Scope OTEL promise domain to startApp() setup and service loop

`local_otel_promise_domain()` binds the domain to the caller's frame,
which in `startApp()` exits before any request is served. A persistent
global install would leak into unrelated user promises between ticks.

Wrap the synchronous setup phase and each service iteration in
`with_otel_promise_domain()`. Callbacks are wrapped at registration
time, so promises created during `onStart`, handlers, and observers
stay instrumented when they fire. The domain is dormant between ticks,
so it stays out of user promises at the console.

.Rbuildignore

@@ -32,3 +32,6 @@
 ^eslint\.config\.mjs$
 ^_dev$
 ^.claude$
+^README-npm\.md$
+^CRAN-SUBMISSION$
+^LICENSE\.md$

.github/workflows/R-CMD-check.yaml

@@ -6,7 +6,7 @@ on:
   push:
     branches: [main, rc-**]
   pull_request:
-    branches: [main]
+    branches:
   schedule:
     - cron: "0 5 * * 1" # every monday
 

.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.13.0.9000
 Authors@R: c(
     person("Winston", "Chang", , "winston@posit.co", role = "aut",
            comment = c(ORCID = "0000-0002-1576-2126")),
@@ -60,10 +60,6 @@ Authors@R: c(
            comment = "Javascript strftime library"),
     person(, "SpryMedia Limited", role = c("ctb", "cph"),
            comment = "DataTables library"),
-    person("John", "Fraser", role = c("ctb", "cph"),
-           comment = "showdown.js library"),
-    person("John", "Gruber", role = c("ctb", "cph"),
-           comment = "showdown.js library"),
     person("Ivan", "Sagalaev", role = c("ctb", "cph"),
            comment = "highlight.js library"),
     person("R Core Team", role = c("ctb", "cph"),
@@ -73,17 +69,17 @@ Description: Makes it incredibly easy to build interactive web
     applications with R. Automatic "reactive" binding between inputs and
     outputs and extensive prebuilt widgets make it possible to build
     beautiful, responsive, and powerful applications with minimal effort.
-License: GPL-3 | file LICENSE
+License: MIT + file LICENSE
 URL: https://shiny.posit.co/, https://github.com/rstudio/shiny
 BugReports: https://github.com/rstudio/shiny/issues
 Depends:
     methods,
-    R (>= 3.0.2)
+    R (>= 3.1.2)
 Imports:
     bslib (>= 0.6.0),
     cachem (>= 1.1.0),
     cli,
-    commonmark (>= 1.7),
+    commonmark (>= 2.0.0),
     fastmap (>= 1.1.1),
     fontawesome (>= 0.4.0),
     glue (>= 1.3.2),
@@ -94,7 +90,8 @@ Imports:
     later (>= 1.0.0),
     lifecycle (>= 0.2.0),
     mime (>= 0.3),
-    promises (>= 1.3.2),
+    otel,
+    promises (>= 1.5.0),
     R6 (>= 2.0),
     rlang (>= 0.4.10),
     sourcetools,
@@ -114,6 +111,7 @@ Suggests:
     magrittr,
     markdown,
     mirai,
+    otelsdk (>= 0.2.0),
     ragg,
     reactlog (>= 1.0.0),
     rmarkdown,
@@ -128,6 +126,7 @@ Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.3.3
 Collate:
+    'app-handle.R'
     'globals.R'
     'app-state.R'
     'app_template.R'
@@ -185,6 +184,15 @@ Collate:
     'modal.R'
     'modules.R'
     'notifications.R'
+    'otel-attr-srcref.R'
+    'otel-collect.R'
+    'otel-enable.R'
+    'otel-error.R'
+    'otel-label.R'
+    'otel-reactive-update.R'
+    'otel-session.R'
+    'otel-shiny.R'
+    'otel-with.R'
     'priorityqueue.R'
     'progress.R'
     'react.R'

LICENSE.md

@@ -0,0 +1,21 @@
+# MIT License
+
+Copyright (c) 2025 shiny authors
+
+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.

NAMESPACE

@@ -165,6 +165,7 @@ export(isTruthy)
 export(isolate)
 export(key_missing)
 export(loadSupport)
+export(localOtelCollect)
 export(mainPanel)
 export(makeReactiveBinding)
 export(markRenderFunction)
@@ -275,6 +276,7 @@ export(snapshotPreprocessInput)
 export(snapshotPreprocessOutput)
 export(span)
 export(splitLayout)
+export(startApp)
 export(stopApp)
 export(strong)
 export(submitButton)
@@ -329,6 +331,7 @@ export(verticalLayout)
 export(wellPanel)
 export(withLogErrors)
 export(withMathJax)
+export(withOtelCollect)
 export(withProgress)
 export(withReactiveDomain)
 export(withTags)
@@ -387,10 +390,13 @@ importFrom(lifecycle,is_present)
 importFrom(promises,"%...!%")
 importFrom(promises,"%...>%")
 importFrom(promises,as.promise)
+importFrom(promises,hybrid_then)
+importFrom(promises,is.promise)
 importFrom(promises,is.promising)
-importFrom(promises,promise)
+importFrom(promises,new_promise_domain)
 importFrom(promises,promise_reject)
 importFrom(promises,promise_resolve)
+importFrom(promises,with_promise_domain)
 importFrom(rlang,"%||%")
 importFrom(rlang,"fn_body<-")
 importFrom(rlang,"fn_fmls<-")

NEWS.md

@@ -2,17 +2,151 @@
 
 ## New features
 
-* The `icon` argument of `updateActionButton()`/`updateActionLink()` nows allows values other than `shiny::icon()` (e.g., `fontawesome::fa()`, `bsicons::bs_icon()`, etc). (#4249)
+* New `startApp()` runs a Shiny app in non-blocking mode, returning a
+  `ShinyAppHandle` object with `stop()`, `status()`, `url()`, and `result()`
+  methods. When a new app is started, any previously running non-blocking app
+  is automatically stopped.
 
-## Bug fixes
+# shiny 1.13.0
 
-* `updateActionButton()`/`updateActionLink()` now correctly renders HTML content passed to the `label` argument. (#4249)
+## New features
 
-* Fixed an issue where `updateSelectizeInput(options = list(plugins="remove_button"))` could lead to multiple remove buttons. (#4275)
+* Shiny now supports interactive breakpoints when used with Ark (e.g. in Positron). (#4352)
 
-## Changes
+## Bug fixes and minor improvements
 
-* 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. 
+* Stack traces from render functions (e.g., `renderPlot()`, `renderDataTable()`) now hide internal Shiny rendering pipeline frames, making error messages cleaner and more focused on user code. (#4358)
+
+* Fixed an issue with `actionLink()` that extended the link underline to whitespace around the text. (#4348)
+
+
+# shiny 1.12.1
+
+## New features
+
+* `withOtelCollect()` and `localOtelCollect()` temporarily control
+  OpenTelemetry collection levels during reactive expression creation,
+  allowing you to enable or disable telemetry collection for specific modules
+  or sections of code. (#4333)
+
+## Bug fixes and minor improvements
+
+* OpenTelemetry code attributes now include both the preferred attribute names
+  (`code.file.path`, `code.line.number`, `code.column.number`) and the
+  deprecated names (`code.filepath`, `code.lineno`, `code.column`) to follow
+  OpenTelemetry semantic conventions while maintaining backward compatibility.
+  The deprecated names will be removed in a future release after Logfire
+  supports the preferred names. (#4325)
+
+* `ExtendedTask` now captures the OpenTelemetry recording state at
+  initialization time rather than at invocation time, ensuring consistent span
+  recording behavior regardless of runtime configuration changes. (#4334)
+
+* Timer tests are now skipped on CRAN. (#4327)
+
+# shiny 1.12.0
+
+## OpenTelemetry support
+
+* Shiny now supports [OpenTelemetry](https://opentelemetry.io/) via
+  [`{otel}`](https://otel.r-lib.org/index.html). By default, if
+  `otel::is_tracing_enabled()` returns `TRUE`, then `{shiny}` records all
+  OpenTelemetry spans. See [`{otelsdk}`'s Collecting Telemetry
+  Data](https://otelsdk.r-lib.org/reference/collecting.html) for more details
+  on configuring OpenTelemetry. (#4269, #4300)
+
+* Supported values for `options(shiny.otel.collect)` (or
+  `Sys.getenv("SHINY_OTEL_COLLECT")`):
+  * `"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"`.
+
+* OpenTelemetry 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.
+  * `reactiveFileReader`, `reactivePoll`: Captures the calculation
+    (including any async promise chains) of a `reactiveFileReader()` or
+    `reactivePoll()`.
+  * `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 unsanitize 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 OpenTelemetry logs and spans will contain a `session.id` attribute
+  containing the active session ID.
+
+## New features
+
+* `updateActionButton()` and `updateActionLink()` now accept values other than
+  `shiny::icon()` for the `icon` argument (e.g., `fontawesome::fa()`,
+  `bsicons::bs_icon()`, etc). (#4249)
+
+## Bug fixes and minor improvements
+
+* Showcase mode now uses server-side markdown rendering with the
+  `{commonmark}` package, providing support for GitHub Flavored Markdown
+  features (tables, strikethrough, autolinks, task lists). While most existing
+  README.md files should continue to work as expected, some minor rendering
+  differences may occur due to the change in markdown processor. (#4202,
+  #4201)
+
+* `debounce()`, `reactiveFileReader()`, `reactivePoll()`, `reactiveValues()`,
+  and `throttle()` now attempt to retrieve the assigned name for the default
+  label if the srcref is available. If a value cannot easily be produced, a
+  default label is used instead. (#4269, #4300)
+
+* 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()`
+
+* `updateActionButton()` and `updateActionLink()` now correctly render HTML
+  content passed to the `label` argument. (#4249)
+
+* `updateSelectizeInput()` no longer creates multiple remove buttons when
+  `options = list(plugins="remove_button")` is used. (#4275)
+
+* `dateRangeInput()`/`updateDateRangeInput()` now correctly considers the time
+  zones of date-time objects (POSIXct) passed to the `start`, `end`, `min` and
+  `max` arguments. (thanks @ismirsehregal, #4318)
+
+## Breaking changes
+
+* The return value of `actionButton()` and `actionLink()` now wraps `label`
+  and `icon` in an additional HTML container element. This allows
+  `updateActionButton()` and `updateActionLink()` to distinguish between the
+  `label` and `icon` when making updates, and allows spacing between `label`
+  and `icon` to be more easily customized via CSS.
 
 # shiny 1.11.1
 
@@ -684,7 +818,7 @@ This release features plot caching, an important new tool for improving performa
 
 ### Minor new features and improvements
 
-* Upgrade FontAwesome from 4.7.0 to 5.3.1 and made `icon` tags browsable, which means they will display in a web browser or RStudio viewer by default (#2186). Note that if your application or library depends on FontAwesome directly using custom CSS, you may need to make some or all of the changes recommended in [Upgrade from Version 4](https://fontawesome.com/how-to-use/on-the-web/setup/upgrading-from-version-4). Font Awesome icons can also now be used in static R Markdown documents.
+* Upgrade FontAwesome from 4.7.0 to 5.3.1 and made `icon` tags browsable, which means they will display in a web browser or RStudio viewer by default (#2186). Note that if your application or library depends on FontAwesome directly using custom CSS, you may need to make some or all of the changes recommended in [Upgrade from Version 4](https://docs-v5.fontawesome.com/web/setup/upgrade-from-v4). Font Awesome icons can also now be used in static R Markdown documents.
 
 * Address #174: Added `datesdisabled` and `daysofweekdisabled` as new parameters to `dateInput()`. This resolves #174 and exposes the underlying arguments of [Bootstrap Datepicker](http://bootstrap-datepicker.readthedocs.io/en/latest/options.html#datesdisabled). `datesdisabled` expects a character vector with values in `yyyy/mm/dd` format and `daysofweekdisabled` expects an integer vector with day interger ids (Sunday=0, Saturday=6). The default value for both is `NULL`, which leaves all days selectable. Thanks, @nathancday! (#2147)
 

R/app-handle.R

@@ -0,0 +1,73 @@
+# Handle returned by startApp()
+ShinyAppHandle <- R6::R6Class("ShinyAppHandle",
+  cloneable = FALSE,
+
+  public = list(
+    initialize = function(appUrl, cleanupFn) {
+      private$appUrl <- appUrl
+      private$cleanupFn <- cleanupFn
+
+      reg.finalizer(self, function(e) {
+        tryCatch(e$stop(), error = function(cnd) NULL)
+      }, onexit = TRUE)
+    },
+
+    stop = function() {
+      if (self$status() != "running") {
+        return(invisible(self))
+      }
+      private$stopped <- TRUE
+      private$captureResult()
+      private$cleanupFn()
+      private$cleanupFn <- NULL
+      invisible(self)
+    },
+
+    url = function() private$appUrl,
+
+    status = function() {
+      if (!private$stopped) {
+        "running"
+      } else if (!is.null(private$resultError)) {
+        "error"
+      } else {
+        "success"
+      }
+    },
+
+    result = function() {
+      if (self$status() == "running") {
+        stop("App is still running. Use status() to check if the app has stopped.")
+      }
+      if (!is.null(private$resultError)) {
+        stop(private$resultError)
+      }
+      private$resultValue
+    },
+
+    print = function(...) {
+      cat("Shiny app handle\n")
+      cat("  URL:   ", private$appUrl, "\n", sep = "")
+      cat("  Status:", self$status(), "\n")
+      invisible(self)
+    }
+  ),
+
+  private = list(
+    appUrl = NULL,
+    cleanupFn = NULL,
+    # Whether this handle has been stopped. Distinct from .globals$stopped
+    # which tracks whether a stop was requested (set by stopApp() or stop()).
+    stopped = FALSE,
+    resultValue = NULL,
+    resultError = NULL,
+
+    captureResult = function() {
+      if (isTRUE(.globals$reterror)) {
+        private$resultError <- .globals$retval
+      } else if (!is.null(.globals$retval)) {
+        private$resultValue <- .globals$retval$value
+      }
+    }
+  )
+)

R/bind-cache.R

@@ -478,7 +478,12 @@ bindCache.default <- function(x, ...) {
 bindCache.reactiveExpr <- function(x, ..., cache = "app") {
   check_dots_unnamed()
 
-  label <- exprToLabel(substitute(key), "cachedReactive")
+  call_srcref <- get_call_srcref(-1)
+  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,24 +495,37 @@ 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:
   # 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)
   }
 
-
-  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_collect({
+    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))
+
+  local({
+    impl <- attr(res, "observable", exact = TRUE)
+    impl$.otelAttrs <- append_otel_srcref_attrs(x_otel_attrs, call_srcref, fn_name = "bindCache")
+  })
+
+  if (has_otel_collect("reactivity")) {
+    res <- enable_otel_reactive_expr(res)
+  }
   res
 }
 
@@ -534,6 +552,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 +604,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,31 +196,58 @@ 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 <- get_call_srcref(-1)
+  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)
 
   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_collect({
+    res <- reactive(label = label, domain = domain, ..stacktraceon = FALSE, {
+      hybrid_chain(
+        {
+          eventFunc()
+        },
+        function(value) {
+          if (ignoreInit && !initialized) {
+            initialized <<- TRUE
+            req(FALSE)
+          }
+
+          req(!ignoreNULL || !isNullEvent(value))
+
+          isolate(valueFunc())
         }
-
-        req(!ignoreNULL || !isNullEvent(value))
-
-        isolate(valueFunc())
-      }
-    )
+      )
+    })
   })
 
-  class(res) <- c("reactive.event", class(res))
+  class(res) <- c("reactive.event", x_classes)
+
+  local({
+    impl <- attr(res, "observable", exact = TRUE)
+    impl$.otelAttrs <- append_otel_srcref_attrs(x_otel_attrs, call_srcref, fn_name = "bindEvent")
+  })
+
+
+  if (has_otel_collect("reactivity")) {
+    res <- enable_otel_reactive_expr(res)
+  }
+
   res
 }
 
@@ -249,6 +276,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
@@ -269,7 +297,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 <- get_call_srcref(-1)
+    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
 
@@ -302,6 +340,13 @@ bindEvent.Observer <- function(x, ..., ignoreNULL = TRUE, ignoreInit = FALSE,
   )
 
   class(x) <- c("Observer.event", class(x))
+  call_srcref <- get_call_srcref(-1)
+  x$.otelAttrs <- append_otel_srcref_attrs(x$.otelAttrs, call_srcref, fn_name = "bindEvent")
+
+  if (has_otel_collect("reactivity")) {
+    x <- enable_otel_observe(x)
+  }
+
   invisible(x)
 }
 

R/conditions.R

@@ -87,13 +87,61 @@ getCallNamesForHash <- function(calls) {
   })
 }
 
+# Get the preferred filename from a srcfile object.
+#
+# For user code, prefer the original path (as typed by user, potentially a
+# symlink or relative path) over the normalized absolute path.
+#
+# For package files (under .libPaths()), keep the srcfile$filename because
+# when a package is installed with keep.source.pkgs = TRUE, the original
+# srcfilecopy filename may point to a collated build-time path rather than
+# the real installed package path.
+getSrcfileFilename <- function(srcfile) {
+  if (!is.null(srcfile$original) &&
+      !is.null(srcfile$original$filename) &&
+      !isPackageFile(srcfile$filename)) {
+    srcfile$original$filename
+  } else {
+    srcfile$filename
+  }
+}
+
+# Get the source lines and correct line number from a srcfile + srcref.
+#
+# sourceUTF8() wraps user code with a `#line` directive that remaps line
+# numbers. This means srcref[1] (the remapped line) may not correctly index
+# into the srcfile's $lines. When a #line directive is present, R extends
+# the srcref to 8 elements: [7] and [8] are the original (pre-remap) first
+# and last line numbers in the srcfilecopy's coordinate system.
+#
+# Additionally, when the #line path differs from the srcfilecopy filename
+# (e.g. macOS /tmp -> /private/tmp, or Windows path normalization), R wraps
+# the srcfile in a srcfilealias whose $lines is NULL. In that case, we
+# retrieve lines from the original srcfilecopy via $original.
+getSrcfileLines <- function(srcfile, srcref) {
+  lines <- srcfile$lines
+  line_num <- srcref[1]
+
+  if (is.null(lines) && inherits(srcfile, "srcfilealias")) {
+    lines <- srcfile$original$lines
+  }
+
+  # Use the pre-remap line number when available and different from the
+  # remapped line, indicating a #line directive shifted line numbering.
+  if (isTRUE(length(srcref) >= 7 && srcref[7] != srcref[1])) {
+    line_num <- srcref[7]
+  }
+
+  list(lines = lines, line_num = line_num)
+}
+
 getLocs <- function(calls) {
   vapply(calls, function(call) {
     srcref <- attr(call, "srcref", exact = TRUE)
     if (!is.null(srcref)) {
       srcfile <- attr(srcref, "srcfile", exact = TRUE)
       if (!is.null(srcfile) && !is.null(srcfile$filename)) {
-        loc <- paste0(srcfile$filename, "#", srcref[[1]])
+        loc <- paste0(getSrcfileFilename(srcfile), "#", srcref[[1]])
         return(paste0(" [", loc, "]"))
       }
     }
@@ -101,13 +149,36 @@ getLocs <- function(calls) {
   }, character(1))
 }
 
+# Check if a file path is in an R package library
+isPackageFile <- function(filepath) {
+  if (is.null(filepath) || filepath == "") {
+    return(FALSE)
+  }
+
+  # Normalize paths for comparison
+  filepath <- normalizePath(filepath, winslash = "/", mustWork = FALSE)
+  lib_paths <- normalizePath(.libPaths(), winslash = "/", mustWork = FALSE)
+  # Ensure trailing slash for proper path-boundary matching, otherwise
+  # e.g. "/usr/lib/R" would incorrectly match "/usr/lib/Rcpp/..."
+  lib_paths <- paste0(sub("/$", "", lib_paths), "/")
+
+  # Check if the file is under any library path
+  any(vapply(
+    lib_paths,
+    function(lib) identical(substr(filepath, 1, nchar(lib)), lib),
+    logical(1)
+  ))
+}
+
 getCallCategories <- function(calls) {
   vapply(calls, function(call) {
     srcref <- attr(call, "srcref", exact = TRUE)
     if (!is.null(srcref)) {
       srcfile <- attr(srcref, "srcfile", exact = TRUE)
-      if (!is.null(srcfile)) {
-        if (!is.null(srcfile$original)) {
+      if (!is.null(srcfile) && !is.null(srcfile$filename)) {
+        # Use the absolute path for package detection (srcfile$filename)
+        # rather than the original path which might be relative
+        if (isPackageFile(srcfile$filename)) {
           return("pkg")
         } else {
           return("user")
@@ -134,7 +205,9 @@ getCallCategories <- function(calls) {
 #' @rdname stacktrace
 #' @export
 captureStackTraces <- function(expr) {
-  promises::with_promise_domain(createStackTracePromiseDomain(),
+  # Use `promises::` as it shows up in the stack trace
+  promises::with_promise_domain(
+    createStackTracePromiseDomain(),
     expr
   )
 }
@@ -184,7 +257,7 @@ createStackTracePromiseDomain <- function() {
   # These are actually stateless, we wouldn't have to create a new one each time
   # if we didn't want to. They're pretty cheap though.
 
-  d <- promises::new_promise_domain(
+  d <- new_promise_domain(
     wrapOnFulfilled = function(onFulfilled) {
       force(onFulfilled)
       # Subscription time
@@ -278,7 +351,7 @@ withLogErrors <- function(expr,
       result <- captureStackTraces(expr)
 
       # Handle expr being an async operation
-      if (promises::is.promise(result)) {
+      if (is.promise(result)) {
         result <- promises::catch(result, function(cond) {
           # Don't print shiny.silent.error (i.e. validation errors)
           if (cnd_inherits(cond, "shiny.silent.error")) {
@@ -443,45 +516,93 @@ printOneStackTrace <- function(stackTrace, stripResult, full, offset) {
   invisible(st)
 }
 
+# Filter stack traces using fence markers to hide internal Shiny frames.
+#
+# `stackTraces` is a list of character vectors (call names), one per "segment".
+# A single synchronous error produces one segment (the immediate call stack).
+# Asynchronous errors (e.g. from promises) produce multiple segments: the deep
+# stack trace segments come first, then the current segment last. Each deep
+# segment may begin with frames that overlap the previous segment; a
+# `..stacktracefloor..` marker delimits this redundant prefix from the active
+# portion.
+#
+# Within the active frames, `..stacktraceon..` / `..stacktraceoff..` markers
+# act as fences. Frames between a matched off/on pair (reading innermost to
+# outermost) are hidden — these are the internal rendering pipeline frames
+# that users don't need to see. The algorithm uses a *reverse clamped cumulative
+# sum* so that an unmatched `..stacktraceoff..` (one with no corresponding
+# inner `..stacktraceon..`) is a no-op, preventing it from hiding user frames.
+# Fence matching works globally across segments so that a `..stacktraceoff..`
+# at the end of one segment can pair with a `..stacktraceon..` at the start
+# of the next.
 stripStackTraces <- function(stackTraces, values = FALSE) {
-  score <- 1L  # >=1: show, <=0: hide
-  lapply(seq_along(stackTraces), function(i) {
-    res <- stripOneStackTrace(stackTraces[[i]], i != 1, score)
-    score <<- res$score
-    toShow <- as.logical(res$trace)
-    if (values) {
-      as.character(stackTraces[[i]][toShow])
-    } else {
-      as.logical(toShow)
+  n_segs <- length(stackTraces)
+  if (n_segs == 0L) return(list())
+
+  # Replace NULL segments with empty character vectors
+  stackTraces <- lapply(stackTraces, function(st) st %||% character(0))
+  seg_lengths <- lengths(stackTraces)
+  total <- sum(seg_lengths)
+
+  if (total == 0L) {
+    return(lapply(seg_lengths, function(n) {
+      if (values) character(0) else logical(0)
+    }))
+  }
+
+  # Pre-compute segment boundaries (used in steps 1 and 4)
+  seg_ends <- cumsum(seg_lengths)
+  seg_starts <- c(1L, seg_ends[-n_segs] + 1L)
+
+  # Concatenate all segments into one vector for vectorized operations
+  all <- unlist(stackTraces)
+
+  # 1. Identify prefix elements (at/before last ..stacktracefloor.. in segs 2+)
+  # Prefix elements are always hidden and excluded from fence scoring.
+  is_active <- rep.int(TRUE, total)
+  if (n_segs >= 2L) {
+    for (i in 2:n_segs) {
+      if (seg_lengths[i] == 0L) next
+      seg_idx <- seg_starts[i]:seg_ends[i]
+      floor_pos <- which(all[seg_idx] == "..stacktracefloor..")
+      if (length(floor_pos)) {
+        is_active[seg_idx[seq_len(floor_pos[length(floor_pos)])]] <- FALSE
+      }
     }
+  }
+
+  # 2. Compute fence scores and marker mask (vectorized across all segments)
+  is_on <- all == "..stacktraceon.."
+  is_off <- all == "..stacktraceoff.."
+  is_marker <- is_on | is_off | (all == "..stacktracefloor..")
+  scores <- integer(total)
+  scores[is_active & is_on] <- 1L
+  scores[is_active & is_off] <- -1L
+
+  # 3. Reverse clamped cumsum across all segments.
+  # Process from innermost (right) to outermost (left). ..stacktraceon.. (+1)
+  # opens a hidden region working outward, ..stacktraceoff.. (-1) closes it.
+  # Clamping at 0 means an unmatched ..stacktraceoff.. (one with no inner
+  # ..stacktraceon..) is a no-op. Prefix elements have score 0 and pass the
+  # running total through unchanged.
+  #
+  # Vectorized via the identity: clamped_cumsum = cumsum - pmin(0, cummin(cumsum))
+  rs <- rev(scores)
+  cs <- cumsum(rs)
+  depth <- rev(cs - pmin.int(0L, cummin(cs)))
+
+  # 4. Compute visibility (vectorized) and split back into segments
+  toShow <- is_active & depth == 0L & !is_marker
+
+  lapply(seq_len(n_segs), function(i) {
+    if (seg_lengths[i] == 0L) {
+      if (values) return(character(0)) else return(logical(0))
+    }
+    idx <- seg_starts[i]:seg_ends[i]
+    if (values) as.character(all[idx[toShow[idx]]]) else toShow[idx]
   })
 }
 
-stripOneStackTrace <- function(stackTrace, truncateFloor, startingScore) {
-  prefix <- logical(0)
-  if (truncateFloor) {
-    indexOfFloor <- utils::tail(which(stackTrace == "..stacktracefloor.."), 1)
-    if (length(indexOfFloor)) {
-      stackTrace <- stackTrace[(indexOfFloor+1L):length(stackTrace)]
-      prefix <- rep_len(FALSE, indexOfFloor)
-    }
-  }
-
-  if (length(stackTrace) == 0) {
-    return(list(score = startingScore, character(0)))
-  }
-
-  score <- rep.int(0L, length(stackTrace))
-  score[stackTrace == "..stacktraceon.."] <- 1L
-  score[stackTrace == "..stacktraceoff.."] <- -1L
-  score <- startingScore + cumsum(score)
-
-  toShow <- score > 0 & !(stackTrace %in% c("..stacktraceon..", "..stacktraceoff..", "..stacktracefloor.."))
-
-
-  list(score = utils::tail(score, 1), trace = c(prefix, toShow))
-}
-
 # Given sys.parents() (which corresponds to sys.calls()), return a logical index
 # that prunes each subtree so that only the final branch remains. The result,
 # when applied to sys.calls(), is a linear list of calls without any "wrapper"
@@ -556,8 +677,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

@@ -41,6 +41,28 @@
 #'   is, a function that quickly returns a promise) and allows even that very
 #'   session to immediately unblock and carry on with other user interactions.
 #'
+#' @section OpenTelemetry Integration:
+#'
+#' When an `ExtendedTask` is created, if OpenTelemetry tracing is enabled for
+#' `"reactivity"` (see [withOtelCollect()]), the `ExtendedTask` will record
+#' spans for each invocation of the task. The tracing level at `invoke()` time
+#' does not affect whether spans are recorded; only the tracing level when
+#' calling `ExtendedTask$new()` matters.
+#'
+#' The OTel span will be named based on the label created from the variable the
+#' `ExtendedTask` is assigned to. If no label can be determined, the span will
+#' be named `<anonymous>`. Similar to other Shiny OpenTelemetry spans, the span
+#' will also include source reference attributes and session ID attributes.
+#'
+#' ```r
+#' withOtelCollect("all", {
+#'   my_task <- ExtendedTask$new(function(...) { ... })
+#' })
+#'
+#' # Span recorded for this invocation: ExtendedTask my_task
+#' my_task$invoke(...)
+#' ```
+#'
 #' @examplesIf rlang::is_interactive() && rlang::is_installed("mirai")
 #' library(shiny)
 #' library(bslib)
@@ -116,10 +138,37 @@ 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_collect({
+        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()
+
+      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 <- get_call_srcref(-1)
+      label <- rassignSrcrefToLabel(
+        call_srcref,
+        defaultLabel = "<anonymous>"
+      )
+      private$otel_span_label <- otel_span_label_extended_task(label, domain = domain)
+      private$otel_log_label_add_to_queue <- otel_log_label_extended_task_add_to_queue(label, domain = domain)
+
+      private$otel_attrs <- c(
+        otel_srcref_attributes(call_srcref, "ExtendedTask"),
+        otel_session_id_attrs(domain)
+      ) %||% list()
+
+      # Capture this value at init-time, not run-time
+      # This way, the span is only created if otel was enabled at time of creation... just like other spans
+      private$is_recording_otel <- has_otel_collect("reactivity")
     },
     #' @description
     #' Starts executing the long-running operation. If this `ExtendedTask` is
@@ -139,8 +188,27 @@ ExtendedTask <- R6Class("ExtendedTask", portable = TRUE, cloneable = FALSE,
         isolate(private$rv_status()) == "running" ||
           private$invocation_queue$size() > 0
       ) {
+        otel_log(
+          private$otel_log_add_to_queue_label,
+          severity = "debug",
+          attributes = c(
+            private$otel_attrs,
+            list(
+              queue_size = private$invocation_queue$size() + 1L
+            )
+          )
+        )
         private$invocation_queue$add(list(args = args, call = call))
       } else {
+
+        if (private$is_recording_otel) {
+          private$otel_span <- start_otel_span(
+            private$otel_span_label,
+            attributes = private$otel_attrs
+          )
+          otel::local_active_span(private$otel_span)
+        }
+
         private$do_invoke(args, call = call)
       }
       invisible(NULL)
@@ -188,7 +256,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 {
@@ -208,21 +276,36 @@ ExtendedTask <- R6Class("ExtendedTask", portable = TRUE, cloneable = FALSE,
     rv_error = NULL,
     invocation_queue = NULL,
 
+    otel_span_label = NULL,
+    otel_log_label_add_to_queue = NULL,
+    otel_attrs = list(),
+    is_recording_otel = FALSE,
+    otel_span = NULL,
+
     do_invoke = function(args, call = NULL) {
       private$rv_status("running")
       private$rv_value(NULL)
       private$rv_error(NULL)
 
-      p <- promises::promise_resolve(
+      p <- promise_resolve(
         maskReactiveContext(do.call(private$func, args))
       )
 
       p <- promises::then(
         p,
         onFulfilled = function(value, .visible) {
+          if (is_otel_span(private$otel_span)) {
+
+            private$otel_span$end(status_code = "ok")
+            private$otel_span <- NULL
+          }
           private$on_success(list(value = value, visible = .visible))
         },
         onRejected = function(error) {
+          if (is_otel_span(private$otel_span)) {
+            private$otel_span$end(status_code = "error")
+            private$otel_span <- 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/imageutils.R

@@ -100,7 +100,7 @@ plotPNG <- function(func, filename=tempfile(fileext='.png'),
 createGraphicsDevicePromiseDomain <- function(which = dev.cur()) {
   force(which)
 
-  promises::new_promise_domain(
+  new_promise_domain(
     wrapOnFulfilled = function(onFulfilled) {
       force(onFulfilled)
       function(...) {

R/input-action.R

@@ -59,11 +59,11 @@ actionButton <- function(inputId, label, icon = NULL, width = NULL,
   icon <- validateIcon(icon)
 
   if (!is.null(icon)) {
-    icon <- span(icon, class = "action-icon")
+    icon <- span(icon, class = "action-icon", .noWS = c("outside", "inside"))
   }
 
   if (!is.null(label)) {
-    label <- span(label, class = "action-label")
+    label <- span(label, class = "action-label", .noWS = c("outside", "inside"))
   }
 
   tags$button(
@@ -74,6 +74,7 @@ actionButton <- function(inputId, label, icon = NULL, width = NULL,
     `data-val` = value,
     disabled = if (isTRUE(disabled)) NA else NULL,
     icon, label,
+    .noWS = "inside",
     ...
   )
 }
@@ -86,11 +87,11 @@ actionLink <- function(inputId, label, icon = NULL, ...) {
   icon <- validateIcon(icon)
 
   if (!is.null(icon)) {
-    icon <- span(icon, class = "action-icon")
+    icon <- span(icon, class = "action-icon", .noWS = c("outside", "inside"))
   }
 
   if (!is.null(label)) {
-    label <- span(label, class = "action-label")
+    label <- span(label, class = "action-label", .noWS = c("outside", "inside"))
   }
 
   tags$a(
@@ -99,6 +100,7 @@ actionLink <- function(inputId, label, icon = NULL, ...) {
     class = "action-button action-link",
     `data-val` = value,
     icon, label,
+    .noWS = "inside",
     ...
   )
 }

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_collect({
+        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 (!is.promise(v)){
+              # Make our sync value into a promise
+              prom <- promise_resolve(v)
+            } else {
+              prom <- v
             }
-            list(val = NULL, err = e)
+          }, error=function(e){
+            # Error running value()
+            prom <<- promise_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)
     },
@@ -716,7 +718,7 @@ MockShinySession <- R6Class(
         stop("Nested calls to withCurrentOutput() are not allowed.")
       }
 
-      promises::with_promise_domain(
+      with_promise_domain(
         createVarPromiseDomain(private, "currentOutputName", name),
         expr
       )

R/otel-attr-srcref.R

@@ -0,0 +1,67 @@
+
+
+# Very similar to srcrefFromShinyCall(),
+# however, this works when the function does not have a srcref attr set
+otel_srcref_attributes <- function(srcref, fn_name = NULL) {
+  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
+  srcfile <- attr(srcref, "srcfile")
+  # Prefer the original filename (as user typed it) over the normalized path
+  filename <- getSrcfileFilename(srcfile)
+  dropNulls(list(
+    "code.function.name" = fn_name,
+    # Location attrs
+    "code.file.path" = filename,
+    "code.line.number" = srcref[1],
+    "code.column.number" = srcref[2],
+    # Remove these deprecated location names once Logfire supports the preferred names
+    # https://github.com/pydantic/logfire/issues/1559
+    "code.filepath" = filename,
+    "code.lineno" = srcref[1],
+    "code.column" = srcref[2]
+  ))
+}
+
+#' Get the srcref for the call at the specified stack level
+#'
+#' If you need to go farther back in the `sys.call()` stack, supply a larger
+#' negative number to `which_offset`. The default of 0 gets the immediate
+#' caller. `-1` would get the caller's caller, and so on.
+#' @param which_offset The stack level to get the call from. Defaults to -1 (the
+#'   immediate caller).
+#' @return An srcref object, or NULL if none is found.
+#' @noRd
+get_call_srcref <- function(which_offset = 0) {
+  # Go back one call to account for this function itself
+  call <- sys.call(which_offset - 1)
+
+  srcref <- attr(call, "srcref", exact = TRUE)
+  srcref
+}
+
+
+append_otel_srcref_attrs <- function(attrs, call_srcref, fn_name) {
+  if (is.null(call_srcref)) {
+    return(attrs)
+  }
+
+  srcref_attrs <- otel_srcref_attributes(call_srcref, fn_name)
+  if (is.null(srcref_attrs)) {
+    return(attrs)
+  }
+
+  attrs[names(srcref_attrs)] <- srcref_attrs
+
+  attrs
+}

R/otel-collect.R

@@ -0,0 +1,55 @@
+otel_collect_choices <- c(
+  "none",
+  "session",
+  "reactive_update",
+  "reactivity",
+  "all"
+)
+
+# Check if the collect level is sufficient
+otel_collect_is_enabled <- function(
+  impl_level,
+  # Listen to option and fall back to the env var
+  opt_collect_level = getOption("shiny.otel.collect", Sys.getenv("SHINY_OTEL_COLLECT", "all"))
+) {
+  opt_collect_level <- as_otel_collect(opt_collect_level)
+
+  which(opt_collect_level == otel_collect_choices) >=
+    which(impl_level == otel_collect_choices)
+}
+
+# Check if tracing is enabled and if the collect level is sufficient
+has_otel_collect <- function(collect) {
+  # Only check pkg author input iff loaded with pkgload
+  if (IS_SHINY_LOCAL_PKG) {
+    stopifnot(length(collect) == 1, any(collect == otel_collect_choices))
+  }
+
+  otel_is_tracing_enabled() && otel_collect_is_enabled(collect)
+}
+
+# Run expr with otel collection disabled
+with_no_otel_collect <- function(expr) {
+  withOtelCollect("none", expr)
+}
+
+
+## -- Helpers -----------------------------------------------------
+
+# shiny.otel.collect can be:
+# "none"; To do nothing / fully opt-out
+# "session" for session/start events
+# "reactive_update" (includes "session" features) and reactive_update spans
+# "reactivity" (includes "reactive_update" features) and spans for all reactive things
+# "all" - Anything that Shiny can do. (Currently equivalent to the "reactivity" level)
+
+as_otel_collect <- function(collect = "all") {
+  if (!is.character(collect)) {
+    stop("`collect` must be a character vector.")
+  }
+
+  # Match to collect enum
+  collect <- match.arg(collect, otel_collect_choices, several.ok = FALSE)
+
+  return(collect)
+}

R/otel-enable.R

@@ -0,0 +1,194 @@
+# # Approach
+# Use flags on the reactive object to indicate whether to record OpenTelemetry spans.
+#
+# Cadence:
+# * `$.isRecordingOtel` - Whether to record OpenTelemetry spans for this reactive object
+# * `$.otelLabel` - The label to use for the OpenTelemetry span
+# * `$.otelAttrs` - Additional attributes to add to the OpenTelemetry span
+
+
+#' Add OpenTelemetry for reactivity to an object
+#'
+#' @description
+#'
+#' `enable_otel_*()` methods add OpenTelemetry flags for [reactive()] expressions
+#' and `render*` functions (like [renderText()], [renderTable()], ...).
+#'
+#' Wrapper to creating an active reactive OpenTelemetry span that closes when
+#' the reactive expression is done computing. Typically this is when the
+#' reactive expression finishes (synchronous) or when the returned promise is
+#' done computing (asynchronous).
+
+#' @section Async with OpenTelemetry:
+#'
+#'   With a reactive expression, the key and/or value expression can be
+#'   _asynchronous_. In other words, they can be promises --- not regular R
+#'   promises, but rather objects provided by the
+#'   \href{https://rstudio.github.io/promises/}{\pkg{promises}}  package, which
+#'   are similar to promises in JavaScript. (See [promises::promise()] for more
+#'   information.) You can also use [mirai::mirai()] or [future::future()]
+#'   objects to run code in a separate process or even on a remote machine.
+#'
+#'   When reactive expressions are being calculated in parallel (by having
+#'   another reactive promise compute in the main process), the currently active
+#'   OpenTelemetry span will be dynamically swapped out according to the
+#'   currently active reactive expression. This means that as long as a promise
+#'   was `then()`ed or `catch()`ed with an active OpenTelemetry span, the span
+#'   will be correctly propagated to the next step (and subsequently other
+#'   steps) in the promise chain.
+#'
+#'   While the common case is for a reactive expression to be created
+#'   synchronously, troubles arise when the reactive expression is created
+#'   asynchronously. The span **must** be created before the reactive expression
+#'   is executed, it **must** be active for the duration of the expression, and
+#'   it **must** not be closed until the reactive expression is done executing.
+#'   This is not easily achieved with a single function call, so we provide a
+#'   way to create a reactive expression that is bound to an OpenTelemetry
+#'   span.
+#'
+#' @section Span management and performance:
+#'
+#' Dev note - Barret 2025-10:
+#' Typically, an OpenTelemetry span (`otel_span`) will inherit from the parent
+#' span. This works well and we can think of the hierarchy as a tree. With
+#' `options("shiny.otel.collect" = <value>)`, we are able to control with a sliding
+#' dial how much of the tree we are interested in: "none", "session",
+#' "reactive_update", "reactivity", and finally "all".
+#'
+#' Leveraging this hierarchy, we can avoid creating spans that are not needed.
+#' The act of making a noop span takes on the order of 10microsec. Handling of
+#' the opspan is also in the 10s of microsecond range. We should avoid this when
+#' we **know** that we're not interested in the span.  Therefore, manually
+#' handling spans should be considered for Shiny.
+#'
+#' * Q:
+#'   * But what about app author who want the current span? Is there any
+#'     guarantee that the current span is expected `reactive()` span?
+#' * A:
+#'   * No. The current span is whatever the current span is. If the app author
+#'     wants a specific span, they should create it themselves.
+#' * Proof:
+#'   ```r
+#'   noop <- otel::get_active_span()
+#'   noop$get_context()$get_span_id()
+#'   #> [1] "0000000000000000"
+#'   ignore <- otelsdk::with_otel_record({
+#'     a <- otel::start_local_active_span("a")
+#'     a$get_context()$get_span_id() |> str()
+#'     otel::with_active_span(noop, {
+#'       otel::get_active_span()$get_context()$get_span_id() |> str()
+#'     })
+#'   })
+#'   #> chr "2645e95715841e75"
+#'   #> chr "2645e95715841e75"
+#'   # ## It is reasonable to expect the second id to be `0000000000000000`, but it's not.
+#'   ```
+#'   Therefore, the app author has no guarantee that the current span is the
+#'   span they're expecting. If the app author wants a specific span, they should
+#'   create it themselves and let natural inheritance take over.
+#'
+#' Given this, I will imagine that app authors will set
+#' `options("shiny.otel.collect" = "reactive_update")` as their default behavior.
+#' Enough to know things are happening, but not overwhelming from **everything**
+#' that is reactive.
+#'
+#' To _light up_ a specific area, users can call `withr::with_options(list("shiny.otel.collect" = "all"), { ... })`.
+#'
+#' @param x The object to add caching to.
+#' @param ... Future parameter expansion.
+#' @noRd
+NULL
+
+
+enable_otel_reactive_val <- function(x) {
+
+  impl <- attr(x, ".impl", exact = TRUE)
+  # Set flag for otel logging when setting the value
+  impl$.isRecordingOtel <- TRUE
+
+  class(x) <- c("reactiveVal.otel", class(x))
+
+  x
+}
+
+enable_otel_reactive_values <- function(x) {
+
+  impl <- .subset2(x, "impl")
+  # Set flag for otel logging when setting values
+  impl$.isRecordingOtel <- TRUE
+
+  class(x) <- c("reactivevalues.otel", class(x))
+
+  x
+}
+
+enable_otel_reactive_expr <- function(x) {
+
+  domain <- reactive_get_domain(x)
+
+  impl <- attr(x, "observable", exact = TRUE)
+  impl$.isRecordingOtel <- TRUE
+  # Covers both reactive and reactive.event
+  impl$.otelLabel <- otel_span_label_reactive(x, domain = impl$.domain)
+
+  class(x) <- c("reactiveExpr.otel", class(x))
+
+  x
+}
+
+enable_otel_observe <- function(x) {
+  x$.isRecordingOtel <- TRUE
+  x$.otelLabel <- otel_span_label_observer(x, domain = x$.domain)
+
+  class(x) <- c("Observer.otel", class(x))
+  invisible(x)
+}
+
+
+
+enable_otel_shiny_render_function <- function(x) {
+
+  valueFunc <- force(x)
+  otel_span_label <- NULL
+  otel_span_attrs <- NULL
+
+  renderFunc <- function(...) {
+    # Dynamically determine the span label given the current reactive domain
+    if (is.null(otel_span_label)) {
+      domain <- getDefaultReactiveDomain()
+      otel_span_label <<-
+        otel_span_label_render_function(x, domain = domain)
+      otel_span_attrs <<- c(
+        attr(x, "otelAttrs"),
+        otel_session_id_attrs(domain)
+      )
+    }
+
+    with_otel_span(
+      otel_span_label,
+      {
+        hybrid_then(
+          valueFunc(...),
+          on_failure = set_otel_exception_status_and_throw,
+          # Must save the error object
+          tee = FALSE
+        )
+      },
+      attributes = otel_span_attrs
+    )
+  }
+
+  renderFunc <- addAttributes(renderFunc, renderFunctionAttributes(valueFunc))
+  class(renderFunc) <- c("shiny.render.function.otel", class(valueFunc))
+  renderFunc
+}
+
+
+# ## If we ever expose a S3 function, I'd like to add this method.
+# bindOtel.function <- function(x, ...) {
+#   cli::cli_abort(paste0(
+#     "Don't know how to add OpenTelemetry recording to a plain function. ",
+#     "If this is a {.code render*()} function for Shiny, it may need to be updated. ",
+#     "Please see {.help shiny::bindOtel} for more information."
+#   ))
+# }

R/otel-error.R

@@ -0,0 +1,56 @@
+
+has_seen_otel_exception <- function(cnd) {
+  !is.null(cnd$.shiny_otel_exception)
+}
+
+mark_otel_exception_as_seen <- function(cnd) {
+  cnd$.shiny_otel_exception <- TRUE
+  cnd
+}
+
+set_otel_exception_status_and_throw <- function(cnd) {
+  cnd <- set_otel_exception_status(cnd)
+
+  # Rethrow the (possibly updated) error
+  signalCondition(cnd)
+}
+
+set_otel_exception_status <- function(cnd) {
+  if (inherits(cnd, "shiny.custom.error")) {
+    # No-op
+  } else if (inherits(cnd, "shiny.output.cancel")) {
+    # No-op
+  } else if (inherits(cnd, "shiny.output.progress")) {
+    # No-op
+  } else if (cnd_inherits(cnd, "shiny.silent.error")) {
+    # No-op
+  } else {
+    # Only when an unknown error occurs do we set the span status to error
+    span <- otel::get_active_span()
+
+    # Only record the exception once at the original point of failure,
+    # not every reactive expression that it passes through
+    if (!has_seen_otel_exception(cnd)) {
+      span$record_exception(
+        # Record a sanitized error if sanitization is enabled
+        get_otel_error_obj(cnd)
+      )
+      cnd <- mark_otel_exception_as_seen(cnd)
+    }
+
+    # Record the error status on the span for any context touching this error
+    span$set_status("error")
+  }
+
+  cnd
+}
+
+
+get_otel_error_obj <- function(e) {
+  # Do not expose errors to otel if sanitization is enabled
+  if (getOption("shiny.otel.sanitize.errors", TRUE)) {
+    sanitized_error()
+  } else {
+    e
+  }
+}

R/otel-label.R

@@ -0,0 +1,198 @@
+# observe mymod:<anonymous>
+# observe <anonymous>
+# observe mylabel
+
+# -- Reactives --------------------------------------------------------------
+
+#' OpenTelemetry Label Generation Functions
+#'
+#' Functions for generating formatted labels for OpenTelemetry tracing spans
+#' in Shiny applications. These functions handle module namespacing and
+#' cache/event modifiers for different Shiny reactive constructs.
+#'
+#' @param x The object to generate a label for (reactive, observer, etc.)
+#' @param label Character string label for reactive values
+#' @param key Character string key for reactiveValues operations
+#' @param ... Additional arguments (unused)
+#' @param domain Shiny domain object containing namespace information
+#'
+#' @return Character string formatted for OpenTelemetry span labels
+#' @name otel_label
+#' @noRd
+NULL
+
+otel_span_label_reactive <- function(x, ..., domain) {
+  fn_name <- otel_label_with_modifiers(
+    x,
+    "reactive",
+    cache_class = "reactive.cache",
+    event_class = "reactive.event"
+  )
+
+  label <- attr(x, "observable", exact = TRUE)[[".label"]]
+  otel_span_label <- otel_label_upgrade(label, domain = domain)
+
+  sprintf("%s %s", fn_name, otel_span_label)
+}
+
+otel_span_label_render_function <- function(x, ..., domain) {
+  fn_name <- otel_label_with_modifiers(
+    x,
+    "output",
+    cache_class = "shiny.render.function.cache",
+    event_class = "shiny.render.function.event"
+  )
+
+  label <- getCurrentOutputInfo(session = domain)$name %||% "<unknown>"
+  otel_span_label <- otel_label_upgrade(label, domain = domain)
+
+  sprintf("%s %s", fn_name, otel_span_label)
+}
+
+otel_span_label_observer <- function(x, ..., domain) {
+  fn_name <- otel_label_with_modifiers(
+    x,
+    "observe",
+    cache_class = NULL, # Do not match a cache class here
+    event_class = "Observer.event"
+  )
+
+  otel_span_label <- otel_label_upgrade(x$.label, domain = domain)
+
+  sprintf("%s %s", fn_name, otel_span_label)
+}
+
+# -- Set reactive value(s) ----------------------------------------------------
+
+otel_log_label_set_reactive_val <- function(label, ..., domain) {
+  sprintf(
+    "Set reactiveVal %s",
+    otel_label_upgrade(label, domain = domain)
+  )
+}
+
+otel_log_label_set_reactive_values <- function(label, key, ..., domain) {
+  sprintf(
+    "Set reactiveValues %s$%s",
+    otel_label_upgrade(label, domain = domain),
+    key
+  )
+}
+
+# -- ExtendedTask -------------------------------------------------------------
+
+otel_span_label_extended_task <- function(label, suffix = NULL, ..., domain) {
+  sprintf(
+    "ExtendedTask %s",
+    otel_label_upgrade(label, domain = domain)
+  )
+}
+otel_log_label_extended_task_add_to_queue <- function(label, ..., domain) {
+  sprintf(
+    "ExtendedTask %s add to queue",
+    otel_label_upgrade(label, domain = domain)
+  )
+}
+
+# -- Debounce / Throttle -------------------------------------------------------
+
+otel_label_debounce <- function(label, ..., domain) {
+  sprintf(
+    "debounce %s",
+    otel_label_upgrade(label, domain = domain)
+  )
+}
+
+otel_label_throttle <- function(label, ..., domain) {
+  sprintf(
+    "throttle %s",
+    otel_label_upgrade(label, domain = domain)
+  )
+}
+
+# ---- Reactive Poll / File Reader -----------------------------------------------
+otel_label_reactive_poll <- function(label, ..., domain) {
+  sprintf(
+    "reactivePoll %s",
+    otel_label_upgrade(label, domain = domain)
+  )
+}
+otel_label_reactive_file_reader <- function(label, ..., domain) {
+  sprintf(
+    "reactiveFileReader %s",
+    otel_label_upgrade(label, domain = domain)
+  )
+}
+
+# -- Helpers --------------------------------------------------------------
+
+#' Modify function name based on object class modifiers
+#'
+#' @param x Object to check class of
+#' @param fn_name Base function name
+#' @param cache_class Optional class name that indicates cache operation
+#' @param event_class Optional class name that indicates event operation
+#'
+#' @return Modified function name with "cache" or "event" suffix if applicable
+#' @noRd
+otel_label_with_modifiers <- function(
+  x,
+  fn_name,
+  cache_class = NULL,
+  event_class = NULL
+) {
+  for (x_class in rev(class(x))) {
+    if (!is.null(cache_class) && x_class == cache_class) {
+      fn_name <- sprintf("%s cache", fn_name)
+    } else if (!is.null(event_class) && x_class == event_class) {
+      fn_name <- sprintf("%s event", fn_name)
+    }
+  }
+
+  fn_name
+}
+
+
+#' Upgrade and format OpenTelemetry labels with module namespacing
+#'
+#' Processes labels for OpenTelemetry tracing, replacing default verbose labels
+#' with cleaner alternatives and prepending module namespaces when available.
+#'
+#' @param label Character string label to upgrade
+#' @param ... Additional arguments (unused)
+#' @param domain Shiny domain object containing namespace information
+#'
+#' @return Modified label string with module prefix if applicable
+#' @noRd
+#'
+#' @details
+#' Module prefix examples:
+#' - "" -> ""
+#' - "my-nested-mod-" -> "my-nested-mod"
+otel_label_upgrade <- function(label, ..., domain) {
+  # By default, `observe()` sets the label to `observe(CODE)`
+  # This label is too big and inconsistent.
+  # Replace it with `<anonymous>`
+  # (Similar with `eventReactive()` and `observeEvent()`)
+  if (is_default_label(label) && grepl("(", label, fixed = TRUE)) {
+    label <- "<anonymous>"
+    # label <- sprintf("<anonymous> - %s", label)
+  }
+
+  if (is.null(domain)) {
+    return(label)
+  }
+
+  namespace <- domain$ns("")
+
+  if (!nzchar(namespace)) {
+    return(label)
+  }
+
+  # Remove trailing module separator
+  mod_ns <- sub(sprintf("%s$", ns.sep), "", namespace)
+
+  # Prepend the module name to the label
+  # Ex: `"mymod:x"`
+  sprintf("%s:%s", mod_ns, label)
+}

R/otel-reactive-update.R

@@ -0,0 +1,114 @@
+# * `session$userData[["_otel_span_reactive_update"]]` - The active reactive update span (or `NULL`)
+
+
+#' Start a `reactive_update` OpenTelemetry span and store it
+#'
+#' Used when a reactive expression is updated
+#' Will only start the span iff the otel tracing is enabled
+#' @param ... Ignored
+#' @param domain The reactive domain to associate with the span
+#' @return Invisibly returns.
+#' @seealso `otel_span_reactive_update_teardown()`
+#' @noRd
+otel_span_reactive_update_init <- function(..., domain) {
+
+  if (!has_otel_collect("reactive_update")) return()
+
+  # Ensure cleanup is registered only once per session
+  if (is.null(domain$userData[["_otel_has_reactive_cleanup"]])) {
+    domain$userData[["_otel_has_reactive_cleanup"]] <- TRUE
+
+    # Clean up any dangling reactive spans on an unplanned exit
+    domain$onSessionEnded(function() {
+      otel_span_reactive_update_teardown(domain = domain)
+    })
+  }
+
+  # Safety check
+  if (is_otel_span(domain$userData[["_otel_span_reactive_update"]])) {
+    stop("Reactive update span already exists")
+  }
+
+  domain$userData[["_otel_span_reactive_update"]] <-
+    start_otel_span(
+      "reactive_update",
+      ...,
+      attributes = otel_session_id_attrs(domain)
+    )
+
+  invisible()
+}
+
+#' End a `reactive_update` OpenTelemetry span and remove it from the session
+#' @param ... Ignored
+#' @param domain The reactive domain to associate with the span
+#' @return Invisibly returns.
+#' @seealso `otel_span_reactive_update_init()`
+#' @noRd
+otel_span_reactive_update_teardown <- function(..., domain) {
+  ospan <- domain$userData[["_otel_span_reactive_update"]]
+
+  if (is_otel_span(ospan)) {
+    otel::end_span(ospan)
+    domain$userData[["_otel_span_reactive_update"]] <- NULL
+  }
+
+  invisible()
+}
+
+
+#' Run expr within a `reactive_update` OpenTelemetry span
+#'
+#' Used to wrap the execution of a reactive expression. Will only
+#' require/activate the span iff the otel tracing is enabled
+#' @param expr The expression to executed within the span
+#' @param ... Ignored
+#' @param domain The reactive domain to associate with the span
+#' @noRd
+with_otel_span_reactive_update <- function(expr, ..., domain) {
+  ospan <- domain$userData[["_otel_span_reactive_update"]]
+
+  if (!is_otel_span(ospan)) {
+    return(force(expr))
+  }
+
+  # Given the reactive update span is started before and ended when exec count
+  # is 0, we only need to wrap the expr in the span context
+  otel::with_active_span(ospan, {force(expr)})
+}
+
+
+#' Run expr within `reactive_update` otel span if not already active
+#'
+#' If the reactive update otel span is not already active, run the expression
+#' within the reactive update otel span context. This ensures that nested calls
+#' to reactive expressions do not attempt to re-enter the same span.
+#'
+#' This method is used within Context `run()` and running an Output's observer
+#' implementation
+#' @param expr The expression to executed within the span
+#' @param ... Ignored
+#' @param domain The reactive domain to associate with the span
+#' @noRd
+maybe_with_otel_span_reactive_update <- function(expr, ..., domain) {
+  if (is.null(domain$userData[["_otel_reactive_update_is_active"]])) {
+    domain$userData[["_otel_reactive_update_is_active"]] <- TRUE
+
+    # When the expression is done promising, clear the active flag
+    hybrid_then(
+      {
+        with_otel_span_reactive_update(domain = domain, expr)
+      },
+      on_success = function(value) {
+        domain$userData[["_otel_reactive_update_is_active"]] <- NULL
+      },
+      on_failure = function(e) {
+        domain$userData[["_otel_reactive_update_is_active"]] <- NULL
+      },
+      # Return the value before the callbacks
+      tee = TRUE
+    )
+  } else {
+    expr
+  }
+}

R/otel-session.R

@@ -0,0 +1,96 @@
+# Semantic conventions for session: https://opentelemetry.io/docs/specs/semconv/general/session/
+
+#' Create and use session span and events
+#'
+#' If otel is disabled, the session span and events will not be created,
+#' however the expression will still be evaluated.
+#'
+#' Span: `session_start`, `session_end`
+#' @param expr Expression to evaluate within the session span
+#' @param ... Ignored
+#' @param domain The reactive domain
+#' @noRd
+otel_span_session_start <- function(expr, ..., domain) {
+
+  if (!has_otel_collect("session")) {
+    return(force(expr))
+  }
+
+  # Wrap the server initialization
+  with_otel_span(
+    "session_start",
+    expr,
+    attributes = otel::as_attributes(c(
+      otel_session_id_attrs(domain),
+      otel_session_attrs(domain)
+    ))
+  )
+}
+
+
+otel_span_session_end <- function(expr, ..., domain) {
+  if (!has_otel_collect("session")) {
+    return(force(expr))
+  }
+
+  id_attrs <- otel_session_id_attrs(domain)
+  with_otel_span(
+    "session_end",
+    expr,
+    attributes = id_attrs
+  )
+}
+
+# -- Helpers -------------------------------
+
+
+# Occurs when the websocket connection is established
+otel_session_attrs <- function(domain) {
+  # TODO: Future: Posit Connect integration
+  # > we are still trying to identify all of the information we want to track/expose
+  #
+  # * `POSIT_PRODUCT` (Fallback to RSTUDIO_PRODUCT) for host environment
+  # * `CONNECT_SERVER` envvar to get the `session.address`.
+  # * `CONNECT_CONTENT_GUID` for the consistent app distinguisher
+  # * Maybe `CONNECT_CONTENT_JOB_KEY`?
+  # * Maybe `user.id` to be their user name: https://opentelemetry.io/docs/specs/semconv/registry/attributes/user/
+  attrs <- list(
+    server.path =
+      sub(
+        "/websocket/$", "/",
+        domain[["request"]][["PATH_INFO"]] %||% ""
+      ),
+    server.address = domain[["request"]][["HTTP_HOST"]] %||% "",
+    server.origin = domain[["request"]][["HTTP_ORIGIN"]] %||% "",
+    ## Currently, Shiny does not expose QUERY_STRING when connecting the websocket
+    # so we do not provide it here.
+    # QUERY_STRING = domain[["request"]][["QUERY_STRING"]] %||% "",
+    server.port = domain[["request"]][["SERVER_PORT"]] %||% NA_integer_
+  )
+  # Safely convert SERVER_PORT to integer
+  # If conversion fails, leave as-is (string or empty)
+  # This avoids warnings/errors if SERVER_PORT is not a valid integer
+  server_port <- suppressWarnings(as.integer(attrs$server.port))
+  if (!is.na(server_port)) {
+    attrs$server.port <- server_port
+  }
+
+  attrs
+}
+
+otel_session_id_attrs <- function(domain) {
+  token <- domain$token
+  if (is.null(token)) {
+    return(list())
+  }
+
+  list(
+    # Convention for client-side with session.start and session.end events
+    # https://opentelemetry.io/docs/specs/semconv/general/session/
+    #
+    # Since we are the server, we'll add them as an attribute to _every_ span
+    # within the session as we don't know exactly when they will be called.
+    # Given it's only a single attribute, the cost should be minimal, but it ties every reactive calculation together.
+    session.id = token
+  )
+}

R/otel-shiny.R

@@ -0,0 +1,127 @@
+# Used by otel to identify the tracer and logger for this package
+# https://github.com/r-lib/otel/blob/afc31bc1f4bd177870d44b051ada1d9e4e685346/R/tracer-name.R#L33-L49
+# DO NOT CHANGE THIS VALUE without understanding the implications for existing telemetry data!
+otel_tracer_name <- "co.posit.r-package.shiny"
+
+init_otel <- function() {
+  .globals$otel_tracer <- otel::get_tracer()
+  .globals$otel_is_tracing_enabled <- otel::is_tracing_enabled(.globals$otel_tracer)
+
+  .globals$otel_logger <- otel::get_logger()
+  # .globals$otel_is_logging_enabled <- otel::is_logging_enabled()
+}
+on_load({init_otel()})
+
+#' Run expr within a Shiny OpenTelemetry recording context
+#'
+#' Reset the OpenTelemetry tracer and logger for Shiny.
+#' Used for testing purposes only.
+#' @param expr Expression to evaluate within the recording context
+#' @return The result of evaluating `otelsdk::with_otel_record(expr)` with freshly enabled Shiny otel tracer and logger
+#' @noRd
+with_shiny_otel_record <- function(expr) {
+  # Only use within internal testthat tests
+  stopifnot(testthat__is_testing())
+  withr::defer({ init_otel() })
+
+  otelsdk::with_otel_record({
+    init_otel()
+
+    force(expr)
+  })
+}
+
+#' Check if OpenTelemetry tracing is enabled
+#'
+#' @param tracer The OpenTelemetry tracer to check (default: Shiny otel tracer)
+#' @return `TRUE` if tracing is enabled, `FALSE` otherwise
+#' @noRd
+otel_is_tracing_enabled <- function() {
+  .globals[["otel_is_tracing_enabled"]]
+}
+
+#' Shiny OpenTelemetry logger
+#'
+#' Used for logging OpenTelemetry events via `otel_log()`
+#' @return An OpenTelemetry logger
+#' @noRd
+shiny_otel_logger <- function() {
+  .globals[["otel_logger"]]
+}
+
+
+
+#' Shiny OpenTelemetry tracer
+#'
+#' Used for creating OpenTelemetry spans via `with_otel_span()` and
+#' `start_otel_span()`
+#'
+#' Inspired by httr2:::get_tracer().
+#' @return An OpenTelemetry tracer
+#' @noRd
+shiny_otel_tracer <- function() {
+  .globals[["otel_tracer"]]
+}
+
+
+
+
+#' Create and use a Shiny OpenTelemetry span
+#'
+#' If otel is disabled, the span will not be created,
+#' however the expression will still be evaluated.
+#' @param name Span name
+#' @param expr Expression to evaluate within the span
+#' @param ... Ignored
+#' @param attributes Optional span attributes
+#' @return The result of evaluating `expr`
+#' @noRd
+with_otel_span <- function(name, expr, ..., attributes = NULL) {
+  promises::with_otel_span(name, expr, ..., attributes = attributes, tracer = shiny_otel_tracer())
+}
+
+
+#' Start a Shiny OpenTelemetry span
+#'
+#' @param name Span name
+#' @param ... Additional arguments passed to `otel::start_span()`
+#' @return An OpenTelemetry span
+#' @noRd
+start_otel_span <- function(name, ...) {
+  otel::start_span(name, ..., tracer = shiny_otel_tracer())
+}
+
+
+# # TODO: Set attributes on the current active span
+# # 5. Set attributes on the current active span
+# set_otel_span_attrs(status = 200L)
+
+
+# -- Helpers --------------------------------------------------------------
+
+
+is_otel_span <- function(x) {
+  inherits(x, "otel_span")
+}
+
+testthat__is_testing <- function() {
+  # testthat::is_testing()
+  identical(Sys.getenv("TESTTHAT"), "true")
+}
+
+#' Log a message using the Shiny OpenTelemetry logger
+#'
+#' @param msg The log message
+#' @param ... Additional attributes to add to the log record
+#' @param severity The log severity level (default: "info")
+#' @param logger The OpenTelemetry logger to use (default: Shiny otel logger)
+#' @return Invisibly returns.
+#' @noRd
+otel_log <- function(
+  msg,
+  ...,
+  severity = "info",
+  logger = shiny_otel_logger()
+) {
+  otel::log(msg, ..., severity = severity, logger = logger)
+}

R/otel-with.R

@@ -0,0 +1,125 @@
+#' Temporarily set OpenTelemetry (OTel) collection level
+#'
+#' @description
+#' Control Shiny's OTel collection level for particular reactive expression(s).
+#'
+#' `withOtelCollect()` sets the OpenTelemetry collection level for
+#' the duration of evaluating `expr`. `localOtelCollect()` sets the collection
+#' level for the remainder of the current function scope.
+#'
+#' @details
+#' Note that `"session"` and `"reactive_update"` levels are not permitted as
+#' these are runtime-specific levels that should only be set permanently via
+#' `options(shiny.otel.collect = ...)` or the `SHINY_OTEL_COLLECT` environment
+#' variable, not temporarily during reactive expression creation.
+#'
+#' @section Best practice:
+#'
+#' Best practice is to set the collection level for code that *creates* reactive
+#' expressions, not code that *runs* them. For instance:
+#'
+#' ```r
+#' # Disable telemetry for a reactive expression
+#' withOtelCollect("none", {
+#'   my_reactive <- reactive({ ... })
+#' })
+#'
+#' # Disable telemetry for a render function
+#' withOtelCollect("none", {
+#'   output$my_plot <- renderPlot({ ... })
+#' })
+#'
+#' #' # Disable telemetry for an observer
+#' withOtelCollect("none", {
+#'   observe({ ... }))
+#' })
+#'
+#' # Disable telemetry for an entire module
+#' withOtelCollect("none", {
+#'   my_result <- my_module("my_id")
+#' })
+#' # Use `my_result` as normal here
+#' ```
+#'
+#' NOTE: It's not recommended to pipe existing reactive objects into
+#' `withOtelCollect()` since they won't inherit their intended OTel settings,
+#' leading to confusion.
+#'
+#' @param collect Character string specifying the OpenTelemetry collection level.
+#'   Must be one of the following:
+#'
+#'     * `"none"` - No telemetry data collected
+#'     * `"reactivity"` - Collect reactive execution spans (includes session and
+#'       reactive update events)
+#'     * `"all"` - All available telemetry (currently equivalent to `"reactivity"`)
+#' @param expr Expression to evaluate with the specified collection level
+#'   (for `withOtelCollect()`).
+#' @param envir Environment where the collection level should be set
+#'   (for `localOtelCollect()`). Defaults to the parent frame.
+#'
+#' @return
+#' * `withOtelCollect()` returns the value of `expr`.
+#' * `localOtelCollect()` is called for its side effect and returns the previous
+#'   `collect` value invisibly.
+#'
+#' @seealso See the `shiny.otel.collect` option within [`shinyOptions`]. Setting
+#' this value will globally control OpenTelemetry collection levels.
+#'
+#' @examples
+#' \dontrun{
+#' # Temporarily disable telemetry collection
+#' withOtelCollect("none", {
+#'   # Code here won't generate telemetry
+#'   reactive({ input$x + 1 })
+#' })
+#'
+#' # Collect reactivity telemetry but not other events
+#' withOtelCollect("reactivity", {
+#'   # Reactive execution will be traced
+#'   observe({ print(input$x) })
+#' })
+#'
+#' # Use local variant in a function
+#' my_function <- function() {
+#'   localOtelCollect("none")
+#'   # Rest of function executes without telemetry
+#'   reactive({ input$y * 2 })
+#' }
+#' }
+#'
+#' @rdname withOtelCollect
+#' @export
+withOtelCollect <- function(collect, expr) {
+  collect <- as_otel_collect_with(collect)
+
+  withr::with_options(
+    list(shiny.otel.collect = collect),
+    expr
+  )
+}
+
+#' @rdname withOtelCollect
+#' @export
+localOtelCollect <- function(collect, envir = parent.frame()) {
+  collect <- as_otel_collect_with(collect)
+
+  old <- withr::local_options(
+    list(shiny.otel.collect = collect),
+    .local_envir = envir
+  )
+
+  invisible(old)
+}
+
+# Helper function to validate collect levels for with/local functions
+# Only allows "none", "reactivity", and "all" - not "session" or "reactive_update"
+as_otel_collect_with <- function(collect) {
+  if (!is.character(collect)) {
+    stop("`collect` must be a character vector.")
+  }
+
+  allowed_levels <- c("none", "reactivity", "all")
+  collect <- match.arg(collect, allowed_levels, several.ok = FALSE)
+
+  return(collect)
+}

R/react.R

@@ -16,6 +16,60 @@ processId <- local({
   }
 })
 
+ctx_otel_info_obj <- function(
+  isRecordingOtel = FALSE,
+  otelLabel = "<unknown>",
+  otelAttrs = list()
+) {
+  structure(
+    list(
+      isRecordingOtel = isRecordingOtel,
+      otelLabel = otelLabel,
+      otelAttrs = otelAttrs
+    ),
+    class = "ctx_otel_info"
+  )
+}
+
+with_otel_span_context <- function(otel_info, expr, domain) {
+  if (!otel_is_tracing_enabled()) {
+    return(force(expr))
+  }
+
+  isRecordingOtel <- .subset2(otel_info, "isRecordingOtel")
+  otelLabel <- .subset2(otel_info, "otelLabel")
+  otelAttrs <- .subset2(otel_info, "otelAttrs")
+
+  # Always set the reactive update span as active
+  # This ensures that any spans created within the reactive context
+  # are at least children of the reactive update span
+  maybe_with_otel_span_reactive_update(domain = domain, {
+    if (isRecordingOtel) {
+      with_otel_span(
+        otelLabel,
+        {
+          # Works with both sync and async expressions
+          # Needed for both observer and reactive contexts
+          hybrid_then(
+            expr,
+            on_failure = set_otel_exception_status_and_throw,
+            # Must upgrade the error object
+            tee = FALSE
+          )
+        },
+        # expr,
+        attributes = otelAttrs
+      )
+    } else {
+      force(expr)
+    }
+  })
+
+}
+
+
+
+
 #' @include graph.R
 Context <- R6Class(
   'Context',
@@ -33,11 +87,14 @@ Context <- R6Class(
     .pid = NULL,
     .weak = NULL,
 
+    .otel_info = NULL,
+
     initialize = function(
       domain, label='', type='other', prevId='',
       reactId = rLog$noReactId,
       id = .getReactiveEnvironment()$nextId(), # For dummy context
-      weak = FALSE
+      weak = FALSE,
+      otel_info = ctx_otel_info_obj()
     ) {
       id <<- id
       .label <<- label
@@ -47,17 +104,26 @@ Context <- R6Class(
       .reactType <<- type
       .weak <<- weak
       rLog$createContext(id, label, type, prevId, domain)
+      if (!is.null(otel_info)) {
+        if (IS_SHINY_LOCAL_PKG) {
+          stopifnot(inherits(otel_info, "ctx_otel_info"))
+        }
+        .otel_info <<- otel_info
+      }
     },
     run = function(func) {
       "Run the provided function under this context."
 
+      # Use `promises::` as it shows up in the stack trace
       promises::with_promise_domain(reactivePromiseDomain(), {
         withReactiveDomain(.domain, {
-          captureStackTraces({
-            env <- .getReactiveEnvironment()
-            rLog$enter(.reactId, id, .reactType, .domain)
-            on.exit(rLog$exit(.reactId, id, .reactType, .domain), add = TRUE)
-            env$runWith(self, func)
+          with_otel_span_context(.otel_info, domain = .domain, {
+            captureStackTraces({
+              env <- .getReactiveEnvironment()
+              rLog$enter(.reactId, id, .reactType, .domain)
+              on.exit(rLog$exit(.reactId, id, .reactType, .domain), add = TRUE)
+              env$runWith(self, func)
+            })
           })
         })
       })
@@ -231,7 +297,7 @@ wrapForContext <- function(func, ctx) {
 }
 
 reactivePromiseDomain <- function() {
-  promises::new_promise_domain(
+  new_promise_domain(
     wrapOnFulfilled = function(onFulfilled) {
       force(onFulfilled)
 

R/reactive-domains.R

@@ -45,6 +45,8 @@ createMockDomain <- function() {
   callbacks <- Callbacks$new()
   ended <- FALSE
   domain <- new.env(parent = emptyenv())
+  domain$ns <- function(id) id
+  domain$token <- "mock-domain"
   domain$onEnded <- function(callback) {
     return(callbacks$register(callback))
   }
@@ -95,7 +97,11 @@ getDefaultReactiveDomain <- function() {
 #' @rdname domains
 #' @export
 withReactiveDomain <- function(domain, expr) {
-  promises::with_promise_domain(createVarPromiseDomain(.globals, "domain", domain), expr)
+  # Use `promises::` as it shows up in the stack trace
+  promises::with_promise_domain(
+    createVarPromiseDomain(.globals, "domain", domain),
+    expr
+  )
 }
 
 #

R/reactives.R

@@ -79,19 +79,26 @@ ReactiveVal <- R6Class(
     dependents = NULL
   ),
   public = list(
+    .isRecordingOtel = FALSE, # Needs to be set by Shiny
+    .otelLabel = NULL, # Needs to be set by Shiny
+    .otelAttrs = NULL, # Needs to be set by Shiny
+
     initialize = function(value, label = NULL) {
       reactId <- nextGlobalReactId()
       private$reactId <- reactId
       private$value <- value
       private$label <- label
       private$dependents <- Dependents$new(reactId = private$reactId)
-      rLog$define(private$reactId, value, private$label, type = "reactiveVal", getDefaultReactiveDomain())
+
+      domain <- getDefaultReactiveDomain()
+      rLog$define(private$reactId, value, private$label, type = "reactiveVal", domain)
+      .otelLabel <<- otel_log_label_set_reactive_val(private$label, domain = domain)
     },
     get = function() {
       private$dependents$register()
 
       if (private$frozen)
-        reactiveStop()
+      reactiveStop()
 
       private$value
     },
@@ -99,7 +106,16 @@ ReactiveVal <- R6Class(
       if (identical(private$value, value)) {
         return(invisible(FALSE))
       }
-      rLog$valueChange(private$reactId, value, getDefaultReactiveDomain())
+
+      domain <- getDefaultReactiveDomain()
+      if ((!is.null(domain)) && .isRecordingOtel) {
+        otel_log(
+          .otelLabel,
+          severity = "info",
+          attributes = c(private$.otelAttrs, otel_session_id_attrs(domain))
+        )
+      }
+      rLog$valueChange(private$reactId, value, domain)
       private$value <- value
       private$dependents$invalidate()
       invisible(TRUE)
@@ -205,13 +221,20 @@ ReactiveVal <- R6Class(
 #'
 #' @export
 reactiveVal <- function(value = NULL, label = NULL) {
+  call_srcref <- get_call_srcref()
   if (missing(label)) {
-    call <- sys.call()
-    label <- rvalSrcrefToLabel(attr(call, "srcref", exact = TRUE))
+    label <- rassignSrcrefToLabel(
+      call_srcref,
+      defaultLabel = paste0("reactiveVal", createUniqueId(4))
+    )
   }
 
   rv <- ReactiveVal$new(value, label)
-  structure(
+  if (!is.null(call_srcref)) {
+    rv$.otelAttrs <- otel_srcref_attributes(call_srcref, fn_name = "reactiveVal")
+  }
+
+  ret <- structure(
     function(x) {
       if (missing(x)) {
         rv$get()
@@ -224,6 +247,12 @@ reactiveVal <- function(value = NULL, label = NULL) {
     label = label,
     .impl = rv
   )
+
+  if (has_otel_collect("reactivity")) {
+    ret <- enable_otel_reactive_val(ret)
+  }
+
+  ret
 }
 
 #' @rdname freezeReactiveValue
@@ -262,8 +291,11 @@ format.reactiveVal <- function(x, ...) {
 # assigned to (e.g. for `a <- reactiveVal()`, the result should be "a"). This
 # is a fragile, error-prone operation, so we default to a random label if
 # necessary.
-rvalSrcrefToLabel <- function(srcref,
-  defaultLabel = paste0("reactiveVal", createUniqueId(4))) {
+rassignSrcrefToLabel <- function(
+  srcref,
+  defaultLabel,
+  fnName = "([a-zA-Z0-9_.]+)"
+) {
 
   if (is.null(srcref))
     return(defaultLabel)
@@ -272,22 +304,29 @@ rvalSrcrefToLabel <- function(srcref,
   if (is.null(srcfile))
     return(defaultLabel)
 
-  if (is.null(srcfile$lines))
+  src <- getSrcfileLines(srcfile, srcref)
+  lines <- src$lines
+  line_num <- src$line_num
+
+  if (is.null(lines))
     return(defaultLabel)
 
-  lines <- srcfile$lines
   # When pasting at the Console, srcfile$lines is not split
   if (length(lines) == 1) {
     lines <- strsplit(lines, "\n")[[1]]
   }
 
-  if (length(lines) < srcref[1]) {
+  if (length(lines) < line_num) {
     return(defaultLabel)
   }
 
-  firstLine <- substring(lines[srcref[1]], srcref[2] - 1)
+  firstLine <- substring(lines[line_num], srcref[2] - 1)
 
-  m <- regexec("\\s*([^[:space:]]+)\\s*(<-|=)\\s*reactiveVal\\b", firstLine)
+  m <- regexec(
+    # Require the first assignment within the line
+    paste0("^\\s*([^[:space:]]+)\\s*(<<-|<-|=)\\s*", fnName, "\\b"),
+    firstLine
+  )
   if (m[[1]][1] == -1) {
     return(defaultLabel)
   }
@@ -330,6 +369,9 @@ ReactiveValues <- R6Class(
     # object, but it does not preserve order.
     .nameOrder = character(0),
 
+    .isRecordingOtel = FALSE, # Needs to be set by Shiny
+    .otelAttrs = NULL, # Needs to be set by Shiny
+
 
     initialize = function(
       dedupe = TRUE,
@@ -406,6 +448,21 @@ ReactiveValues <- R6Class(
         return(invisible())
       }
 
+      if ((!is.null(domain)) && .isRecordingOtel) {
+        if (
+          # Any reactiveValues (other than input or clientData) are fair game
+          !(.label == "input" || .label == "clientData") ||
+          # Do not include updates to input or clientData unless _some_ reactivity has occured
+          !is.null(domain$userData[["_otel_has_reactive_cleanup"]])
+        ) {
+          otel_log(
+            otel_log_label_set_reactive_values(.label, key, domain = domain),
+            severity = "info",
+            attributes = c(.otelAttrs, otel_session_id_attrs(domain))
+          )
+        }
+      }
+
       # If it's new, append key to the name order
       if (!key_exists) {
         .nameOrder[length(.nameOrder) + 1] <<- key
@@ -579,10 +636,28 @@ reactiveValues <- function(...) {
   if ((length(args) > 0) && (is.null(names(args)) || any(names(args) == "")))
     rlang::abort("All arguments passed to reactiveValues() must be named.")
 
-  values <- .createReactiveValues(ReactiveValues$new())
+  values <- .createReactiveValues(ReactiveValues$new(), withOtel = FALSE)
 
   # Use .subset2() instead of [[, to avoid method dispatch
-  .subset2(values, 'impl')$mset(args)
+  impl <- .subset2(values, 'impl')
+
+  call_srcref <- get_call_srcref()
+  if (!is.null(call_srcref)) {
+    impl$.label <- rassignSrcrefToLabel(
+      call_srcref,
+      # Pass through the random default label created in ReactiveValues$new()
+      defaultLabel = impl$.label
+    )
+
+    impl$.otelAttrs <- otel_srcref_attributes(call_srcref, fn_name = "reactiveValues")
+  }
+
+  impl$mset(args)
+
+  # Add otel collection after `$mset()` so that we don't log the initial values
+  # Add otel collection after `.label` so that any logging uses the correct label
+  values <- maybeAddReactiveValuesOtel(values)
+
   values
 }
 
@@ -597,10 +672,11 @@ checkName <- function(x) {
 # @param values A ReactiveValues object
 # @param readonly Should this object be read-only?
 # @param ns A namespace function (either `identity` or `NS(namespace)`)
+# @param withOtel Should otel collection be attempted?
 .createReactiveValues <- function(values = NULL, readonly = FALSE,
-  ns = identity) {
+  ns = identity, withOtel = TRUE) {
 
-  structure(
+  ret <- structure(
     list(
       impl = values,
       readonly = readonly,
@@ -608,6 +684,20 @@ checkName <- function(x) {
     ),
     class='reactivevalues'
   )
+
+  if (withOtel) {
+    ret <- maybeAddReactiveValuesOtel(ret)
+  }
+
+  ret
+}
+
+maybeAddReactiveValuesOtel <- function(x) {
+  if (!has_otel_collect("reactivity")) {
+    return(x)
+  }
+
+  enable_otel_reactive_values(x)
 }
 
 #' @export
@@ -831,6 +921,10 @@ Observable <- R6Class(
     .mostRecentCtxId = character(0),
     .ctx = 'Context',
 
+    .isRecordingOtel = FALSE, # Needs to be set by Shiny
+    .otelLabel = NULL, # Needs to be set by Shiny
+    .otelAttrs = NULL, # Needs to be set by Shiny
+
     initialize = function(func, label = deparse(substitute(func)),
                           domain = getDefaultReactiveDomain(),
                           ..stacktraceon = TRUE) {
@@ -885,9 +979,19 @@ Observable <- R6Class(
       simpleExprToFunction(fn_body(.origFunc), "reactive")
     },
     .updateValue = function() {
-      ctx <- Context$new(.domain, .label, type = 'observable',
-                         prevId = .mostRecentCtxId, reactId = .reactId,
-                         weak = TRUE)
+      ctx <- Context$new(
+        .domain,
+        .label,
+        type = 'observable',
+        prevId = .mostRecentCtxId,
+        reactId = .reactId,
+        weak = TRUE,
+        otel_info = ctx_otel_info_obj(
+          isRecordingOtel = .isRecordingOtel,
+          otelLabel = .otelLabel,
+          otelAttrs = c(.otelAttrs, otel_session_id_attrs(.domain))
+        )
+      )
       .mostRecentCtxId <<- ctx$id
 
       # A Dependency object will have a weak reference to the context, which
@@ -920,6 +1024,15 @@ Observable <- R6Class(
           },
 
           error = function(cond) {
+            if (.isRecordingOtel) {
+              # `cond` is too early in the stack to be updated by `ctx`'s
+              # `with_otel_span_context()` where it calls
+              # `set_otel_exception_status_and_throw()` on eval error.
+              # So we mark it as seen here.
+              # When the error is re-thrown later, it won't be a _new_ error
+              cond <- mark_otel_exception_as_seen(cond)
+            }
+
             # If an error occurs, we want to propagate the error, but we also
             # want to save a copy of it, so future callers of this reactive will
             # get the same error (i.e. the error is cached).
@@ -1017,12 +1130,24 @@ reactive <- function(
   label <- exprToLabel(userExpr, "reactive", label)
 
   o <- Observable$new(func, label, domain, ..stacktraceon = ..stacktraceon)
-  structure(
+
+  call_srcref <- get_call_srcref()
+  if (!is.null(call_srcref)) {
+    o$.otelAttrs <- otel_srcref_attributes(call_srcref, fn_name = "reactive")
+  }
+
+  ret <- structure(
     o$getValue,
     observable = o,
     cacheHint = list(userExpr = zap_srcref(userExpr)),
     class = c("reactiveExpr", "reactive", "function")
   )
+
+  if (has_otel_collect("reactivity")) {
+    ret <- enable_otel_reactive_expr(ret)
+  }
+
+  ret
 }
 
 # Given the srcref to a reactive expression, attempts to figure out what the
@@ -1030,7 +1155,7 @@ reactive <- function(
 # scans the line of code that started the reactive block and looks for something
 # that looks like assignment. If we fail, fall back to a default value (likely
 # the block of code in the body of the reactive).
-rexprSrcrefToLabel <- function(srcref, defaultLabel) {
+rexprSrcrefToLabel <- function(srcref, defaultLabel, fnName) {
   if (is.null(srcref))
     return(defaultLabel)
 
@@ -1038,22 +1163,26 @@ rexprSrcrefToLabel <- function(srcref, defaultLabel) {
   if (is.null(srcfile))
     return(defaultLabel)
 
-  if (is.null(srcfile$lines))
+  src <- getSrcfileLines(srcfile, srcref)
+  lines <- src$lines
+  line_num <- src$line_num
+
+  if (is.null(lines))
     return(defaultLabel)
 
-  lines <- srcfile$lines
   # When pasting at the Console, srcfile$lines is not split
   if (length(lines) == 1) {
     lines <- strsplit(lines, "\n")[[1]]
   }
 
-  if (length(lines) < srcref[1]) {
+  if (length(lines) < line_num) {
     return(defaultLabel)
   }
 
-  firstLine <- substring(lines[srcref[1]], 1, srcref[2] - 1)
+  firstLine <- substring(lines[line_num], 1, srcref[2] - 1)
 
-  m <- regexec("(.*)(<-|=)\\s*reactive\\s*\\($", firstLine)
+  # Require the assignment to be parsed from the start
+  m <- regexec(paste0("^(.*)(<<-|<-|=)\\s*", fnName, "\\s*\\($"), firstLine)
   if (m[[1]][1] == -1) {
     return(defaultLabel)
   }
@@ -1127,6 +1256,10 @@ Observer <- R6Class(
     .prevId = character(0),
     .ctx = NULL,
 
+    .isRecordingOtel = FALSE, # Needs to be set by Shiny
+    .otelLabel = NULL, # Needs to be set by Shiny
+    .otelAttrs = NULL, # Needs to be set by Shiny
+
     initialize = function(observerFunc, label, suspended = FALSE, priority = 0,
                           domain = getDefaultReactiveDomain(),
                           autoDestroy = TRUE, ..stacktraceon = TRUE) {
@@ -1161,7 +1294,18 @@ Observer <- R6Class(
       .createContext()$invalidate()
     },
     .createContext = function() {
-      ctx <- Context$new(.domain, .label, type='observer', prevId=.prevId, reactId = .reactId)
+      ctx <- Context$new(
+        .domain,
+        .label,
+        type = 'observer',
+        prevId = .prevId,
+        reactId = .reactId,
+        otel_info = ctx_otel_info_obj(
+          isRecordingOtel = .isRecordingOtel,
+          otelLabel = .otelLabel,
+          otelAttrs = c(.otelAttrs, otel_session_id_attrs(.domain))
+        )
+      )
       .prevId <<- ctx$id
 
       if (!is.null(.ctx)) {
@@ -1430,7 +1574,14 @@ observe <- function(
   check_dots_empty()
 
   func <- installExprFunction(x, "func", env, quoted)
-  label <- funcToLabel(func, "observe", label)
+
+  call_srcref <- get_call_srcref()
+  if (is.null(label)) {
+    label <- rassignSrcrefToLabel(
+      call_srcref,
+      defaultLabel = funcToLabel(func, "observe", label)
+    )
+  }
 
   o <- Observer$new(
     func,
@@ -1441,6 +1592,14 @@ observe <- function(
     autoDestroy = autoDestroy,
     ..stacktraceon = ..stacktraceon
   )
+  if (!is.null(call_srcref)) {
+    o$.otelAttrs <- otel_srcref_attributes(call_srcref, fn_name = "observe")
+  }
+
+  if (has_otel_collect("reactivity")) {
+    o <- enable_otel_observe(o)
+  }
+
   invisible(o)
 }
 
@@ -1828,34 +1987,64 @@ coerceToFunc <- function(x) {
 #' }
 #' @export
 reactivePoll <- function(intervalMillis, session, checkFunc, valueFunc) {
+  reactive_poll_impl(
+    fnName = "reactivePoll",
+    intervalMillis = intervalMillis,
+    session = session,
+    checkFunc = checkFunc,
+    valueFunc = valueFunc
+  )
+}
+
+reactive_poll_impl <- function(
+  fnName,
+  intervalMillis,
+  session,
+  checkFunc,
+  valueFunc
+) {
   intervalMillis <- coerceToFunc(intervalMillis)
 
-  rv <- reactiveValues(cookie = isolate(checkFunc()))
+  fnName <- match.arg(fnName, c("reactivePoll", "reactiveFileReader"), several.ok = FALSE)
+
+  call_srcref <- get_call_srcref(-1)
+  label <- rassignSrcrefToLabel(
+    call_srcref,
+    defaultLabel = "<anonymous>",
+    fnName = fnName
+  )
 
   re_finalized <- FALSE
   env <- environment()
 
-  o <- observe({
-    # When no one holds a reference to the reactive returned from
-    # reactivePoll, destroy and remove the observer so that it doesn't keep
-    # firing and hold onto resources.
-    if (re_finalized) {
-      o$destroy()
-      rm(o, envir = env)
-      return()
-    }
+  with_no_otel_collect({
+    cookie <- reactiveVal(
+      isolate(checkFunc()),
+      label = sprintf("%s %s cookie", fnName, label)
+    )
 
-    rv$cookie <- checkFunc()
-    invalidateLater(intervalMillis(), session)
+    o <- observe({
+      # When no one holds a reference to the reactive returned from
+      # reactivePoll, destroy and remove the observer so that it doesn't keep
+      # firing and hold onto resources.
+      if (re_finalized) {
+        o$destroy()
+        rm(o, envir = env)
+        return()
+      }
+
+      cookie(checkFunc())
+      invalidateLater(intervalMillis(), session)
+    }, label = sprintf("%s %s cleanup", fnName, label))
   })
 
-  # TODO: what to use for a label?
-  re <- reactive({
-    rv$cookie
+  re <- reactive(label = sprintf("%s %s", fnName, label), {
+    # Take a dependency on the cookie, so that when it changes, this
+    # reactive expression is invalidated.
+    cookie()
 
     valueFunc()
-
-  }, label = NULL)
+  })
 
   reg.finalizer(attr(re, "observable"), function(e) {
     re_finalized <<- TRUE
@@ -1865,6 +2054,16 @@ reactivePoll <- function(intervalMillis, session, checkFunc, valueFunc) {
   # reference to `re` and thus prevent it from getting GC'd.
   on.exit(rm(re))
 
+  local({
+    impl <- attr(re, "observable", exact = TRUE)
+    impl$.otelLabel <-
+      if (fnName == "reactivePoll")
+        otel_label_reactive_poll(label, domain = impl$.domain)
+      else if (fnName == "reactiveFileReader")
+        otel_label_reactive_file_reader(label, domain = impl$.domain)
+    impl$.otelAttrs <- append_otel_srcref_attrs(impl$.otelAttrs, call_srcref, fn_name = fnName)
+  })
+
   return(re)
 }
 
@@ -1928,14 +2127,16 @@ reactiveFileReader <- function(intervalMillis, session, filePath, readFunc, ...)
   filePath <- coerceToFunc(filePath)
   extraArgs <- list2(...)
 
-  reactivePoll(
-    intervalMillis, session,
-    function() {
+  reactive_poll_impl(
+    fnName = "reactiveFileReader",
+    intervalMillis = intervalMillis,
+    session = session,
+    checkFunc = function() {
       path <- filePath()
       info <- file.info(path)
       return(paste(path, info$mtime, info$size))
     },
-    function() {
+    valueFunc = function() {
       do.call(readFunc, c(filePath(), extraArgs))
     }
   )
@@ -2017,6 +2218,8 @@ isolate <- function(expr) {
   } else {
     reactId <- rLog$noReactId
   }
+
+  # Do not track otel spans for `isolate()`
   ctx <- Context$new(getDefaultReactiveDomain(), '[isolate]', type='isolate', reactId = reactId)
   on.exit(ctx$invalidate())
   # Matching ..stacktraceon../..stacktraceoff.. pair
@@ -2295,26 +2498,41 @@ observeEvent <- function(eventExpr, handlerExpr,
   eventQ <- exprToQuo(eventExpr, event.env, event.quoted)
   handlerQ <- exprToQuo(handlerExpr, handler.env, handler.quoted)
 
-  label <- quoToLabel(eventQ, "observeEvent", label)
+  call_srcref <- get_call_srcref()
+  if (is.null(label)) {
+    label <- rassignSrcrefToLabel(
+      call_srcref,
+      defaultLabel = quoToLabel(eventQ, "observeEvent", label)
+    )
+  }
 
-  handler <- inject(observe(
-    !!handlerQ,
-    label = label,
-    suspended = suspended,
-    priority = priority,
-    domain = domain,
-    autoDestroy = TRUE,
-    ..stacktraceon = TRUE
-  ))
+  with_no_otel_collect({
+    handler <- inject(observe(
+      !!handlerQ,
+      label = label,
+      suspended = suspended,
+      priority = priority,
+      domain = domain,
+      autoDestroy = TRUE,
+      ..stacktraceon = TRUE
+    ))
 
-  o <- inject(bindEvent(
-    ignoreNULL = ignoreNULL,
-    ignoreInit = ignoreInit,
-    once = once,
-    label = label,
-    !!eventQ,
-    x = handler
-  ))
+    o <- inject(bindEvent(
+      ignoreNULL = ignoreNULL,
+      ignoreInit = ignoreInit,
+      once = once,
+      label = label,
+      !!eventQ,
+      x = handler
+    ))
+  })
+
+  if (!is.null(call_srcref)) {
+    o$.otelAttrs <- otel_srcref_attributes(call_srcref, fn_name = "observeEvent")
+  }
+  if (has_otel_collect("reactivity")) {
+    o <- enable_otel_observe(o)
+  }
 
   invisible(o)
 }
@@ -2333,15 +2551,40 @@ eventReactive <- function(eventExpr, valueExpr,
   eventQ <- exprToQuo(eventExpr, event.env, event.quoted)
   valueQ <- exprToQuo(valueExpr, value.env, value.quoted)
 
-  label <- quoToLabel(eventQ, "eventReactive", label)
+  func <- installExprFunction(eventExpr, "func", event.env, event.quoted, wrappedWithLabel = FALSE)
+  # Attach a label and a reference to the original user source for debugging
+  userEventExpr <- fn_body(func)
 
-  invisible(inject(bindEvent(
-    ignoreNULL = ignoreNULL,
-    ignoreInit = ignoreInit,
-    label = label,
-    !!eventQ,
-    x = reactive(!!valueQ, domain = domain, label = label)
-  )))
+  call_srcref <- get_call_srcref()
+  if (is.null(label)) {
+    label <- rassignSrcrefToLabel(
+      call_srcref,
+      defaultLabel = exprToLabel(userEventExpr, "eventReactive", label)
+    )
+  }
+
+  with_no_otel_collect({
+    value_r <- inject(reactive(!!valueQ, domain = domain, label = label))
+
+    r <- inject(bindEvent(
+      ignoreNULL = ignoreNULL,
+      ignoreInit = ignoreInit,
+      label = label,
+      !!eventQ,
+      x = value_r
+    ))
+  })
+
+  if (!is.null(call_srcref)) {
+    impl <- attr(r, "observable", exact = TRUE)
+    impl$.otelAttrs <- otel_srcref_attributes(call_srcref, fn_name = "eventReactive")
+  }
+  if (has_otel_collect("reactivity")) {
+    r <- enable_otel_reactive_expr(r)
+  }
+
+
+  return(r)
 }
 
 isNullEvent <- function(value) {
@@ -2456,71 +2699,103 @@ isNullEvent <- function(value) {
 #'
 #' @export
 debounce <- function(r, millis, priority = 100, domain = getDefaultReactiveDomain()) {
-
-  # TODO: make a nice label for the observer(s)
+  # Do not bind OpenTelemetry spans for debounce reactivity internals,
+  # except for the eventReactive that is returned.
 
   force(r)
   force(millis)
 
+  call_srcref <- get_call_srcref()
+  label <- rassignSrcrefToLabel(
+    call_srcref,
+    defaultLabel = "<anonymous>"
+  )
+
   if (!is.function(millis)) {
     origMillis <- millis
     millis <- function() origMillis
   }
 
-  v <- reactiveValues(
-    trigger = NULL,
-    when = NULL # the deadline for the timer to fire; NULL if not scheduled
-  )
+  with_no_otel_collect({
+    trigger <- reactiveVal(NULL, label = sprintf("debounce %s trigger", label))
+    # the deadline for the timer to fire; NULL if not scheduled
+    when <- reactiveVal(NULL, label = sprintf("debounce %s when", label))
 
-  # Responsible for tracking when r() changes.
-  firstRun <- TRUE
-  observe({
-    if (firstRun) {
-      # During the first run we don't want to set v$when, as this will kick off
-      # the timer. We only want to do that when we see r() change.
-      firstRun <<- FALSE
+    # Responsible for tracking when r() changes.
+    firstRun <- TRUE
+    observe(
+      label = sprintf("debounce %s tracker", label),
+      domain = domain,
+      priority = priority,
+      {
+        if (firstRun) {
+          # During the first run we don't want to set `when`, as this will kick
+          # off the timer. We only want to do that when we see `r()` change.
+          firstRun <<- FALSE
 
-      # Ensure r() is called only after setting firstRun to FALSE since r()
-      # may throw an error
-      try(r(), silent = TRUE)
-      return()
-    }
-    # This ensures r() is still tracked after firstRun
-    try(r(), silent = TRUE)
+          # Ensure r() is called only after setting firstRun to FALSE since r()
+          # may throw an error
+          try(r(), silent = TRUE)
+          return()
+        }
+        # This ensures r() is still tracked after firstRun
+        try(r(), silent = TRUE)
 
-    # The value (or possibly millis) changed. Start or reset the timer.
-    v$when <- getDomainTimeMs(domain) + millis()
-  }, label = "debounce tracker", domain = domain, priority = priority)
+        # The value (or possibly millis) changed. Start or reset the timer.
+        when(
+          getDomainTimeMs(domain) + millis()
+        )
+      }
+    )
 
-  # This observer is the timer. It rests until v$when elapses, then touches
-  # v$trigger.
-  observe({
-    if (is.null(v$when))
-      return()
+    # This observer is the timer. It rests until `when` elapses, then touches
+    # `trigger`.
+    observe(
+      label = sprintf("debounce %s timer", label),
+      domain = domain,
+      priority = priority,
+      {
+        if (is.null(when()))
+          return()
 
-    now <- getDomainTimeMs(domain)
-    if (now >= v$when) {
-      # Mod by 999999999 to get predictable overflow behavior
-      v$trigger <- isolate(v$trigger %||% 0) %% 999999999 + 1
-      v$when <- NULL
-    } else {
-      invalidateLater(v$when - now)
-    }
-  }, label = "debounce timer", domain = domain, priority = priority)
+        now <- getDomainTimeMs(domain)
+        if (now >= when()) {
+          # Mod by 999999999 to get predictable overflow behavior
+          trigger(
+            isolate(trigger() %||% 0) %% 999999999 + 1
+          )
+          when(NULL)
+        } else {
+          invalidateLater(when() - now)
+        }
+      }
+    )
+
+  })
 
   # This is the actual reactive that is returned to the user. It returns the
-  # value of r(), but only invalidates/updates when v$trigger is touched.
-  er <- eventReactive(v$trigger, {
-    r()
-  }, label = "debounce result", ignoreNULL = FALSE, domain = domain)
+  # value of r(), but only invalidates/updates when `trigger` is touched.
+  er <- eventReactive(
+    {trigger()}, {r()},
+    label = sprintf("debounce %s result", label), ignoreNULL = FALSE, domain = domain
+  )
 
-  # Force the value of er to be immediately cached upon creation. It's very hard
-  # to explain why this observer is needed, but if you want to understand, try
-  # commenting it out and studying the unit test failure that results.
-  primer <- observe({
-    primer$destroy()
-    try(er(), silent = TRUE)
-  }, label = "debounce primer", domain = domain, priority = priority)
+  # Update the otel label
+  local({
+    er_impl <- attr(er, "observable", exact = TRUE)
+    er_impl$.otelLabel <- otel_label_debounce(label, domain = domain)
+    er_impl$.otelAttrs <- append_otel_srcref_attrs(er_impl$.otelAttrs, call_srcref, fn_name = "debounce")
+  })
+
+  with_no_otel_collect({
+    # Force the value of er to be immediately cached upon creation. It's very hard
+    # to explain why this observer is needed, but if you want to understand, try
+    # commenting it out and studying the unit test failure that results.
+    primer <- observe({
+      primer$destroy()
+      try(er(), silent = TRUE)
+    }, label = sprintf("debounce %s primer", label), domain = domain, priority = priority)
+  })
 
   er
 }
@@ -2528,69 +2803,88 @@ debounce <- function(r, millis, priority = 100, domain = getDefaultReactiveDomai
 #' @rdname debounce
 #' @export
 throttle <- function(r, millis, priority = 100, domain = getDefaultReactiveDomain()) {
-
-  # TODO: make a nice label for the observer(s)
+  # Do not bind OpenTelemetry spans for throttle reactivity internals,
+  # except for the eventReactive that is returned.
 
   force(r)
   force(millis)
 
+  call_srcref <- get_call_srcref()
+  label <- rassignSrcrefToLabel(
+    call_srcref,
+    defaultLabel = "<anonymous>"
+  )
+
   if (!is.function(millis)) {
     origMillis <- millis
     millis <- function() origMillis
   }
 
-  v <- reactiveValues(
-    trigger = 0,
-    lastTriggeredAt = NULL, # Last time we fired; NULL if never
-    pending = FALSE # If TRUE, trigger again when timer elapses
-  )
+  with_no_otel_collect({
+    trigger <- reactiveVal(0, label = sprintf("throttle %s trigger", label))
+    # Last time we fired; NULL if never
+    lastTriggeredAt <- reactiveVal(NULL, label = sprintf("throttle %s last triggered at", label))
+    # If TRUE, trigger again when timer elapses
+    pending <- reactiveVal(FALSE, label = sprintf("throttle %s pending", label))
+  })
 
   blackoutMillisLeft <- function() {
-    if (is.null(v$lastTriggeredAt)) {
+    if (is.null(lastTriggeredAt())) {
       0
     } else {
-      max(0, v$lastTriggeredAt + millis() - getDomainTimeMs(domain))
+      max(0, lastTriggeredAt() + millis() - getDomainTimeMs(domain))
     }
   }
 
-  trigger <- function() {
-    v$lastTriggeredAt <- getDomainTimeMs(domain)
+  update_trigger <- function() {
+    lastTriggeredAt(getDomainTimeMs(domain))
     # Mod by 999999999 to get predictable overflow behavior
-    v$trigger <- isolate(v$trigger) %% 999999999 + 1
-    v$pending <- FALSE
+    trigger(isolate(trigger()) %% 999999999 + 1)
+    pending(FALSE)
   }
 
-  # Responsible for tracking when f() changes.
-  observeEvent(try(r(), silent = TRUE), {
-    if (v$pending) {
-      # In a blackout period and someone already scheduled; do nothing
-    } else if (blackoutMillisLeft() > 0) {
-      # In a blackout period but this is the first change in that period; set
-      # v$pending so that a trigger will be scheduled at the end of the period
-      v$pending <- TRUE
-    } else {
-      # Not in a blackout period. Trigger, which will start a new blackout
-      # period.
-      trigger()
-    }
-  }, label = "throttle tracker", ignoreNULL = FALSE, priority = priority, domain = domain)
+  with_no_otel_collect({
+    # Responsible for tracking when f() changes.
+    observeEvent(try(r(), silent = TRUE), {
+      if (pending()) {
+        # In a blackout period and someone already scheduled; do nothing
+      } else if (blackoutMillisLeft() > 0) {
+        # In a blackout period but this is the first change in that period; set
+        # pending so that a trigger will be scheduled at the end of the period
+        pending(TRUE)
+      } else {
+        # Not in a blackout period. Trigger, which will start a new blackout
+        # period.
+        update_trigger()
+      }
+    }, label = sprintf("throttle %s tracker", label), ignoreNULL = FALSE, priority = priority, domain = domain)
 
-  observe({
-    if (!v$pending) {
-      return()
-    }
+    observe({
+      if (!pending()) {
+        return()
+      }
 
-    timeout <- blackoutMillisLeft()
-    if (timeout > 0) {
-      invalidateLater(timeout)
-    } else {
-      trigger()
-    }
-  }, priority = priority, domain = domain)
+      timeout <- blackoutMillisLeft()
+      if (timeout > 0) {
+        invalidateLater(timeout)
+      } else {
+        update_trigger()
+      }
+    }, label = sprintf("throttle %s trigger", label), priority = priority, domain = domain)
+  })
 
   # This is the actual reactive that is returned to the user. It returns the
-  # value of r(), but only invalidates/updates when v$trigger is touched.
-  eventReactive(v$trigger, {
+  # value of r(), but only invalidates/updates when trigger is touched.
+  er <- eventReactive({trigger()}, {
     r()
-  }, label = "throttle result", ignoreNULL = FALSE, domain = domain)
+  }, label = sprintf("throttle %s result", label), ignoreNULL = FALSE, domain = domain)
+
+  # Update the otel label
+  local({
+    er_impl <- attr(er, "observable", exact = TRUE)
+    er_impl$.otelLabel <- otel_label_throttle(label, domain = domain)
+    er_impl$.otelAttrs <- append_otel_srcref_attrs(er_impl$.otelAttrs, call_srcref, fn_name = "throttle")
+  })
+
+  er
 }

R/render-plot.R

@@ -253,7 +253,7 @@ drawPlot <- function(name, session, func, width, height, alt, pixelratio, res, .
 
   hybrid_chain(
     hybrid_chain(
-      promises::with_promise_domain(domain, {
+      with_promise_domain(domain, {
         hybrid_chain(
           func(),
           function(value) {

R/runapp.R

@@ -46,6 +46,12 @@
 #'   only used for recording or running automated tests. Defaults to the
 #'   `shiny.testmode` option, or FALSE if the option is not set.
 #'
+#' @return The value passed to [stopApp()], or throws an error if the app was
+#'   stopped with an error.
+#'
+#' @seealso [startApp()] for non-blocking mode, [stopApp()] to stop a running
+#'   app.
+#'
 #' @examples
 #' \dontrun{
 #' # Start app in the current working directory
@@ -84,18 +90,23 @@
 #'   runApp(app)
 #' }
 #' @export
-runApp <- function(appDir=getwd(),
-                   port=getOption('shiny.port'),
-                   launch.browser = getOption('shiny.launch.browser', interactive()),
-                   host=getOption('shiny.host', '127.0.0.1'),
-                   workerId="", quiet=FALSE,
-                   display.mode=c("auto", "normal", "showcase"),
-                   test.mode=getOption('shiny.testmode', FALSE)) {
-  on.exit({
-    handlerManager$clear()
-  }, add = TRUE)
+runApp <- function(
+  appDir=getwd(),
+  port=getOption('shiny.port'),
+  launch.browser = getOption('shiny.launch.browser', interactive()),
+  host=getOption('shiny.host', '127.0.0.1'),
+  workerId="", quiet=FALSE,
+  display.mode=c("auto", "normal", "showcase"),
+  test.mode=getOption('shiny.testmode', FALSE)
+) {
+  # * Wrap **all** execution of the app inside the otel promise domain
+  # * While this could be done at a lower level, it allows for _anything_ within
+  #   shiny's control to allow for the opportunity to have otel active spans be
+  #   reactivated upon promise domain restoration
+  promises::local_otel_promise_domain()
 
-  if (isRunning()) {
+  # Check for nested blocking runApp() before sourcing app code
+  if (isRunning() && is.null(.globals$runningHandle)) {
     stop("Can't call `runApp()` from within `runApp()`. If your ",
          "application code contains `runApp()`, please remove it.")
   }
@@ -107,14 +118,13 @@ runApp <- function(appDir=getwd(),
     warn = max(1, getOption("warn", default = 1)),
     pool.scheduler = scheduleTask
   )
-  on.exit(options(ops), add = TRUE)
 
-  # ============================================================================
-  # Global onStart/onStop callbacks
-  # ============================================================================
-  # Invoke user-defined onStop callbacks, before the application's internal
-  # onStop callbacks.
-  on.exit({
+  # Ensure options are restored and onStop callbacks fire even if
+  # as.shiny.appobj() errors. Once .setupShinyApp() succeeds, the returned
+  # cleanup function takes over and this guard becomes a no-op.
+  setupComplete <- FALSE
+  on.exit(if (!setupComplete) {
+    options(ops)
     .globals$onStopCallbacks$invoke()
     .globals$onStopCallbacks <- Callbacks$new()
   }, add = TRUE)
@@ -126,32 +136,140 @@ runApp <- function(appDir=getwd(),
   # ============================================================================
   appParts <- as.shiny.appobj(appDir)
 
-  # ============================================================================
-  # Initialize app state object
-  # ============================================================================
-  # This is so calls to getCurrentAppState() can be used to find (A) whether an
-  # app is running and (B), get options and data associated with the app.
-  initCurrentAppState(appParts)
-  on.exit(clearCurrentAppState(), add = TRUE)
-  # Any shinyOptions set after this point will apply to the current app only
-  # (and will not persist after the app stops).
+  result <- .setupShinyApp(
+    appDir, appParts, port, launch.browser, host,
+    workerId, quiet, display.mode, test.mode, ops = ops
+  )
+  setupComplete <- TRUE
+  on.exit(result$cleanup(), add = TRUE)
 
   # ============================================================================
-  # shinyOptions
+  # Run event loop via httpuv
   # ============================================================================
-  # A unique identifier associated with this run of this application. It is
-  # shared across sessions.
-  shinyOptions(appToken = createUniqueId(8))
+  # Top-level ..stacktraceoff..; matches with ..stacktraceon in observe(),
+  # reactive(), Callbacks$invoke(), and others
+  ..stacktraceoff..(
+    captureStackTraces({
+      while (!.globals$stopped) {
+        ..stacktracefloor..(serviceApp())
+      }
+    })
+  )
 
-  # Set up default cache for app.
-  if (is.null(getShinyOption("cache", default = NULL))) {
-    shinyOptions(cache = cachem::cache_mem(max_size = 200 * 1024^2))
+  if (isTRUE(.globals$reterror)) {
+    stop(.globals$retval)
+  } else if (.globals$retval$visible) {
+    .globals$retval$value
+  } else {
+    invisible(.globals$retval$value)
   }
+}
 
-  # Extract appOptions (which is a list) and store them as shinyOptions, for
-  # this app. (This is the only place we have to store settings that are
-  # accessible both the UI and server portion of the app.)
-  applyCapturedAppOptions(appParts$appOptions)
+#' Start Shiny Application (Non-Blocking)
+#'
+#' Starts a Shiny application in non-blocking mode, returning a
+#' `ShinyAppHandle` immediately while the app runs in the background.
+#' The `later` event loop services the app, so the R console remains
+#' available for interaction.
+#'
+#' @inheritParams runApp
+#'
+#' @return A `ShinyAppHandle` object with methods `stop()`, `status()`,
+#'   `url()`, and `result()`. The `status()` method returns `"running"`,
+#'   `"success"`, or `"error"`. The `result()` method throws an error if called
+#'   while running, or re-throws the error if the app stopped with an error.
+#'
+#' @examples
+#' \dontrun{
+#' # Start app in the background
+#' handle <- startApp("myapp")
+#'
+#' # Check status
+#' handle$status()
+#' handle$url()
+#'
+#' # Stop the app
+#' handle$stop()
+#' }
+#'
+#' @seealso [runApp()] for blocking mode, [stopApp()] to stop a running app.
+#' @export
+startApp <- function(
+  appDir = getwd(),
+  port = getOption("shiny.port"),
+  launch.browser = getOption("shiny.launch.browser", interactive()),
+  host = getOption("shiny.host", "127.0.0.1"),
+  workerId = "",
+  quiet = FALSE,
+  display.mode = c("auto", "normal", "showcase"),
+  test.mode = getOption("shiny.testmode", FALSE)
+) {
+  # OTEL: `local_otel_promise_domain()` ties its lifetime to this frame,
+  # which exits as soon as the handle is returned — before any request is
+  # served. A persistent global install would instead leak into unrelated
+  # user promises between ticks. Wrap the synchronous setup below (covers
+  # onStart) and each service iteration in `serviceNonBlocking()` (covers
+  # handlers and observers). The domain is dormant between ticks, so it
+  # stays out of user promises created at the console.
+
+  # Make warnings print immediately
+  # Set pool.scheduler to support pool package
+  ops <- options(
+    # Raise warn level to 1, but don't lower it
+    warn = max(1, getOption("warn", default = 1)),
+    pool.scheduler = scheduleTask
+  )
+
+  # Ensure options are restored and onStop callbacks fire even if
+  # as.shiny.appobj() errors. See matching guard in runApp().
+  setupComplete <- FALSE
+  on.exit(if (!setupComplete) {
+    options(ops)
+    .globals$onStopCallbacks$invoke()
+    .globals$onStopCallbacks <- Callbacks$new()
+  }, add = TRUE)
+
+  require(shiny)
+
+  result <- promises::with_otel_promise_domain({
+    appParts <- as.shiny.appobj(appDir)
+    .setupShinyApp(
+      appDir, appParts, port, launch.browser, host,
+      workerId, quiet, display.mode, test.mode, ops = ops
+    )
+  })
+  setupComplete <- TRUE
+
+  handle <- ShinyAppHandle$new(result$appUrl, result$cleanup)
+  .globals$runningHandle <- handle
+  serviceNonBlocking(handle, .globals$serviceGeneration)
+  handle
+}
+
+# Shared initialization for runApp() and startApp().
+# Handles all app setup: options, state, httpuv server, browser launch, etc.
+# Returns list(appUrl, cleanup) where cleanup() tears down the app.
+# On setup failure, internal on.exit handlers clean up partial state.
+.setupShinyApp <- function(appDir, appParts, port, launch.browser, host,
+                           workerId, quiet, display.mode, test.mode, ops,
+                           caller = parent.frame()) {
+  # Guard on.exit handlers with this flag so they only fire on setup failure.
+  # On success, cleanup responsibility is handed to the caller via the
+  # returned cleanup function.
+  cleanupOnExit <- TRUE
+
+  on.exit(if (cleanupOnExit) handlerManager$clear(), add = TRUE)
+
+  if (isRunning()) {
+    if (!is.null(.globals$runningHandle)) {
+      message("Stopping running Shiny app.")
+      .globals$runningHandle$stop()
+    } else {
+      stop("Can't start a new app while another is running. ",
+           "If your application code contains `runApp()` or `startApp()`, remove it. ",
+           "Otherwise, stop the current app first with stopApp().")
+    }
+  }
 
   # ============================================================================
   # runApp options set via shinyApp(options = list(...))
@@ -173,25 +291,55 @@ runApp <- function(appDir=getwd(),
   # | no          | yes       | use runApp   | if it's not missing (runApp specifies), use those                                                                                      |
   # | yes         | yes       | use runApp   | if it's not missing (runApp specifies), use those                                                                                      |
   #
-  # I tried to make this as compact and intuitive as possible,
-  # given that there are four distinct possibilities to check
+  # `missing()` runs in the caller's frame: with defaults on the outer
+  # formals, arguments are no longer missing by the time they reach here.
   appOps <- appParts$options
   findVal <- function(arg, default) {
     if (arg %in% names(appOps)) appOps[[arg]] else default
   }
+  if (evalq(missing(port), caller))           port <- findVal("port", port)
+  if (evalq(missing(launch.browser), caller)) launch.browser <- findVal("launch.browser", launch.browser)
+  if (evalq(missing(host), caller))           host <- findVal("host", host)
+  if (evalq(missing(quiet), caller))          quiet <- findVal("quiet", quiet)
+  if (evalq(missing(display.mode), caller))   display.mode <- findVal("display.mode", display.mode)
+  if (evalq(missing(test.mode), caller))      test.mode <- findVal("test.mode", test.mode)
 
-  if (missing(port))
-    port <- findVal("port", port)
-  if (missing(launch.browser))
-    launch.browser <- findVal("launch.browser", launch.browser)
-  if (missing(host))
-    host <- findVal("host", host)
-  if (missing(quiet))
-    quiet <- findVal("quiet", quiet)
-  if (missing(display.mode))
-    display.mode <- findVal("display.mode", display.mode)
-  if (missing(test.mode))
-    test.mode <- findVal("test.mode", test.mode)
+  on.exit(if (cleanupOnExit) options(ops), add = TRUE)
+
+  # ============================================================================
+  # Global onStart/onStop callbacks
+  # ============================================================================
+  on.exit(if (cleanupOnExit) {
+    .globals$onStopCallbacks$invoke()
+    .globals$onStopCallbacks <- Callbacks$new()
+  }, add = TRUE)
+
+  # ============================================================================
+  # Initialize app state object
+  # ============================================================================
+  # This is so calls to getCurrentAppState() can be used to find (A) whether an
+  # app is running and (B), get options and data associated with the app.
+  initCurrentAppState(appParts)
+  on.exit(if (cleanupOnExit) clearCurrentAppState(), add = TRUE)
+  # Any shinyOptions set after this point will apply to the current app only
+  # (and will not persist after the app stops).
+
+  # ============================================================================
+  # shinyOptions
+  # ============================================================================
+  # A unique identifier associated with this run of this application. It is
+  # shared across sessions.
+  shinyOptions(appToken = createUniqueId(8))
+
+  # Set up default cache for app.
+  if (is.null(getShinyOption("cache", default = NULL))) {
+    shinyOptions(cache = cachem::cache_mem(max_size = 200 * 1024^2))
+  }
+
+  # Extract appOptions (which is a list) and store them as shinyOptions, for
+  # this app. (This is the only place we have to store settings that are
+  # accessible both the UI and server portion of the app.)
+  applyCapturedAppOptions(appParts$appOptions)
 
   if (is.null(host) || is.na(host)) host <- '0.0.0.0'
 
@@ -207,8 +355,14 @@ runApp <- function(appDir=getwd(),
     # any valid version.
     ver <- Sys.getenv('SHINY_SERVER_VERSION')
     if (utils::compareVersion(ver, .shinyServerMinVersion) < 0) {
-      warning('Shiny Server v', .shinyServerMinVersion,
-              ' or later is required; please upgrade!')
+      rlang::warn(c(
+        sprintf(
+          "Shiny Server v%s or later is required; please upgrade.",
+          .shinyServerMinVersion
+        ),
+        "i" = "If you are not using Shiny Server, you are likely seeing this message because the `SHINY_PORT` environment variable is set in your environment.",
+        "i" = "Avoid using `SHINY_PORT` to prevent this warning."
+      ))
     }
   }
 
@@ -271,7 +425,7 @@ runApp <- function(appDir=getwd(),
 
   # If display mode is specified as an argument, apply it (overriding the
   # value specified in DESCRIPTION, if any).
-  display.mode <- match.arg(display.mode)
+  display.mode <- match.arg(display.mode, c("auto", "normal", "showcase"))
   if (display.mode == "normal") {
     setShowcaseDefault(0)
   }
@@ -325,24 +479,21 @@ runApp <- function(appDir=getwd(),
   # onStart/onStop callbacks
   # ============================================================================
   # Set up the onStop before we call onStart, so that it gets called even if an
-  # error happens in onStart.
+  # error happens in onStart or later during startup.
   if (!is.null(appParts$onStop))
-    on.exit(appParts$onStop(), add = TRUE)
+    on.exit(if (cleanupOnExit) appParts$onStop(), add = TRUE)
   if (!is.null(appParts$onStart))
     appParts$onStart()
 
   # ============================================================================
-  # Start/stop httpuv app
+  # Start httpuv app
   # ============================================================================
-  server <- startApp(appParts, port, host, quiet)
+  server <- startHttpuvApp(appParts, port, host, quiet)
 
   # Make the httpuv server object accessible. Needed for calling
   # addResourcePath while app is running.
   shinyOptions(server = server)
-
-  on.exit({
-    stopServer(server)
-  }, add = TRUE)
+  on.exit(if (cleanupOnExit) stopServer(server), add = TRUE)
 
   # ============================================================================
   # Launch web browser
@@ -373,39 +524,52 @@ runApp <- function(appDir=getwd(),
   # Application hooks
   # ============================================================================
   callAppHook("onAppStart", appUrl)
-  on.exit({
-    callAppHook("onAppStop", appUrl)
-  }, add = TRUE)
+  on.exit(if (cleanupOnExit) callAppHook("onAppStop", appUrl), add = TRUE)
 
-  # ============================================================================
-  # Run event loop via httpuv
-  # ============================================================================
+  # Initialize globals used by the event loop and stopApp()
   .globals$reterror <- NULL
   .globals$retval <- NULL
   .globals$stopped <- FALSE
-  # Top-level ..stacktraceoff..; matches with ..stacktraceon in observe(),
-  # reactive(), Callbacks$invoke(), and others
-  ..stacktraceoff..(
-    captureStackTraces({
-      while (!.globals$stopped) {
-        ..stacktracefloor..(serviceApp())
-      }
-    })
-  )
 
-  if (isTRUE(.globals$reterror)) {
-    stop(.globals$retval)
+  # Invalidate any stale non-blocking service loops from a previous app.
+  # Each app launch gets a fresh generation so old callbacks become no-ops.
+  .globals$serviceGeneration <- (.globals$serviceGeneration %||% 0L) + 1L
+
+  # Setup complete - disable on.exit cleanup, hand off to caller
+  cleanupOnExit <- FALSE
+
+  list(
+    appUrl = appUrl,
+    cleanup = .createCleanup(server, appParts, appUrl, ops)
+  )
+}
+
+# Consolidated cleanup function for app teardown
+.createCleanup <- function(server, appParts, appUrl, ops) {
+  cleanedUp <- FALSE
+  function() {
+    if (cleanedUp) return()
+    cleanedUp <<- TRUE
+
+    .globals$stopped <- TRUE
+    .globals$runningHandle <- NULL
+    handlerManager$clear()
+    options(ops)
+    .globals$onStopCallbacks$invoke()
+    .globals$onStopCallbacks <- Callbacks$new()
+    clearCurrentAppState()
+    if (!is.null(appParts$onStop)) appParts$onStop()
+    stopServer(server)
+    callAppHook("onAppStop", appUrl)
   }
-  else if (.globals$retval$visible)
-    .globals$retval$value
-  else
-    invisible(.globals$retval$value)
 }
 
 #' Stop the currently running Shiny app
 #'
 #' Stops the currently running Shiny app, returning control to the caller of
-#' [runApp()].
+#' [runApp()]. Despite the similar names, `stopApp()` is not the
+#' counterpart of [startApp()] — it is the counterpart of [runApp()],
+#' controlling its return value via `returnValue`.
 #'
 #' @param returnValue The value that should be returned from
 #'   [runApp()].

R/server.R

@@ -274,15 +274,20 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
                 args <- argsForServerFunc(serverFunc, shinysession)
 
                 withReactiveDomain(shinysession, {
-                  do.call(
-                    # No corresponding ..stacktraceoff; the server func is pure
-                    # user code
-                    wrapFunctionLabel(appvars$server, "server",
-                      ..stacktraceon = TRUE
-                    ),
-                    args
-                  )
+                  otel_span_session_start(domain = shinysession, {
+
+                    do.call(
+                      # No corresponding ..stacktraceoff; the server func is pure
+                      # user code
+                      wrapFunctionLabel(appvars$server, "server",
+                        ..stacktraceon = TRUE
+                      ),
+                      args
+                    )
+
+                  })
                 })
+
               })
             },
             update = {
@@ -382,7 +387,7 @@ removeSubApp <- function(path) {
   handlerManager$removeWSHandler(path)
 }
 
-startApp <- function(appObj, port, host, quiet) {
+startHttpuvApp <- function(appObj, port, host, quiet) {
   appHandlers <- createAppHandlers(appObj$httpHandler, appObj$serverFuncSource)
   handlerManager$addHandler(appHandlers$http, "/", tail = TRUE)
   handlerManager$addWSHandler(appHandlers$ws, "/", tail = TRUE)
@@ -474,9 +479,12 @@ startApp <- function(appObj, port, host, quiet) {
   }
 }
 
-# Run an application that was created by \code{\link{startApp}}. This
+# Run an application that was created by \code{\link{startHttpuvApp}}. This
 # function should normally be called in a \code{while(TRUE)} loop.
-serviceApp <- function() {
+serviceApp <- function(
+  # rely on lazy evaluation for maximum efficiency
+  timeout = max(1, min(maxTimeout, timerCallbacks$timeToNextEvent(), later::next_op_secs()))
+) {
   timerCallbacks$executeElapsed()
 
   flushReact()
@@ -486,13 +494,58 @@ serviceApp <- function() {
   # to keep the session responsive to user input
   maxTimeout <- ifelse(interactive(), 100, 1000)
 
-  timeout <- max(1, min(maxTimeout, timerCallbacks$timeToNextEvent(), later::next_op_secs()))
   service(timeout)
 
   flushReact()
   flushPendingSessions()
 }
 
+# Non-blocking service loop using later callbacks.
+# Uses 1ms delay between iterations to yield CPU for console interaction.
+# The generation token (incremented on every runApp() call) ensures that when
+# a new app starts, any stale service loop from a previous non-blocking app
+# exits cleanly instead of continuing to run.
+# Each iteration wraps `serviceApp()` in `with_otel_promise_domain()` so the
+# OTEL domain is active while Shiny processes its own work — handlers,
+# later callbacks, promise fulfillments — all executed synchronously inside
+# `serviceApp()`. Span wrapping is attached at promise-registration time, so
+# callbacks registered inside an iteration stay instrumented when they fire
+# later. The domain is dormant between ticks, keeping it out of unrelated
+# user promises created while the console is interactive.
+serviceNonBlocking <- function(handle, generation) {
+  serviceLoop <- function() {
+    if (!identical(.globals$serviceGeneration, generation)) {
+      return(invisible())
+    }
+    if (!.globals$stopped) {
+      promises::with_otel_promise_domain(
+        ..stacktraceoff..(
+          captureStackTraces(
+            tryCatch(
+              ..stacktracefloor..(serviceApp(.shinyServiceDelaySecs * 1000)),
+              error = function(e) {
+                .globals$stopped <- TRUE
+                .globals$retval <- e
+                .globals$reterror <- TRUE
+              }
+            )
+          )
+        )
+      )
+    }
+    if (!identical(.globals$serviceGeneration, generation)) {
+      return(invisible())
+    }
+    if (!.globals$stopped) {
+      later::later(serviceLoop, delay = .shinyServiceDelaySecs)
+    } else {
+      handle$stop()
+    }
+  }
+  later::later(serviceLoop, delay = .shinyServiceDelaySecs)
+}
+
+.shinyServiceDelaySecs <- 0.001
 .shinyServerMinVersion <- '0.3.4'
 
 #' Check whether a Shiny application is running

R/shiny-options.R

@@ -70,7 +70,7 @@ getShinyOption <- function(name, default = NULL) {
 #'
 #'   You can customize the file patterns Shiny will monitor by setting the
 #'   shiny.autoreload.pattern option. For example, to monitor only `ui.R`:
-#'   `options(shiny.autoreload.pattern = glob2rx("ui.R"))`. 
+#'   `options(shiny.autoreload.pattern = glob2rx("ui.R"))`.
 #'
 #'   As mentioned above, Shiny no longer polls watched files for changes.
 #'   Instead, using \pkg{watcher}, Shiny is notified of file changes as they
@@ -160,6 +160,31 @@ getShinyOption <- function(name, default = NULL) {
 # '  side devmode features. Currently the primary feature is the client-side
 # '  error console.}
 ### end shiny.client_devmode
+#' \item{shiny.otel.collect (defaults to `Sys.getenv("SHINY_OTEL_COLLECT",
+#'   "all")`)}{Determines how Shiny will interact with OpenTelemetry.
+#'
+#'   Supported values:
+#'   * `"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 and logs for setting
+#'     reactive vals and values. (Includes `"reactive_update"` features). This
+#'     option must be set when creating any reactive objects that should record
+#'     OpenTelemetry spans / logs. See [`withOtelCollect()`] and
+#'     [`localOtelCollect()`] for ways to set this option locally when creating
+#'     your reactive expressions.
+#'   * `"all"` - All Shiny OpenTelemetry tracing. Currently equivalent to
+#'     `"reactivity"`.
+#'
+#'   This option is useful for debugging and profiling while in production. This
+#'   option will only be useful if the `otelsdk` package is installed and
+#'   `otel::is_tracing_enabled()` returns `TRUE`. Please have any OpenTelemetry
+#'   environment variables set before loading any relevant R packages.
+#'
+#'   To set this option locally within a specific part of your Shiny
+#'   application, see [`withOtelCollect()`] and [`localOtelCollect()`].}
+#' \item{shiny.otel.sanitize.errors (defaults to `TRUE`)}{If `TRUE`, fatal and unhandled errors will be sanitized before being sent to the OpenTelemetry backend. The default value of `TRUE` is set to avoid potentially sending sensitive information to the OpenTelemetry backend. If you want the full error message and stack trace to be sent to the OpenTelemetry backend, set this option to `FALSE` or use `safeError(e)`.}
 #' }
 #'
 #'

R/shiny-package.R

@@ -4,11 +4,12 @@
 #' @importFrom lifecycle deprecated is_present
 #' @importFrom grDevices dev.set dev.cur
 #' @importFrom fastmap fastmap
-#' @importFrom promises %...!%
-#' @importFrom promises %...>%
 #' @importFrom promises
-#'    promise promise_resolve promise_reject is.promising
-#'    as.promise
+#'     %...!% %...>%
+#'    as.promise is.promising is.promise
+#'    promise_resolve promise_reject
+#'    hybrid_then
+#'    with_promise_domain new_promise_domain
 #' @importFrom rlang
 #'    quo enquo enquo0 as_function get_expr get_env new_function enquos
 #'    eval_tidy expr pairlist2 new_quosure enexpr as_quosure is_quosure inject

R/shiny.R

@@ -428,7 +428,7 @@ ShinySession <- R6Class(
         stop("Nested calls to withCurrentOutput() are not allowed.")
       }
 
-      promises::with_promise_domain(
+      with_promise_domain(
         createVarPromiseDomain(private, "currentOutputName", name),
         expr
       )
@@ -1056,6 +1056,19 @@ ShinySession <- R6Class(
         class(e) <- c("shiny.error.fatal", class(e))
       }
 
+      # For fatal errors, always log.
+      # For non-fatal errors, only log if we haven't seen this error before.
+      if (close || !has_seen_otel_exception(e)) {
+        otel_log(
+          if (close) "Fatal error" else "Unhandled error",
+          severity = if (close) "fatal" else "error",
+          attributes = otel::as_attributes(list(
+            session.id = self$token,
+            error = get_otel_error_obj(e)
+          ))
+        )
+      }
+
       private$unhandledErrorCallbacks$invoke(e, onError = printError)
       .globals$onUnhandledErrorCallbacks$invoke(e, onError = printError)
 
@@ -1073,7 +1086,9 @@ ShinySession <- R6Class(
       }
       # ..stacktraceon matches with the top-level ..stacktraceoff..
       withReactiveDomain(self, {
-        private$closedCallbacks$invoke(onError = printError, ..stacktraceon = TRUE)
+        otel_span_session_end(domain = self, {
+          private$closedCallbacks$invoke(onError = printError, ..stacktraceon = TRUE)
+        })
       })
     },
     isClosed = function() {
@@ -1142,7 +1157,8 @@ ShinySession <- R6Class(
         attr(label, "srcref") <- srcref
         attr(label, "srcfile") <- srcfile
 
-        obs <- observe(..stacktraceon = FALSE, {
+        # Do not bind this `observe()` call
+        obs <- with_no_otel_collect(observe(..stacktraceon = FALSE, {
 
           private$sendMessage(recalculating = list(
             name = name, status = 'recalculating'
@@ -1154,7 +1170,9 @@ ShinySession <- R6Class(
             hybrid_chain(
               {
                 private$withCurrentOutput(name, {
-                  shinyCallingHandlers(func())
+                  maybe_with_otel_span_reactive_update({
+                    shinyCallingHandlers(func())
+                  }, domain = self)
                 })
               },
               catch = function(cond) {
@@ -1179,9 +1197,7 @@ ShinySession <- R6Class(
                 } else {
                   if (isTRUE(getOption("show.error.messages"))) printError(cond)
                   if (getOption("shiny.sanitize.errors", FALSE)) {
-                    cond <- simpleError(paste("An error has occurred. Check your",
-                      "logs or contact the app author for",
-                      "clarification."))
+                    cond <- sanitized_error()
                   }
                   self$unhandledError(cond, close = FALSE)
                   invisible(structure(list(), class = "try-error", condition = cond))
@@ -1245,7 +1261,7 @@ ShinySession <- R6Class(
                 private$invalidatedOutputValues$set(name, value)
             }
           )
-        }, suspended=private$shouldSuspend(name), label=label)
+        }, suspended=private$shouldSuspend(name), label=label))
 
         # If any output attributes were added to the render function attach
         # them to observer.
@@ -2023,7 +2039,7 @@ ShinySession <- R6Class(
           ext <- paste(".", ext, sep = "")
         tmpdata <- tempfile(fileext = ext)
         return(Context$new(getDefaultReactiveDomain(), '[download]')$run(function() {
-          promises::with_promise_domain(reactivePromiseDomain(), {
+          with_promise_domain(reactivePromiseDomain(), {
             captureStackTraces({
               self$incrementBusyCount()
               hybrid_chain(
@@ -2195,6 +2211,8 @@ ShinySession <- R6Class(
       if (private$busyCount == 0L) {
         rLog$asyncStart(domain = self)
         private$sendMessage(busy = "busy")
+
+        otel_span_reactive_update_init(domain = self)
       }
       private$busyCount <- private$busyCount + 1L
     },
@@ -2216,6 +2234,8 @@ ShinySession <- R6Class(
             private$startCycle()
           }
         })
+
+        otel_span_reactive_update_teardown(domain = self)
       }
     }
   )
@@ -2723,3 +2743,10 @@ validate_session_object <- function(session, label = as.character(sys.call(sys.p
     )
   }
 }
+
+
+sanitized_error <- function() {
+  simpleError(paste("An error has occurred. Check your",
+    "logs or contact the app author for",
+    "clarification."))
+}

R/shinywrappers.R

@@ -130,11 +130,20 @@ markRenderFunction <- function(
       # stop warning from happening again for the same object
       hasExecuted$set(TRUE)
     }
-    if (is.null(formals(renderFunc))) renderFunc()
-    else renderFunc(...)
+    ..stacktraceoff..(
+      if (is.null(formals(renderFunc))) renderFunc()
+      else renderFunc(...)
+    )
   }
 
-  structure(
+  otelAttrs <-
+    otel_srcref_attributes(
+      attr(renderFunc, "wrappedFunc", exact = TRUE),
+      # Can't retrieve the render function used at this point, so just use NULL
+      fn_name = NULL
+    )
+
+  ret <- structure(
     wrappedRenderFunc,
     class          = c("shiny.render.function", "function"),
     outputFunc     = uiFunc,
@@ -142,8 +151,15 @@ markRenderFunction <- function(
     hasExecuted    = hasExecuted,
     cacheHint      = cacheHint,
     cacheWriteHook = cacheWriteHook,
-    cacheReadHook  = cacheReadHook
+    cacheReadHook  = cacheReadHook,
+    otelAttrs      = otelAttrs
   )
+
+  if (has_otel_collect("reactivity")) {
+    ret <- enable_otel_shiny_render_function(ret)
+  }
+
+  ret
 }
 
 #' @export
@@ -261,7 +277,7 @@ createRenderFunction <- function(
 ) {
   renderFunc <- function(shinysession, name, ...) {
     hybrid_chain(
-      func(),
+      ..stacktraceon..(func()),
       function(value) {
         transform(value, shinysession, name, ...)
       }
@@ -271,9 +287,7 @@ createRenderFunction <- function(
   # Hoist func's wrappedFunc attribute into renderFunc, so that when we pass
   # renderFunc on to markRenderFunction, it is able to find the original user
   # function.
-  if (identical(cacheHint, "auto")) {
-    attr(renderFunc, "wrappedFunc") <- attr(func, "wrappedFunc", exact = TRUE)
-  }
+  attr(renderFunc, "wrappedFunc") <- attr(func, "wrappedFunc", exact = TRUE)
 
   markRenderFunction(outputFunc, renderFunc, outputArgs, cacheHint,
                      cacheWriteHook, cacheReadHook)
@@ -321,7 +335,7 @@ as.tags.shiny.render.function <- function(x, ..., inline = FALSE) {
 
 # Get relevant attributes from a render function object.
 renderFunctionAttributes <- function(x) {
-  attrs <- c("outputFunc", "outputArgs", "hasExecuted", "cacheHint")
+  attrs <- c("outputFunc", "outputArgs", "hasExecuted", "cacheHint", "otelAttrs")
   names(attrs) <- attrs
   lapply(attrs, function(name) attr(x, name, exact = TRUE))
 }
@@ -383,7 +397,7 @@ markOutputAttrs <- function(renderFunc, snapshotExclude = NULL,
 #' The corresponding HTML output tag should be `div` or `img` and have
 #' the CSS class name `shiny-image-output`.
 #'
-#' @seealso 
+#' @seealso
 #' * For more details on how the images are generated, and how to control
 #'   the output, see [plotPNG()].
 #' * Use [outputOptions()] to set general output options for an image output.
@@ -616,7 +630,7 @@ renderPrint <- function(expr, env = parent.frame(), quoted = FALSE,
     domain <- createRenderPrintPromiseDomain(width)
     hybrid_chain(
       {
-        promises::with_promise_domain(domain, func())
+        with_promise_domain(domain, ..stacktraceon..(func()))
       },
       function(value) {
         res <- withVisible(value)
@@ -645,7 +659,7 @@ renderPrint <- function(expr, env = parent.frame(), quoted = FALSE,
 createRenderPrintPromiseDomain <- function(width) {
   f <- file()
 
-  promises::new_promise_domain(
+  new_promise_domain(
     wrapOnFulfilled = function(onFulfilled) {
       force(onFulfilled)
       function(...) {
@@ -815,9 +829,9 @@ renderUI <- function(expr, env = parent.frame(), quoted = FALSE,
 #'
 #' @seealso
 #' * The download handler, like other outputs, is suspended (disabled) by
-#'   default for download buttons and links that are hidden. Use 
-#'   [outputOptions()] to control this behavior, e.g. to set 
-#'   `suspendWhenHidden = FALSE` if the download is initiated by 
+#'   default for download buttons and links that are hidden. Use
+#'   [outputOptions()] to control this behavior, e.g. to set
+#'   `suspendWhenHidden = FALSE` if the download is initiated by
 #'   programmatically clicking on the download button using JavaScript.
 #' @export
 downloadHandler <- function(filename, content, contentType=NULL, outputArgs=list()) {
@@ -951,7 +965,7 @@ legacyRenderDataTable <- function(expr, options = NULL, searchDelay = 500,
     options <- checkDT9(options)
     res <- checkAsIs(options)
     hybrid_chain(
-      func(),
+      ..stacktraceon..(func()),
       function(data) {
         if (length(dim(data)) != 2) return() # expects a rectangular data object
         if (is.data.frame(data)) data <- as.data.frame(data)

R/showcase.R

@@ -33,13 +33,6 @@ showcaseHead <- function() {
 
   deps  <- list(
     jqueryuiDependency(),
-    htmlDependency(
-      "showdown",
-      "0.3.1",
-      src = "www/shared/showdown/compressed",
-      package="shiny",
-      script = "showdown.js"
-    ),
     htmlDependency(
       "highlight.js",
       "6.2",
@@ -61,10 +54,11 @@ showcaseHead <- function() {
 
   mdfile <- file.path.ci(getwd(), 'Readme.md')
   html <- tagList(
-    if (file.exists(mdfile))
-      tags$script(type="text/markdown", id="showcase-markdown-content",
-        paste(readUTF8(mdfile), collapse="\n"))
-    else ""
+    if (file.exists(mdfile)) {
+      md_content <- paste(readUTF8(mdfile), collapse="\n")
+      md_html <- commonmark::markdown_html(md_content, extensions = TRUE)
+      tags$template(id="showcase-markdown-content", HTML(md_html))
+    } else ""
   )
 
   return(attachDependencies(html, deps))

R/utils-lang.R

@@ -208,8 +208,10 @@ exprToLabel <- function(expr, function_name, label = NULL) {
   if (is.null(label)) {
     label <- rexprSrcrefToLabel(
       srcref[[1]],
-      simpleExprToFunction(expr, function_name)
+      simpleExprToFunction(expr, function_name),
+      function_name
     )
+    label <- as_default_label(label)
   }
   if (length(srcref) >= 2) attr(label, "srcref") <- srcref[[2]]
   attr(label, "srcfile") <- srcFileOfRef(srcref[[1]])
@@ -229,10 +231,12 @@ funcToLabelBody <- function(func) {
 funcToLabel <- function(func, functionLabel, label = NULL) {
   if (!is.null(label)) return(label)
 
-  sprintf(
-    '%s(%s)',
-    functionLabel,
-    funcToLabelBody(func)
+  as_default_label(
+    sprintf(
+      '%s(%s)',
+      functionLabel,
+      funcToLabelBody(func)
+    )
   )
 }
 quoToLabelBody <- function(q) {
@@ -241,9 +245,19 @@ quoToLabelBody <- function(q) {
 quoToLabel <- function(q, functionLabel, label = NULL) {
   if (!is.null(label)) return(label)
 
-  sprintf(
-    '%s(%s)',
-    functionLabel,
-    quoToLabelBody(q)
+  as_default_label(
+    sprintf(
+      '%s(%s)',
+      functionLabel,
+      quoToLabelBody(q)
+    )
   )
 }
+
+as_default_label <- function(x) {
+  class(x) <- c("default_label", class(x))
+  x
+}
+is_default_label <- function(x) {
+  inherits(x, "default_label")
+}

R/utils.R

@@ -797,8 +797,8 @@ cachedFuncWithFile <- function(dir, file, func, case.sensitive = FALSE) {
   last_autoreload <- 0
 
   function(...) {
-    fname <- if (case.sensitive) { 
-      file.path(dir, file) 
+    fname <- if (case.sensitive) {
+      file.path(dir, file)
     } else {
       file.path.ci(dir, file)
     }
@@ -1366,31 +1366,62 @@ tryNativeEncoding <- function(string) {
   if (identical(enc2utf8(string2), string)) string2 else string
 }
 
-# similarly, try to source() a file with UTF-8
-sourceUTF8 <- function(file, envir = globalenv()) {
-  lines <- readUTF8(file)
-  enc <- if (any(Encoding(lines) == 'UTF-8')) 'UTF-8' else 'unknown'
-  src <- srcfilecopy(file, lines, isFile = TRUE)  # source reference info
-  # oddly, parse(file) does not work when file contains multibyte chars that
-  # **can** be encoded natively on Windows (might be a bug in base R); we
-  # rewrite the source code in a natively encoded temp file and parse it in this
-  # case (the source reference is still pointed to the original file, though)
-  if (isWindows() && enc == 'unknown') {
-    file <- tempfile(); on.exit(unlink(file), add = TRUE)
-    writeLines(lines, file)
-  }
-  exprs <- try(parse(file, keep.source = FALSE, srcfile = src, encoding = enc))
-  if (inherits(exprs, "try-error")) {
-    diagnoseCode(file)
-    stop("Error sourcing ", file)
+maybeAnnotateSourceForArk <- function(file, lines) {
+  ark_annotate_source <- get0(".ark_annotate_source", baseenv())
+
+  if (is.null(ark_annotate_source)) {
+    return(lines)
   }
 
-  # Wrap the exprs in first `{`, then ..stacktraceon..(). It's only really the
-  # ..stacktraceon..() that we care about, but the `{` is needed to make that
-  # possible.
-  exprs <- makeCall(`{`, exprs)
-  # Need to wrap exprs in a list because we want it treated as a single argument
-  exprs <- makeCall(..stacktraceon.., list(exprs))
+  file <- normalizePath(file, mustWork = TRUE, winslash = "/") # Just to be safe
+  uri <- paste0("file:///", sub("^/", "", file)) # Ark expects URIs
+  lines_str <- paste(lines, collapse = "\n")
+  tryCatch(
+    {
+      annotated <- ark_annotate_source(lines_str, uri)
+      if (!is.null(annotated)) {
+        lines <- strsplit(annotated, "\n", fixed = TRUE)[[1]]
+      }
+    },
+    error = function(cnd) {
+      rlang::warn("Can't inject breakpoints for Ark", parent = cnd)
+    }
+  )
+
+
+  lines
+}
+
+# similarly, try to source() a file with UTF-8
+sourceUTF8 <- function(file, envir = globalenv()) {
+  file_norm <- normalizePath(file, mustWork = TRUE, winslash = "/")
+  lines <- readUTF8(file)
+  enc <- if (any(Encoding(lines) == 'UTF-8')) 'UTF-8' else 'unknown'
+
+  # Inject Ark annotations for breakpoints if available
+  lines <- maybeAnnotateSourceForArk(file, lines)
+
+  # Wrap in `..stacktraceon..({...})` using string manipulation before parsing,
+  # with a `#line` directive to map source references back to the original file
+  lines <- c(
+    "..stacktraceon..({",
+    sprintf('#line 1 "%s"', file_norm),
+    lines,
+    "})"
+  )
+
+  # Create a source file copy, i.e. an in-memory srcfile that contains all the
+  # code but refers to an original file
+  src <- srcfilecopy(file, lines, isFile = TRUE)
+
+  # Parse from our annotated lines
+  exprs <- tryCatch(
+    parse(text = lines, keep.source = FALSE, srcfile = src, encoding = enc),
+    error = function(cnd) {
+      diagnoseCode(file)
+      stop("Error sourcing ", file)
+    }
+  )
 
   eval(exprs, envir)
 }
@@ -1433,7 +1464,11 @@ URLencode <- function(value, reserved = FALSE) {
 dateYMD <- function(date = NULL, argName = "value") {
   if (!length(date)) return(NULL)
   tryCatch({
-      res <- format(as.Date(date), "%Y-%m-%d")
+      if (inherits(date, "POSIXt")) {
+        res <- format(date, "%Y-%m-%d")
+      } else {
+        res <- format(as.Date(date), "%Y-%m-%d")
+      }
       if (any(is.na(res))) stop()
       date <- res
     },
@@ -1525,7 +1560,7 @@ promise_chain <- function(promise, ..., catch = NULL, finally = NULL,
   }
 
   if (!is.null(domain)) {
-    promises::with_promise_domain(domain, do(), replace = replace)
+    with_promise_domain(domain, do(), replace = replace)
   } else {
     do()
   }
@@ -1542,7 +1577,7 @@ hybrid_chain <- function(expr, ..., catch = NULL, finally = NULL,
       {
         captureStackTraces({
           result <- withVisible(force(expr))
-          if (promises::is.promising(result$value)) {
+          if (is.promising(result$value)) {
             # Purposefully NOT including domain (nor replace), as we're already in
             # the domain at this point
             p <- promise_chain(valueWithVisible(result), ..., catch = catch, finally = finally)
@@ -1576,7 +1611,7 @@ hybrid_chain <- function(expr, ..., catch = NULL, finally = NULL,
   }
 
   if (!is.null(domain)) {
-    promises::with_promise_domain(domain, do(), replace = replace)
+    with_promise_domain(domain, do(), replace = replace)
   } else {
     do()
   }
@@ -1594,7 +1629,7 @@ createVarPromiseDomain <- function(env, name, value) {
   force(name)
   force(value)
 
-  promises::new_promise_domain(
+  new_promise_domain(
     wrapOnFulfilled = function(onFulfilled) {
       function(...) {
         orig <- env[[name]]

README.md

@@ -61,7 +61,7 @@ We welcome contributions to the **shiny** package. Please see our [CONTRIBUTING.
 
 ## License
 
-The shiny package as a whole is licensed under the GPLv3. See the [LICENSE](LICENSE) file for more details.
+The shiny package as a whole is licensed under the MIT License. See the [LICENSE](LICENSE) file for more details.
 
 ## R version support
 

cran-comments.md

@@ -1,40 +1,129 @@
+## Comments
+
+#### 2025-12-08
+
+Test has been removed from CRAN checks.
+
+Also added a couple bug fixes as found by users.
+
+Please let me know if you need any further changes.
+
+Thank you,
+Carson
+
+#### 2025-12-04
+
+Error:
+
+```
+Check Details
+Version: 1.12.0
+Check: tests
+Result: ERROR
+    Running ‘testthat.R’ [100s/394s]
+  Running the tests in ‘tests/testthat.R’ failed.
+  Complete output:
+    > library(testthat)
+    > library(shiny)
+    >
+    > test_check("shiny")
+    Saving _problems/test-timer-35.R
+    [ FAIL 1 | WARN 0 | SKIP 22 | PASS 1981 ]
+
+    ══ Skipped tests (22) ══════════════════════════════════════════════════════════
+    • File system is not case-sensitive (1): 'test-app.R:36:5'
+    • I'm not sure of a great way to test this without timers. (1):
+      'test-test-server.R:216:3'
+    • Not testing in CI (1): 'test-devmode.R:17:3'
+    • On CRAN (18): 'test-actionButton.R:59:1', 'test-busy-indication.R:1:1',
+      'test-busy-indication.R:15:1', 'test-busy-indication.R:50:1',
+      'test-otel-error.R:1:1', 'test-otel-mock.R:1:1', 'test-pkgdown.R:3:3',
+      'test-reactivity.r:146:1', 'test-reactivity.r:1240:5',
+      'test-reactivity.r:1240:5', 'test-stacks-deep.R:93:1',
+      'test-stacks-deep.R:141:1', 'test-stacks.R:140:3', 'test-tabPanel.R:46:1',
+      'test-tabPanel.R:66:1', 'test-tabPanel.R:73:1', 'test-tabPanel.R:83:1',
+      'test-utils.R:177:3'
+    • {shinytest2} is not installed (1): 'test-test-shinyAppTemplate.R:2:1'
+
+    ══ Failed tests ════════════════════════════════════════════════════════════════
+    ── Failure ('test-timer.R:35:3'): Unscheduling works ───────────────────────────
+    Expected `timerCallbacks$.times` to be identical to `origTimes`.
+    Differences:
+    `attr(actual, 'row.names')` is an integer vector ()
+    `attr(expected, 'row.names')` is a character vector ()
+
+
+    [ FAIL 1 | WARN 0 | SKIP 22 | PASS 1981 ]
+    Error:
+    ! Test failures.
+    Execution halted
+```
+
+
+#### 2025-12-03
+
+```
+Dear maintainer,
+
+Please see the problems shown on
+<https://cran.r-project.org/web/checks/check_results_shiny.html>.
+
+Please correct before 2025-12-17 to safely retain your package on CRAN.
+
+The CRAN Team
+```
+
+## `R CMD check` results:
+
+0 errors | 0 warning | 1 note
+
+```
+─  checking CRAN incoming feasibility ... [7s/70s] NOTE (1m 9.5s)
+   Maintainer: ‘Carson Sievert <carson@posit.co>’
+
+   Days since last update: 5
+```
+
+
 ## revdepcheck results
 
-We checked 1278 reverse dependencies (1277 from CRAN + 1 from Bioconductor), comparing R CMD check results across CRAN and dev versions of shiny.
+We checked 1383 reverse dependencies (1376 from CRAN + 7 from Bioconductor), comparing R CMD check results across CRAN and dev versions of this package.
 
- * We saw 2 new problems (NOTEs only)
- * We failed to check 19 packages due to installation issues
+ * We saw 0 new problems
+ * We failed to check 31 packages
 
 Issues with CRAN packages are summarised below.
 
-### New problems
-
-R CMD check displayed NOTEs for two packages, unrelated to changes in shiny.
-
-* HH
-  checking installed package size ... NOTE
-
-* PopED
-  checking installed package size ... NOTE
-
 ### Failed to check
 
-* animalEKF
-* AovBay
-* Certara.VPCResults
-* chipPCR
+* AssumpSure
+* boinet
+* brms
+* cheem
 * ctsem
-* dartR.sim
-* diveR
-* gap
-* jsmodule
+* detourr
+* FAfA
+* fio
+* fitteR
+* FossilSimShiny
+* GDINA
+* ggsem
+* grandR
+* hbsaems
+* langevitour
+* lavaan.shiny
+* lcsm
+* linkspotter
 * loon.shiny
-* robmedExtra
+* MOsemiind
+* MVN
+* pandemonium
+* polarisR
+* RCTrep
 * rstanarm
-* SensMap
-* Seurat
-* shinyTempSignal
-* Signac
-* statsr
+* semdrw
+* shotGroups
+* sphereML
+* spinifex
+* SurprisalAnalysis
 * TestAnaAPP
-* tidyvpc

inst/www/shared/busy-indicators/busy-indicators.css

@@ -1,2 +1,2 @@
-/*! shiny 1.11.1.9000 | (c) 2012-2025 Posit Software, PBC. | License: GPL-3 | file LICENSE */
+/*! shiny 1.13.0.9000 | (c) 2012-2026 Posit Software, PBC. | License: MIT + file LICENSE */
 :where([data-shiny-busy-spinners] .recalculating){position:relative}[data-shiny-busy-spinners] .recalculating{min-height:var(--shiny-spinner-size, 32px)}[data-shiny-busy-spinners] .recalculating:after{position:absolute;content:"";--_shiny-spinner-url: var(--shiny-spinner-url, url(spinners/ring.svg));--_shiny-spinner-color: var(--shiny-spinner-color, var(--bs-primary, #007bc2));--_shiny-spinner-size: var(--shiny-spinner-size, 32px);--_shiny-spinner-delay: var(--shiny-spinner-delay, 1s);background:var(--_shiny-spinner-color);width:var(--_shiny-spinner-size);height:var(--_shiny-spinner-size);inset:calc(50% - var(--_shiny-spinner-size) / 2);mask-image:var(--_shiny-spinner-url);-webkit-mask-image:var(--_shiny-spinner-url);opacity:0;animation-delay:var(--_shiny-spinner-delay);animation-name:fade-in;animation-duration:.25s;animation-fill-mode:forwards}[data-shiny-busy-spinners] .recalculating:has(>*),[data-shiny-busy-spinners] .recalculating:empty{opacity:1}[data-shiny-busy-spinners] .recalculating>*:not(.recalculating){opacity:var(--_shiny-fade-opacity);transition:opacity .25s ease var(--shiny-spinner-delay, 1s)}[data-shiny-busy-spinners] .recalculating.html-widget-output{visibility:inherit!important}[data-shiny-busy-spinners] .recalculating.html-widget-output>*{visibility:hidden}[data-shiny-busy-spinners] .recalculating.html-widget-output :after{visibility:visible}[data-shiny-busy-spinners] .recalculating.shiny-html-output:not(.shiny-table-output):after{display:none}[data-shiny-busy-spinners][data-shiny-busy-pulse].shiny-busy:after{--_shiny-pulse-background: var( --shiny-pulse-background, linear-gradient( 120deg, transparent, var(--bs-indigo, #4b00c1), var(--bs-purple, #74149c), var(--bs-pink, #bf007f), transparent ) );--_shiny-pulse-height: var(--shiny-pulse-height, 3px);--_shiny-pulse-speed: var(--shiny-pulse-speed, 1.2s);position:fixed;top:0;left:0;height:var(--_shiny-pulse-height);background:var(--_shiny-pulse-background);z-index:9999;animation-name:busy-page-pulse;animation-duration:var(--_shiny-pulse-speed);animation-direction:alternate;animation-iteration-count:infinite;animation-timing-function:ease-in-out;content:""}[data-shiny-busy-spinners][data-shiny-busy-pulse].shiny-busy:has(.recalculating:not(.shiny-html-output)):after{display:none}[data-shiny-busy-spinners][data-shiny-busy-pulse].shiny-busy:has(.recalculating.shiny-table-output):after{display:none}[data-shiny-busy-spinners][data-shiny-busy-pulse].shiny-busy:has(#shiny-disconnected-overlay):after{display:none}[data-shiny-busy-pulse]:not([data-shiny-busy-spinners]).shiny-busy:after{--_shiny-pulse-background: var( --shiny-pulse-background, linear-gradient( 120deg, transparent, var(--bs-indigo, #4b00c1), var(--bs-purple, #74149c), var(--bs-pink, #bf007f), transparent ) );--_shiny-pulse-height: var(--shiny-pulse-height, 3px);--_shiny-pulse-speed: var(--shiny-pulse-speed, 1.2s);position:fixed;top:0;left:0;height:var(--_shiny-pulse-height);background:var(--_shiny-pulse-background);z-index:9999;animation-name:busy-page-pulse;animation-duration:var(--_shiny-pulse-speed);animation-direction:alternate;animation-iteration-count:infinite;animation-timing-function:ease-in-out;content:""}[data-shiny-busy-pulse]:not([data-shiny-busy-spinners]).shiny-busy:has(#shiny-disconnected-overlay):after{display:none}@keyframes fade-in{0%{opacity:0}to{opacity:1}}@keyframes busy-page-pulse{0%{left:-14%;right:97%}45%{left:0%;right:14%}55%{left:14%;right:0%}to{left:97%;right:-14%}}.shiny-spinner-output-container{--shiny-spinner-size: 0px}

inst/www/shared/shiny-autoreload.js

@@ -1,3 +1,3 @@
-/*! shiny 1.11.1.9000 | (c) 2012-2025 Posit Software, PBC. | License: GPL-3 | file LICENSE */
+/*! shiny 1.13.0.9000 | (c) 2012-2026 Posit Software, PBC. | License: MIT + file LICENSE */
 "use strict";(()=>{document.documentElement.classList.add("autoreload-enabled");var c=window.location.protocol==="https:"?"wss:":"ws:",s=window.location.pathname.replace(/\/?$/,"/")+"autoreload/",i=`${c}//${window.location.host}${s}`,l=document.currentScript?.dataset?.wsUrl||i;async function u(o){let e=new WebSocket(o),n=!1;return new Promise((a,r)=>{e.onopen=()=>{n=!0},e.onerror=t=>{r(t)},e.onclose=()=>{n?a(!1):r(new Error("WebSocket connection failed"))},e.onmessage=function(t){t.data==="autoreload"&&a(!0)}})}async function d(o){return new Promise(e=>setTimeout(e,o))}async function w(){for(;;){try{if(await u(l)){window.location.reload();return}}catch{console.debug("Giving up on autoreload");return}await d(1e3)}}w().catch(o=>{console.error(o)});})();
 //# sourceMappingURL=shiny-autoreload.js.map

inst/www/shared/shiny-showcase.css

@@ -1,2 +1,2 @@
-/*! shiny 1.11.1.9000 | (c) 2012-2025 Posit Software, PBC. | License: GPL-3 | file LICENSE */
+/*! shiny 1.13.0.9000 | (c) 2012-2026 Posit Software, PBC. | License: MIT + file LICENSE */
 #showcase-well{border-radius:0}.shiny-code{background-color:#fff;margin-bottom:0}.shiny-code code{font-family:Menlo,Consolas,Courier New,monospace}.shiny-code-container{margin-top:20px;clear:both}.shiny-code-container h3{display:inline;margin-right:15px}.showcase-header{font-size:16px;font-weight:400}.showcase-code-link{text-align:right;padding:15px}#showcase-app-container{vertical-align:top}#showcase-code-tabs{margin-right:15px}#showcase-code-tabs pre{border:none;line-height:1em}#showcase-code-tabs .nav,#showcase-code-tabs ul{margin-bottom:0}#showcase-code-tabs .tab-content{border-style:solid;border-color:#e5e5e5;border-width:0px 1px 1px 1px;overflow:auto;border-bottom-right-radius:4px;border-bottom-left-radius:4px}#showcase-app-code{width:100%}#showcase-code-position-toggle{float:right}#showcase-sxs-code{padding-top:20px;vertical-align:top}.showcase-code-license{display:block;text-align:right}#showcase-code-content pre{background-color:#fff}

inst/www/shared/shiny-showcase.js

@@ -1,3 +1,3 @@
-/*! shiny 1.11.1.9000 | (c) 2012-2025 Posit Software, PBC. | License: GPL-3 | file LICENSE */
-"use strict";(()=>{var m=400;function c(e,l){let t=0;if(e.nodeType===3){let n=e.nodeValue?.replace(/\n/g,"").length??0;if(n>=l)return{element:e,offset:l};t+=n}else if(e.nodeType===1&&e.firstChild){let n=c(e.firstChild,l);if(n.element!==null)return n;t+=n.offset}return e.nextSibling?c(e.nextSibling,l-t):{element:null,offset:t}}function r(e,l,t){let n=0;for(let s=0;s<e.childNodes.length;s++){let i=e.childNodes[s];if(i.nodeType===3){let o=/\n/g,d;for(;(d=o.exec(i.nodeValue))!==null;)if(n++,n===l)return c(i,d.index+t+1)}else if(i.nodeType===1){let o=r(i,l-n,t);if(o.element!==null)return o;n+=o.offset}}return{element:null,offset:n}}function p(e,l){if(!document.createRange)return;let t=document.getElementById("srcref_"+e);if(!t){t=document.createElement("span"),t.id="srcref_"+e;let n=e,s=document.getElementById(l.replace(/\./g,"_")+"_code");if(!s)return;let i=r(s,n[0],n[4]),o=r(s,n[2],n[5]);if(i.element===null||o.element===null)return;let d=document.createRange();i.element.parentNode?.nodeName==="SPAN"&&i.element!==o.element?d.setStartBefore(i.element.parentNode):d.setStart(i.element,i.offset),o.element.parentNode?.nodeName==="SPAN"&&i.element!==o.element?d.setEndAfter(o.element.parentNode):d.setEnd(o.element,o.offset),d.surroundContents(t)}$(t).stop(!0,!0).effect("highlight",null,1600)}window.Shiny&&window.Shiny.addCustomMessageHandler("showcase-src",function(e){e.srcref&&e.srcfile&&p(e.srcref,e.srcfile)});var a=!1,u=function(e,l){let t=l?m:1,n=e?document.getElementById("showcase-sxs-code"):document.getElementById("showcase-code-inline"),s=e?document.getElementById("showcase-code-inline"):document.getElementById("showcase-sxs-code");if(document.getElementById("showcase-app-metadata")===null){let o=$("#showcase-well");e?o.fadeOut(t):o.fadeIn(t)}if(n===null||s===null){console.warn("Could not find the host elements for the code tabs. This is likely a bug in the showcase app.");return}$(n).hide(),$(s).fadeOut(t,function(){let o=document.getElementById("showcase-code-tabs");if(o===null){console.warn("Could not find the code tabs element. This is likely a bug in the showcase app.");return}if(s.removeChild(o),n.appendChild(o),e?w():document.getElementById("showcase-code-content")?.removeAttribute("style"),$(n).fadeIn(t),!e&&(document.getElementById("showcase-app-container")?.removeAttribute("style"),l)){let f=$(n).offset()?.top;f!==void 0&&$(document.body).animate({scrollTop:f})}let d=document.getElementById("readme-md");d!==null&&(d.parentElement?.removeChild(d),e?(s.appendChild(d),$(s).fadeIn(t)):document.getElementById("showcase-app-metadata")?.appendChild(d)),document.getElementById("showcase-code-position-toggle").innerHTML=e?'<i class="fa fa-level-down"></i> show below':'<i class="fa fa-level-up"></i> show with app'}),e&&$(document.body).animate({scrollTop:0},t),a=e,h(e&&l),$(window).trigger("resize")};function h(e){let t=960,n=1,s=document.getElementById("showcase-app-code").offsetWidth;s/2>960?t=s/2:s*.66>960?t=960:(t=s*.66,n=t/960),$("#showcase-app-container").animate({width:t+"px",zoom:n*100+"%"},e?m:0)}var g=function(){u(!a,!0)},y=function(){document.body.offsetWidth>1350&&u(!0,!1)};function w(){document.getElementById("showcase-code-content").style.height=$(window).height()+"px"}function E(){let e=document.getElementById("showcase-markdown-content");if(e!==null){let l=e.innerText||e.innerHTML,t=window.Showdown.converter;document.getElementById("readme-md").innerHTML=new t().makeHtml(l)}}$(window).resize(function(){a&&(h(!1),w())});window.toggleCodePosition=g;$(window).on("load",y);$(window).on("load",E);window.hljs&&window.hljs.initHighlightingOnLoad();})();
+/*! shiny 1.13.0.9000 | (c) 2012-2026 Posit Software, PBC. | License: MIT + file LICENSE */
+"use strict";(()=>{var m=400;function c(e,s){let t=0;if(e.nodeType===3){let n=e.nodeValue?.replace(/\n/g,"").length??0;if(n>=s)return{element:e,offset:s};t+=n}else if(e.nodeType===1&&e.firstChild){let n=c(e.firstChild,s);if(n.element!==null)return n;t+=n.offset}return e.nextSibling?c(e.nextSibling,s-t):{element:null,offset:t}}function a(e,s,t){let n=0;for(let l=0;l<e.childNodes.length;l++){let i=e.childNodes[l];if(i.nodeType===3){let o=/\n/g,d;for(;(d=o.exec(i.nodeValue))!==null;)if(n++,n===s)return c(i,d.index+t+1)}else if(i.nodeType===1){let o=a(i,s-n,t);if(o.element!==null)return o;n+=o.offset}}return{element:null,offset:n}}function g(e,s){if(!document.createRange)return;let t=document.getElementById("srcref_"+e);if(!t){t=document.createElement("span"),t.id="srcref_"+e;let n=e,l=document.getElementById(s.replace(/\./g,"_")+"_code");if(!l)return;let i=a(l,n[0],n[4]),o=a(l,n[2],n[5]);if(i.element===null||o.element===null)return;let d=document.createRange();i.element.parentNode?.nodeName==="SPAN"&&i.element!==o.element?d.setStartBefore(i.element.parentNode):d.setStart(i.element,i.offset),o.element.parentNode?.nodeName==="SPAN"&&i.element!==o.element?d.setEndAfter(o.element.parentNode):d.setEnd(o.element,o.offset),d.surroundContents(t)}$(t).stop(!0,!0).effect("highlight",null,1600)}window.Shiny&&window.Shiny.addCustomMessageHandler("showcase-src",function(e){e.srcref&&e.srcfile&&g(e.srcref,e.srcfile)});var r=!1,u=function(e,s){let t=s?m:1,n=e?document.getElementById("showcase-sxs-code"):document.getElementById("showcase-code-inline"),l=e?document.getElementById("showcase-code-inline"):document.getElementById("showcase-sxs-code");if(document.getElementById("showcase-app-metadata")===null){let o=$("#showcase-well");e?o.fadeOut(t):o.fadeIn(t)}if(n===null||l===null){console.warn("Could not find the host elements for the code tabs. This is likely a bug in the showcase app.");return}$(n).hide(),$(l).fadeOut(t,function(){let o=document.getElementById("showcase-code-tabs");if(o===null){console.warn("Could not find the code tabs element. This is likely a bug in the showcase app.");return}if(l.removeChild(o),n.appendChild(o),e?p():document.getElementById("showcase-code-content")?.removeAttribute("style"),$(n).fadeIn(t),!e&&(document.getElementById("showcase-app-container")?.removeAttribute("style"),s)){let f=$(n).offset()?.top;f!==void 0&&$(document.body).animate({scrollTop:f})}let d=document.getElementById("readme-md");d!==null&&(d.parentElement?.removeChild(d),e?(l.appendChild(d),$(l).fadeIn(t)):document.getElementById("showcase-app-metadata")?.appendChild(d)),document.getElementById("showcase-code-position-toggle").innerHTML=e?'<i class="fa fa-level-down"></i> show below':'<i class="fa fa-level-up"></i> show with app'}),e&&$(document.body).animate({scrollTop:0},t),r=e,h(e&&s),$(window).trigger("resize")};function h(e){let t=960,n=1,l=document.getElementById("showcase-app-code").offsetWidth;l/2>960?t=l/2:l*.66>960?t=960:(t=l*.66,n=t/960),$("#showcase-app-container").animate({width:t+"px",zoom:n*100+"%"},e?m:0)}var w=function(){u(!r,!0)},y=function(){document.body.offsetWidth>1350&&u(!0,!1)};function p(){document.getElementById("showcase-code-content").style.height=$(window).height()+"px"}function E(){let e=document.getElementById("showcase-markdown-content");if(e!==null){let s=document.getElementById("readme-md");if(s!==null){let t=e.content.cloneNode(!0);s.appendChild(t)}}}$(window).resize(function(){r&&(h(!1),p())});window.toggleCodePosition=w;$(window).on("load",y);$(window).on("load",E);window.hljs&&window.hljs.initHighlightingOnLoad();})();
 //# sourceMappingURL=shiny-showcase.js.map

inst/www/shared/shiny-testmode.js

@@ -1,3 +1,3 @@
-/*! shiny 1.11.1.9000 | (c) 2012-2025 Posit Software, PBC. | License: GPL-3 | file LICENSE */
+/*! shiny 1.13.0.9000 | (c) 2012-2026 Posit Software, PBC. | License: MIT + file LICENSE */
 "use strict";(()=>{var t=eval;window.addEventListener("message",function(a){let e=a.data;e.code&&t(e.code)});})();
 //# sourceMappingURL=shiny-testmode.js.map

inst/www/shared/shiny.js

@@ -1,4 +1,4 @@
-/*! shiny 1.11.1.9000 | (c) 2012-2025 Posit Software, PBC. | License: GPL-3 | file LICENSE */
+/*! shiny 1.13.0.9000 | (c) 2012-2026 Posit Software, PBC. | License: MIT + file LICENSE */
 "use strict";
 (() => {
   var __create = Object.create;
@@ -7206,7 +7206,7 @@ ${duplicateIdMsg}`;
   // srcts/src/shiny/index.ts
   var ShinyClass = class {
     constructor() {
-      this.version = "1.11.1.9000";
+      this.version = "1.13.0.9000";
       const { inputBindings, fileInputBinding: fileInputBinding2 } = initInputBindings();
       const { outputBindings } = initOutputBindings();
       setFileInputBinding(fileInputBinding2);

inst/www/shared/shiny_scss/shiny.scss

@@ -463,10 +463,11 @@ textarea.textarea-autoresize.form-control {
   }
 }
 
-// Add spacing between icon and label for actionButton()
-.action-button:not(.action-link) {
+// Add spacing between icon and label for action buttons and links (#4348)
+// Using margin instead of padding so the underline doesn't extend into the gap for links
+.action-button {
   .action-icon + .action-label {
-    padding-left: 0.5ch;
+    margin-left: 1ch;
   }
 }
 

inst/www/shared/showdown/license.txt

@@ -1,34 +0,0 @@
-Copyright (c) 2007, John Fraser  
-<http://www.attacklab.net/>  
-All rights reserved.
-
-Original Markdown copyright (c) 2004, John Gruber  
-<http://daringfireball.net/>  
-All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-* Redistributions of source code must retain the above copyright notice,
-  this list of conditions and the following disclaimer.
-
-* Redistributions in binary form must reproduce the above copyright
-  notice, this list of conditions and the following disclaimer in the
-  documentation and/or other materials provided with the distribution.
-
-* Neither the name "Markdown" nor the names of its contributors may
-  be used to endorse or promote products derived from this software
-  without specific prior written permission.
-
-This software is provided by the copyright holders and contributors "as
-is" and any express or implied warranties, including, but not limited
-to, the implied warranties of merchantability and fitness for a
-particular purpose are disclaimed. In no event shall the copyright owner
-or contributors be liable for any direct, indirect, incidental, special,
-exemplary, or consequential damages (including, but not limited to,
-procurement of substitute goods or services; loss of use, data, or
-profits; or business interruption) however caused and on any theory of
-liability, whether in contract, strict liability, or tort (including
-negligence or otherwise) arising in any way out of the use of this
-software, even if advised of the possibility of such damage.

man/ExtendedTask.Rd

@@ -45,6 +45,29 @@ is, a function that quickly returns a promise) and allows even that very
 session to immediately unblock and carry on with other user interactions.
 }
 
+\section{OpenTelemetry Integration}{
+
+
+When an \code{ExtendedTask} is created, if OpenTelemetry tracing is enabled for
+\code{"reactivity"} (see \code{\link[=withOtelCollect]{withOtelCollect()}}), the \code{ExtendedTask} will record
+spans for each invocation of the task. The tracing level at \code{invoke()} time
+does not affect whether spans are recorded; only the tracing level when
+calling \code{ExtendedTask$new()} matters.
+
+The OTel span will be named based on the label created from the variable the
+\code{ExtendedTask} is assigned to. If no label can be determined, the span will
+be named \verb{<anonymous>}. Similar to other Shiny OpenTelemetry spans, the span
+will also include source reference attributes and session ID attributes.
+
+\if{html}{\out{<div class="sourceCode r">}}\preformatted{withOtelCollect("all", \{
+  my_task <- ExtendedTask$new(function(...) \{ ... \})
+\})
+
+# Span recorded for this invocation: ExtendedTask my_task
+my_task$invoke(...)
+}\if{html}{\out{</div>}}
+}
+
 \examples{
 \dontshow{if (rlang::is_interactive() && rlang::is_installed("mirai")) withAutoprint(\{ # examplesIf}
 library(shiny)

man/runApp.Rd

@@ -60,6 +60,10 @@ in its \code{DESCRIPTION} file, if any.}
 only used for recording or running automated tests. Defaults to the
 \code{shiny.testmode} option, or FALSE if the option is not set.}
 }
+\value{
+The value passed to \code{\link[=stopApp]{stopApp()}}, or throws an error if the app was
+stopped with an error.
+}
 \description{
 Runs a Shiny application. This function normally does not return; interrupt R
 to stop the application (usually by pressing Ctrl+C or Esc).
@@ -109,3 +113,7 @@ if (interactive()) {
   runApp(app)
 }
 }
+\seealso{
+\code{\link[=startApp]{startApp()}} for non-blocking mode, \code{\link[=stopApp]{stopApp()}} to stop a running
+app.
+}

man/shiny-package.Rd

@@ -59,8 +59,6 @@ Other contributors:
   \item Denis Ineshin (ion.rangeSlider library) [contributor, copyright holder]
   \item Sami Samhuri (Javascript strftime library) [contributor, copyright holder]
   \item  SpryMedia Limited (DataTables library) [contributor, copyright holder]
-  \item John Fraser (showdown.js library) [contributor, copyright holder]
-  \item John Gruber (showdown.js library) [contributor, copyright holder]
   \item Ivan Sagalaev (highlight.js library) [contributor, copyright holder]
   \item R Core Team (tar implementation from R) [contributor, copyright holder]
 }

man/shinyOptions.Rd

@@ -130,6 +130,32 @@ ragg package. See \code{\link[=plotPNG]{plotPNG()}} for more information.}
 Cairo package. See \code{\link[=plotPNG]{plotPNG()}} for more information.}
 \item{shiny.devmode (defaults to \code{NULL})}{Option to enable Shiny Developer Mode. When set,
 different default \code{getOption(key)} values will be returned. See \code{\link[=devmode]{devmode()}} for more details.}
+\item{shiny.otel.collect (defaults to \code{Sys.getenv("SHINY_OTEL_COLLECT", "all")})}{Determines how Shiny will interact with OpenTelemetry.
+
+Supported values:
+\itemize{
+\item \code{"none"} - No Shiny OpenTelemetry tracing.
+\item \code{"session"} - Adds session start/end spans.
+\item \code{"reactive_update"} - Spans for any synchronous/asynchronous reactive
+update. (Includes \code{"session"} features).
+\item \code{"reactivity"} - Spans for all reactive expressions and logs for setting
+reactive vals and values. (Includes \code{"reactive_update"} features). This
+option must be set when creating any reactive objects that should record
+OpenTelemetry spans / logs. See \code{\link[=withOtelCollect]{withOtelCollect()}} and
+\code{\link[=localOtelCollect]{localOtelCollect()}} for ways to set this option locally when creating
+your reactive expressions.
+\item \code{"all"} - All Shiny OpenTelemetry tracing. Currently equivalent to
+\code{"reactivity"}.
+}
+
+This option is useful for debugging and profiling while in production. This
+option will only be useful if the \code{otelsdk} package is installed and
+\code{otel::is_tracing_enabled()} returns \code{TRUE}. Please have any OpenTelemetry
+environment variables set before loading any relevant R packages.
+
+To set this option locally within a specific part of your Shiny
+application, see \code{\link[=withOtelCollect]{withOtelCollect()}} and \code{\link[=localOtelCollect]{localOtelCollect()}}.}
+\item{shiny.otel.sanitize.errors (defaults to \code{TRUE})}{If \code{TRUE}, fatal and unhandled errors will be sanitized before being sent to the OpenTelemetry backend. The default value of \code{TRUE} is set to avoid potentially sending sensitive information to the OpenTelemetry backend. If you want the full error message and stack trace to be sent to the OpenTelemetry backend, set this option to \code{FALSE} or use \code{safeError(e)}.}
 }
 }
 

man/startApp.Rd

@@ -0,0 +1,91 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/runapp.R
+\name{startApp}
+\alias{startApp}
+\title{Start Shiny Application (Non-Blocking)}
+\usage{
+startApp(
+  appDir = getwd(),
+  port = getOption("shiny.port"),
+  launch.browser = getOption("shiny.launch.browser", interactive()),
+  host = getOption("shiny.host", "127.0.0.1"),
+  workerId = "",
+  quiet = FALSE,
+  display.mode = c("auto", "normal", "showcase"),
+  test.mode = getOption("shiny.testmode", FALSE)
+)
+}
+\arguments{
+\item{appDir}{The application to run. Should be one of the following:
+\itemize{
+\item A directory containing \code{server.R}, plus, either \code{ui.R} or
+a \code{www} directory that contains the file \code{index.html}.
+\item A directory containing \code{app.R}.
+\item An \code{.R} file containing a Shiny application, ending with an
+expression that produces a Shiny app object.
+\item A list with \code{ui} and \code{server} components.
+\item A Shiny app object created by \code{\link[=shinyApp]{shinyApp()}}.
+}}
+
+\item{port}{The TCP port that the application should listen on. If the
+\code{port} is not specified, and the \code{shiny.port} option is set (with
+\code{options(shiny.port = XX)}), then that port will be used. Otherwise,
+use a random port between 3000:8000, excluding ports that are blocked
+by Google Chrome for being considered unsafe: 3659, 4045, 5060,
+5061, 6000, 6566, 6665:6669 and 6697. Up to twenty random
+ports will be tried.}
+
+\item{launch.browser}{If true, the system's default web browser will be
+launched automatically after the app is started. Defaults to true in
+interactive sessions only. The value of this parameter can also be a
+function to call with the application's URL.}
+
+\item{host}{The IPv4 address that the application should listen on. Defaults
+to the \code{shiny.host} option, if set, or \code{"127.0.0.1"} if not. See
+Details.}
+
+\item{workerId}{Can generally be ignored. Exists to help some editions of
+Shiny Server Pro route requests to the correct process.}
+
+\item{quiet}{Should Shiny status messages be shown? Defaults to FALSE.}
+
+\item{display.mode}{The mode in which to display the application. If set to
+the value \code{"showcase"}, shows application code and metadata from a
+\code{DESCRIPTION} file in the application directory alongside the
+application. If set to \code{"normal"}, displays the application normally.
+Defaults to \code{"auto"}, which displays the application in the mode given
+in its \code{DESCRIPTION} file, if any.}
+
+\item{test.mode}{Should the application be launched in test mode? This is
+only used for recording or running automated tests. Defaults to the
+\code{shiny.testmode} option, or FALSE if the option is not set.}
+}
+\value{
+A \code{ShinyAppHandle} object with methods \code{stop()}, \code{status()},
+\code{url()}, and \code{result()}. The \code{status()} method returns \code{"running"},
+\code{"success"}, or \code{"error"}. The \code{result()} method throws an error if called
+while running, or re-throws the error if the app stopped with an error.
+}
+\description{
+Starts a Shiny application in non-blocking mode, returning a
+\code{ShinyAppHandle} immediately while the app runs in the background.
+The \code{later} event loop services the app, so the R console remains
+available for interaction.
+}
+\examples{
+\dontrun{
+# Start app in the background
+handle <- startApp("myapp")
+
+# Check status
+handle$status()
+handle$url()
+
+# Stop the app
+handle$stop()
+}
+
+}
+\seealso{
+\code{\link[=runApp]{runApp()}} for blocking mode, \code{\link[=stopApp]{stopApp()}} to stop a running app.
+}

man/stopApp.Rd

@@ -12,5 +12,7 @@ stopApp(returnValue = invisible())
 }
 \description{
 Stops the currently running Shiny app, returning control to the caller of
-\code{\link[=runApp]{runApp()}}.
+\code{\link[=runApp]{runApp()}}. Despite the similar names, \code{stopApp()} is not the
+counterpart of \code{\link[=startApp]{startApp()}} — it is the counterpart of \code{\link[=runApp]{runApp()}},
+controlling its return value via \code{returnValue}.
 }

man/withOtelCollect.Rd

@@ -0,0 +1,107 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/otel-with.R
+\name{withOtelCollect}
+\alias{withOtelCollect}
+\alias{localOtelCollect}
+\title{Temporarily set OpenTelemetry (OTel) collection level}
+\usage{
+withOtelCollect(collect, expr)
+
+localOtelCollect(collect, envir = parent.frame())
+}
+\arguments{
+\item{collect}{Character string specifying the OpenTelemetry collection level.
+Must be one of the following:
+
+\if{html}{\out{<div class="sourceCode">}}\preformatted{* `"none"` - No telemetry data collected
+* `"reactivity"` - Collect reactive execution spans (includes session and
+  reactive update events)
+* `"all"` - All available telemetry (currently equivalent to `"reactivity"`)
+}\if{html}{\out{</div>}}}
+
+\item{expr}{Expression to evaluate with the specified collection level
+(for \code{withOtelCollect()}).}
+
+\item{envir}{Environment where the collection level should be set
+(for \code{localOtelCollect()}). Defaults to the parent frame.}
+}
+\value{
+\itemize{
+\item \code{withOtelCollect()} returns the value of \code{expr}.
+\item \code{localOtelCollect()} is called for its side effect and returns the previous
+\code{collect} value invisibly.
+}
+}
+\description{
+Control Shiny's OTel collection level for particular reactive expression(s).
+
+\code{withOtelCollect()} sets the OpenTelemetry collection level for
+the duration of evaluating \code{expr}. \code{localOtelCollect()} sets the collection
+level for the remainder of the current function scope.
+}
+\details{
+Note that \code{"session"} and \code{"reactive_update"} levels are not permitted as
+these are runtime-specific levels that should only be set permanently via
+\code{options(shiny.otel.collect = ...)} or the \code{SHINY_OTEL_COLLECT} environment
+variable, not temporarily during reactive expression creation.
+}
+\section{Best practice}{
+
+
+Best practice is to set the collection level for code that \emph{creates} reactive
+expressions, not code that \emph{runs} them. For instance:
+
+\if{html}{\out{<div class="sourceCode r">}}\preformatted{# Disable telemetry for a reactive expression
+withOtelCollect("none", \{
+  my_reactive <- reactive(\{ ... \})
+\})
+
+# Disable telemetry for a render function
+withOtelCollect("none", \{
+  output$my_plot <- renderPlot(\{ ... \})
+\})
+
+#' # Disable telemetry for an observer
+withOtelCollect("none", \{
+  observe(\{ ... \}))
+\})
+
+# Disable telemetry for an entire module
+withOtelCollect("none", \{
+  my_result <- my_module("my_id")
+\})
+# Use `my_result` as normal here
+}\if{html}{\out{</div>}}
+
+NOTE: It's not recommended to pipe existing reactive objects into
+\code{withOtelCollect()} since they won't inherit their intended OTel settings,
+leading to confusion.
+}
+
+\examples{
+\dontrun{
+# Temporarily disable telemetry collection
+withOtelCollect("none", {
+  # Code here won't generate telemetry
+  reactive({ input$x + 1 })
+})
+
+# Collect reactivity telemetry but not other events
+withOtelCollect("reactivity", {
+  # Reactive execution will be traced
+  observe({ print(input$x) })
+})
+
+# Use local variant in a function
+my_function <- function() {
+  localOtelCollect("none")
+  # Rest of function executes without telemetry
+  reactive({ input$y * 2 })
+}
+}
+
+}
+\seealso{
+See the \code{shiny.otel.collect} option within \code{\link{shinyOptions}}. Setting
+this value will globally control OpenTelemetry collection levels.
+}

package-lock.json

@@ -1,13 +1,13 @@
 {
-  "name": "@types/rstudio-shiny",
-  "version": "1.11.1-alpha.9000",
+  "name": "@posit/shiny",
+  "version": "1.12.1-alpha.9000",
   "lockfileVersion": 3,
   "requires": true,
   "packages": {
     "": {
-      "name": "@types/rstudio-shiny",
-      "version": "1.11.1-alpha.9000",
-      "license": "GPL-3.0-only",
+      "name": "@posit/shiny",
+      "version": "1.12.1-alpha.9000",
+      "license": "MIT",
       "dependencies": {
         "@types/bootstrap": "5.2.x",
         "@types/bootstrap-datepicker": "1.10.0",
@@ -23,7 +23,6 @@
         "@types/jqueryui": "1.12.24",
         "@types/lodash": "4.x",
         "@types/node": "18.x",
-        "@types/showdown": "1.x",
         "@typescript-eslint/eslint-plugin": "8.x",
         "@typescript-eslint/parser": "8.x",
         "autoprefixer": "10.x",
@@ -2421,13 +2420,6 @@
       "integrity": "sha512-ABnSEXM1MyO9ZZXl2yXLqzHcENuGh6kyXisnq87OQCubbJrMaargMYV/NPVmJA3lJGnDM6hzc1ce7yQM/RwI5g==",
       "license": "MIT"
     },
-    "node_modules/@types/showdown": {
-      "version": "1.9.4",
-      "resolved": "https://registry.npmjs.org/@types/showdown/-/showdown-1.9.4.tgz",
-      "integrity": "sha512-50ehC3IAijfkvoNqmQ+VL73S7orOxmAK8ljQAFBv8o7G66lAZyxQj1L3BAv2dD86myLXI+sgKP1kcxAaxW356w==",
-      "dev": true,
-      "license": "MIT"
-    },
     "node_modules/@types/sizzle": {
       "version": "2.3.9",
       "resolved": "https://registry.npmjs.org/@types/sizzle/-/sizzle-2.3.9.tgz",

package.json

@@ -5,8 +5,8 @@
     "url": "git+https://github.com/rstudio/shiny.git"
   },
   "name": "@posit/shiny",
-  "version": "1.11.1-alpha.9000",
-  "license": "GPL-3.0-only",
+  "version": "1.13.0-alpha.9000",
+  "license": "MIT",
   "main": "",
   "browser": "",
   "types": "srcts/types/extras/globalShiny.d.ts",
@@ -33,7 +33,6 @@
     "@types/jqueryui": "1.12.24",
     "@types/lodash": "4.x",
     "@types/node": "18.x",
-    "@types/showdown": "1.x",
     "@typescript-eslint/eslint-plugin": "8.x",
     "@typescript-eslint/parser": "8.x",
     "autoprefixer": "10.x",
@@ -70,7 +69,7 @@
     "coverage_detailed": "npx --yes type-check --detail",
     "coverage": "type-coverage -p tsconfig.json --at-least 90",
     "circular": "npx --yes dpdm --transform ./srcts/src/index.ts",
-    "prepack": "cp README.md README-orig.md && cp npm-README.md README.md",
+    "prepack": "cp README.md README-orig.md && cp README-npm.md README.md",
     "postpack": "test -f README-orig.md && cp README-orig.md README.md && rm README-orig.md"
   },
   "prettier": {

revdep/README.md

@@ -1,29 +1,45 @@
 # Revdeps
 
-## Failed to check (12)
+## Failed to check (38)
 
 |package              |version |error |warning |note |
 |:--------------------|:-------|:-----|:-------|:----|
+|ADAMgui              |?       |      |        |     |
+|AssumpSure           |?       |      |        |     |
+|boinet               |1.5.0   |1     |        |     |
+|brms                 |?       |      |        |     |
+|cheem                |?       |      |        |     |
+|ctsem                |3.10.4  |1     |        |1    |
+|detourr              |?       |      |        |     |
 |EMMAgeo              |?       |      |        |     |
+|FactEff              |?       |      |        |     |
 |FAfA                 |?       |      |        |     |
 |fio                  |0.1.6   |1     |        |     |
+|fitteR               |?       |      |        |     |
+|FossilSimShiny       |?       |      |        |     |
 |GDINA                |?       |      |        |     |
+|ggsem                |?       |      |        |     |
+|grandR               |?       |      |        |     |
 |GSVA                 |?       |      |        |     |
-|lavaan.shiny         |1.2     |1     |        |     |
+|hbsaems              |?       |      |        |     |
+|langevitour          |?       |      |        |     |
+|lavaan.shiny         |?       |      |        |     |
+|lcsm                 |?       |      |        |     |
+|linkspotter          |?       |      |        |     |
 |loon.shiny           |?       |      |        |     |
+|MOsemiind            |0.1.0   |1     |        |     |
+|MVN                  |?       |      |        |     |
+|pandemonium          |?       |      |        |     |
+|polarisR             |?       |      |        |     |
 |Prostar              |?       |      |        |     |
-|rstanarm             |2.32.1  |1     |        |     |
-|sphereML             |0.1.1   |1     |        |     |
+|RCTrep               |1.2.0   |1     |        |     |
+|recmap               |?       |      |        |     |
+|rstanarm             |2.32.2  |1     |        |     |
+|semdrw               |?       |      |        |     |
+|shotGroups           |?       |      |        |     |
+|sphereML             |?       |      |        |     |
+|spinifex             |?       |      |        |     |
 |StatTeacherAssistant |?       |      |        |     |
-|TestAnaAPP           |1.1.2   |1     |        |     |
-
-## New problems (5)
-
-|package       |version |error  |warning |note   |
-|:-------------|:-------|:------|:-------|:------|
-|[omicsTools](problems.md#omicstools)|1.0.5   |__+1__ |        |       |
-|[PopED](problems.md#poped)|0.7.0   |       |        |__+1__ |
-|[shinyGovstyle](problems.md#shinygovstyle)|0.1.0   |__+1__ |        |       |
-|[ShinyLink](problems.md#shinylink)|0.2.2   |__+1__ |        |       |
-|[shinySbm](problems.md#shinysbm)|0.1.5   |__+1__ |        |1      |
+|SurprisalAnalysis    |?       |      |        |     |
+|TestAnaAPP           |?       |      |        |     |
 

revdep/cran.md

@@ -1,37 +1,42 @@
 ## revdepcheck results
 
-We checked 1349 reverse dependencies (1345 from CRAN + 4 from Bioconductor), comparing R CMD check results across CRAN and dev versions of this package.
+We checked 1383 reverse dependencies (1376 from CRAN + 7 from Bioconductor), comparing R CMD check results across CRAN and dev versions of this package.
 
- * We saw 5 new problems
- * We failed to check 8 packages
+ * We saw 0 new problems
+ * We failed to check 31 packages
 
 Issues with CRAN packages are summarised below.
 
-### New problems
-(This reports the first line of each new failure)
-
-* omicsTools
-  checking tests ... ERROR
-
-* PopED
-  checking installed package size ... NOTE
-
-* shinyGovstyle
-  checking tests ... ERROR
-
-* ShinyLink
-  checking tests ... ERROR
-
-* shinySbm
-  checking tests ... ERROR
-
 ### Failed to check
 
-* FAfA         (NA)
-* fio          (NA)
-* GDINA        (NA)
-* lavaan.shiny (NA)
-* loon.shiny   (NA)
-* rstanarm     (NA)
-* sphereML     (NA)
-* TestAnaAPP   (NA)
+* AssumpSure        (NA)
+* boinet            (NA)
+* brms              (NA)
+* cheem             (NA)
+* ctsem             (NA)
+* detourr           (NA)
+* FAfA              (NA)
+* fio               (NA)
+* fitteR            (NA)
+* FossilSimShiny    (NA)
+* GDINA             (NA)
+* ggsem             (NA)
+* grandR            (NA)
+* hbsaems           (NA)
+* langevitour       (NA)
+* lavaan.shiny      (NA)
+* lcsm              (NA)
+* linkspotter       (NA)
+* loon.shiny        (NA)
+* MOsemiind         (NA)
+* MVN               (NA)
+* pandemonium       (NA)
+* polarisR          (NA)
+* RCTrep            (NA)
+* rstanarm          (NA)
+* semdrw            (NA)
+* shotGroups        (NA)
+* sphereML          (NA)
+* spinifex          (NA)
+* SurprisalAnalysis (NA)
+* TestAnaAPP        (NA)

revdep/problems.md

@@ -1,212 +1 @@
-# omicsTools
-
-<details>
-
-* Version: 1.0.5
-* GitHub: https://github.com/YaoxiangLi/omicsTools
-* Source code: https://github.com/cran/omicsTools
-* Date/Publication: 2023-07-03 16:20:02 UTC
-* Number of recursive dependencies: 87
-
-Run `revdepcheck::cloud_details(, "omicsTools")` for more info
-
-</details>
-
-## Newly broken
-
-*   checking tests ... ERROR
-    ```
-      Running ‘spelling.R’
-      Running ‘testthat.R’
-    Running the tests in ‘tests/testthat.R’ failed.
-    Complete output:
-      > # This file is part of the standard setup for testthat.
-      > # It is recommended that you do not modify it.
-      > #
-      > # Where should you do additional test configuration?
-      > # Learn more about the roles of various files in:
-      > # * https://r-pkgs.org/tests.html
-    ...
-      
-      lines(actual) vs lines(expected)
-      - "<button id=\"go_filter\" type=\"button\" class=\"btn btn-default action-button\" style=\"display: none;\">"
-      - "  <span class=\"action-label\">go</span>"
-      - "</button>"
-      + "<button id=\"go_filter\" type=\"button\" class=\"btn btn-default action-button\" style=\"display: none;\">go</button>"
-      
-      [ FAIL 2 | WARN 0 | SKIP 1 | PASS 94 ]
-      Error: Test failures
-      Execution halted
-    ```
-
-# PopED
-
-<details>
-
-* Version: 0.7.0
-* GitHub: https://github.com/andrewhooker/PopED
-* Source code: https://github.com/cran/PopED
-* Date/Publication: 2024-10-07 19:30:02 UTC
-* Number of recursive dependencies: 139
-
-Run `revdepcheck::cloud_details(, "PopED")` for more info
-
-</details>
-
-## Newly broken
-
-*   checking installed package size ... NOTE
-    ```
-      installed size is  5.5Mb
-      sub-directories of 1Mb or more:
-        R      1.5Mb
-        doc    1.4Mb
-        test   1.1Mb
-    ```
-
-# shinyGovstyle
-
-<details>
-
-* Version: 0.1.0
-* GitHub: https://github.com/moj-analytical-services/shinyGovstyle
-* Source code: https://github.com/cran/shinyGovstyle
-* Date/Publication: 2024-09-12 14:40:02 UTC
-* Number of recursive dependencies: 48
-
-Run `revdepcheck::cloud_details(, "shinyGovstyle")` for more info
-
-</details>
-
-## Newly broken
-
-*   checking tests ... ERROR
-    ```
-      Running ‘testthat.R’
-    Running the tests in ‘tests/testthat.R’ failed.
-    Complete output:
-      > library(testthat)
-      > library(shinyGovstyle)
-      > 
-      > test_check("shinyGovstyle")
-      [ FAIL 1 | WARN 0 | SKIP 0 | PASS 125 ]
-      
-      ══ Failed tests ════════════════════════════════════════════════════════════════
-      ── Failure ('test-backlink_Input.R:4:3'): backlink works ───────────────────────
-      backlink_check$children[[1]][[2]] not identical to "Back".
-      target is NULL, current is character
-      
-      [ FAIL 1 | WARN 0 | SKIP 0 | PASS 125 ]
-      Error: Test failures
-      Execution halted
-    ```
-
-# ShinyLink
-
-<details>
-
-* Version: 0.2.2
-* GitHub: NA
-* Source code: https://github.com/cran/ShinyLink
-* Date/Publication: 2023-01-18 11:40:05 UTC
-* Number of recursive dependencies: 129
-
-Run `revdepcheck::cloud_details(, "ShinyLink")` for more info
-
-</details>
-
-## Newly broken
-
-*   checking tests ... ERROR
-    ```
-      Running ‘spelling.R’
-      Running ‘testthat.R’
-    Running the tests in ‘tests/testthat.R’ failed.
-    Complete output:
-      > # This file is part of the standard setup for testthat.
-      > # It is recommended that you do not modify it.
-      > #
-      > # Where should you do additional test configuration?
-      > # Learn more about the roles of various files in:
-      > # * https://r-pkgs.org/tests.html
-    ...
-      
-      lines(actual) vs lines(expected)
-      - "<button id=\"go_filter\" type=\"button\" class=\"btn btn-default action-button\" style=\"display: none;\">"
-      - "  <span class=\"action-label\">go</span>"
-      - "</button>"
-      + "<button id=\"go_filter\" type=\"button\" class=\"btn btn-default action-button\" style=\"display: none;\">go</button>"
-      
-      [ FAIL 2 | WARN 0 | SKIP 1 | PASS 145 ]
-      Error: Test failures
-      Execution halted
-    ```
-
-# shinySbm
-
-<details>
-
-* Version: 0.1.5
-* GitHub: https://github.com/Jo-Theo/shinySbm
-* Source code: https://github.com/cran/shinySbm
-* Date/Publication: 2023-09-07 21:50:02 UTC
-* Number of recursive dependencies: 134
-
-Run `revdepcheck::cloud_details(, "shinySbm")` for more info
-
-</details>
-
-## Newly broken
-
-*   checking tests ... ERROR
-    ```
-      Running ‘spelling.R’
-      Running ‘testthat.R’
-    Running the tests in ‘tests/testthat.R’ failed.
-    Complete output:
-      > # This file is part of the standard setup for testthat.
-      > # It is recommended that you do not modify it.
-      > #
-      > # Where should you do additional test configuration?
-      > # Learn more about the roles of various files in:
-      > # * https://r-pkgs.org/tests.html
-    ...
-      
-      lines(actual) vs lines(expected)
-      - "<button id=\"go_filter\" type=\"button\" class=\"btn btn-default action-button\" style=\"display: none;\">"
-      - "  <span class=\"action-label\">go</span>"
-      - "</button>"
-      + "<button id=\"go_filter\" type=\"button\" class=\"btn btn-default action-button\" style=\"display: none;\">go</button>"
-      
-      [ FAIL 2 | WARN 0 | SKIP 1 | PASS 141 ]
-      Error: Test failures
-      Execution halted
-    ```
-
-## In both
-
-*   checking Rd files ... NOTE
-    ```
-    checkRd: (-1) FungusTreeNetwork.Rd:15-21: Lost braces in \itemize; meant \describe ?
-    checkRd: (-1) FungusTreeNetwork.Rd:22-28: Lost braces in \itemize; meant \describe ?
-    checkRd: (-1) FungusTreeNetwork.Rd:33-34: Lost braces in \itemize; meant \describe ?
-    checkRd: (-1) FungusTreeNetwork.Rd:33: Lost braces; missing escapes or markup?
-        33 |      \item{tree_tree}{Results of \code{estimateSimpleSBM} for {sbm}
-           |                                                               ^
-    checkRd: (-1) FungusTreeNetwork.Rd:35-36: Lost braces in \itemize; meant \describe ?
-    checkRd: (-1) FungusTreeNetwork.Rd:35: Lost braces; missing escapes or markup?
-        35 |      \item{fungus_tree}{Results of \code{estimateBipartiteSBM} for {sbm}
-           |                                                                    ^
-    ...
-    checkRd: (-1) visSbm.default.Rd:25: Lost braces in \itemize; meant \describe ?
-    checkRd: (-1) visSbm.default.Rd:26: Lost braces in \itemize; meant \describe ?
-    checkRd: (-1) visSbm.default.Rd:43-44: Lost braces in \itemize; meant \describe ?
-    checkRd: (-1) visSbm.default.Rd:45: Lost braces in \itemize; meant \describe ?
-    checkRd: (-1) visSbm.default.Rd:46: Lost braces in \itemize; meant \describe ?
-    checkRd: (-1) visSbm.default.Rd:47: Lost braces in \itemize; meant \describe ?
-    checkRd: (-1) visSbm.default.Rd:48: Lost braces in \itemize; meant \describe ?
-    checkRd: (-1) visSbm.default.Rd:49: Lost braces in \itemize; meant \describe ?
-    checkRd: (-1) visSbm.default.Rd:50: Lost braces in \itemize; meant \describe ?
-    checkRd: (-1) visSbm.default.Rd:51: Lost braces in \itemize; meant \describe ?
-    ```
-
+*Wow, no problems at all. :)*

srcts/extras/shiny-showcase.ts

@@ -299,20 +299,18 @@ function setCodeHeightFromDocHeight() {
     $(window).height() + "px";
 }
 
-// if there's a block of markdown content, render it to HTML
-function renderMarkdown() {
-  const mdContent = document.getElementById("showcase-markdown-content");
+// Move server-rendered markdown from template into the readme container
+function insertMarkdownContent() {
+  const template = document.getElementById(
+    "showcase-markdown-content",
+  ) as HTMLTemplateElement | null;
 
-  if (mdContent !== null) {
-    // IE8 puts the content of <script> tags into innerHTML but
-    // not innerText
-    const content = mdContent.innerText || mdContent.innerHTML;
-
-    const showdownConverter = (window as any).Showdown
-      .converter as showdown.ConverterStatic;
-
-    document.getElementById("readme-md")!.innerHTML =
-      new showdownConverter().makeHtml(content);
+  if (template !== null) {
+    const readmeContainer = document.getElementById("readme-md");
+    if (readmeContainer !== null) {
+      const content = template.content.cloneNode(true);
+      readmeContainer.appendChild(content);
+    }
   }
 }
 
@@ -331,7 +329,7 @@ declare global {
 window.toggleCodePosition = toggleCodePosition;
 
 $(window).on("load", setInitialCodePosition);
-$(window).on("load", renderMarkdown);
+$(window).on("load", insertMarkdownContent);
 
 if (window.hljs) window.hljs.initHighlightingOnLoad();
 

tests/testthat/_snaps/actionButton.md

@@ -3,19 +3,26 @@
     Code
       actionButton("foo", "Click me")
     Output
-      <button id="foo" type="button" class="btn btn-default action-button">
-        <span class="action-label">Click me</span>
-      </button>
+      <button id="foo" type="button" class="btn btn-default action-button"><span class="action-label">Click me</span></button>
 
 ---
 
     Code
       actionButton("foo", "Click me", icon = icon("star"))
     Output
-      <button id="foo" type="button" class="btn btn-default action-button">
-        <span class="action-icon">
-          <i class="far fa-star" role="presentation" aria-label="star icon"></i>
-        </span>
-        <span class="action-label">Click me</span>
-      </button>
+      <button id="foo" type="button" class="btn btn-default action-button"><span class="action-icon"><i class="far fa-star" role="presentation" aria-label="star icon"></i></span><span class="action-label">Click me</span></button>
+
+# actionLink uses .noWS to prevent underline rendering issues
+
+    Code
+      actionLink("foo", "Click me")
+    Output
+      <a id="foo" href="#" class="action-button action-link"><span class="action-label">Click me</span></a>
+
+---
+
+    Code
+      actionLink("foo", "Click me", icon = icon("star"))
+    Output
+      <a id="foo" href="#" class="action-button action-link"><span class="action-icon"><i class="far fa-star" role="presentation" aria-label="star icon"></i></span><span class="action-label">Click me</span></a>
 

tests/testthat/_snaps/reactivity.md

@@ -0,0 +1,6 @@
+# reactiveValues() has useful print method
+
+    <ReactiveValues> 
+      Values:    x, y, z 
+      Readonly:  FALSE 
+

tests/testthat/_snaps/stacks-deep.md

@@ -144,10 +144,10 @@
           : doTryCatch
           : tryCatchOne
           : tryCatchList
-          : doTryCatch
-          : tryCatchOne
-          : tryCatchList
           : tryCatch
+          : doWithOneRestart
+          : withOneRestart
+          : withRestarts
           : test_code
           : test_that
           : eval [test-stacks-deep.R#XXX]
@@ -156,10 +156,10 @@
           : doTryCatch
           : tryCatchOne
           : tryCatchList
-          : doTryCatch
-          : tryCatchOne
-          : tryCatchList
           : tryCatch
+          : doWithOneRestart
+          : withOneRestart
+          : withRestarts
           : test_code
           : source_file
           : FUN
@@ -212,10 +212,10 @@
           : doTryCatch
           : tryCatchOne
           : tryCatchList
-          : doTryCatch
-          : tryCatchOne
-          : tryCatchList
           : tryCatch
+          : doWithOneRestart
+          : withOneRestart
+          : withRestarts
           : test_code
           : test_that
           : eval [test-stacks-deep.R#XXX]
@@ -224,10 +224,10 @@
           : doTryCatch
           : tryCatchOne
           : tryCatchList
-          : doTryCatch
-          : tryCatchOne
-          : tryCatchList
           : tryCatch
+          : doWithOneRestart
+          : withOneRestart
+          : withRestarts
           : test_code
           : source_file
           : FUN
@@ -281,10 +281,10 @@
           : doTryCatch
           : tryCatchOne
           : tryCatchList
-          : doTryCatch
-          : tryCatchOne
-          : tryCatchList
           : tryCatch
+          : doWithOneRestart
+          : withOneRestart
+          : withRestarts
           : test_code
           : test_that
           : eval [test-stacks-deep.R#XXX]
@@ -293,10 +293,10 @@
           : doTryCatch
           : tryCatchOne
           : tryCatchList
-          : doTryCatch
-          : tryCatchOne
-          : tryCatchList
           : tryCatch
+          : doWithOneRestart
+          : withOneRestart
+          : withRestarts
           : test_code
           : source_file
           : FUN
@@ -335,10 +335,10 @@
           : doTryCatch
           : tryCatchOne
           : tryCatchList
-          : doTryCatch
-          : tryCatchOne
-          : tryCatchList
           : tryCatch
+          : doWithOneRestart
+          : withOneRestart
+          : withRestarts
           : test_code
           : test_that
           : eval [test-stacks-deep.R#XXX]
@@ -347,10 +347,10 @@
           : doTryCatch
           : tryCatchOne
           : tryCatchList
-          : doTryCatch
-          : tryCatchOne
-          : tryCatchList
           : tryCatch
+          : doWithOneRestart
+          : withOneRestart
+          : withRestarts
           : test_code
           : source_file
           : FUN

tests/testthat/_snaps/stacks.md

@@ -1,90 +1,103 @@
 # integration tests
 
     Code
-      df
+      df_integration_slim
     Output
-        num                call                 loc
-      1  64                   A   [test-stacks.R#3]
-      2  63                   B   [test-stacks.R#7]
-      3  62        <reactive:C>  [test-stacks.R#11]
-      4  42                   C                    
-      5  41         renderTable  [test-stacks.R#18]
-      6  40                func                    
-      7  39               force                    
-      8  38         withVisible                    
-      9  37 withCallingHandlers                    
+         num                                     call                 loc
+      1   70                                        A   [test-stacks.R#3]
+      2   69                                        B   [test-stacks.R#7]
+      3   68                             <reactive:C>  [test-stacks.R#11]
+      4   46                                        C                    
+      5   45                              renderTable  [test-stacks.R#18]
+      6   44                                     func                    
+      7   28 renderTable({     C() }, server = FALSE)                    
+      8   10                                  isolate                    
+      9    9                      withCallingHandlers  [test-stacks.R#16]
+      10   8                          domain$wrapSync                    
+      11   7            promises::with_promise_domain                    
+      12   6                       captureStackTraces                    
+      13   2                                 tryCatch                    
+      14   1                                      try                    
+      15   0                               causeError  [test-stacks.R#14]
 
 ---
 
     Code
-      df
+      df_integration_full
     Output
          num                                     call                 loc
-      1   67                                        h                    
-      2   66                       .handleSimpleError                    
-      3   65                                     stop                    
-      4   64                                        A   [test-stacks.R#3]
-      5   63                                        B   [test-stacks.R#7]
-      6   62                             <reactive:C>  [test-stacks.R#11]
-      7   61                         ..stacktraceon..                    
-      8   60                                    .func                    
-      9   59                              withVisible                    
-      10  58                      withCallingHandlers                    
-      11  57                              contextFunc                    
-      12  56                              env$runWith                    
-      13  55                      withCallingHandlers                    
-      14  54                          domain$wrapSync                    
-      15  53            promises::with_promise_domain                    
-      16  52                       captureStackTraces                    
-      17  51                                    force                    
-      18  50                          domain$wrapSync                    
-      19  49            promises::with_promise_domain                    
-      20  48                       withReactiveDomain                    
-      21  47                          domain$wrapSync                    
-      22  46            promises::with_promise_domain                    
-      23  45                                  ctx$run                    
-      24  44                        self$.updateValue                    
-      25  43                        ..stacktraceoff..                    
-      26  42                                        C                    
-      27  41                              renderTable  [test-stacks.R#18]
-      28  40                                     func                    
-      29  39                                    force                    
-      30  38                              withVisible                    
-      31  37                      withCallingHandlers                    
-      32  36                          domain$wrapSync                    
-      33  35            promises::with_promise_domain                    
-      34  34                       captureStackTraces                    
-      35  33                               doTryCatch                    
-      36  32                              tryCatchOne                    
-      37  31                             tryCatchList                    
-      38  30                                 tryCatch                    
-      39  29                                       do                    
-      40  28                             hybrid_chain                    
-      41  27                               renderFunc                    
-      42  26 renderTable({     C() }, server = FALSE)                    
-      43  25                         ..stacktraceon..  [test-stacks.R#17]
-      44  24                              contextFunc                    
-      45  23                              env$runWith                    
-      46  22                      withCallingHandlers                    
-      47  21                          domain$wrapSync                    
-      48  20            promises::with_promise_domain                    
-      49  19                       captureStackTraces                    
-      50  18                                    force                    
-      51  17                          domain$wrapSync                    
-      52  16            promises::with_promise_domain                    
-      53  15                       withReactiveDomain                    
-      54  14                          domain$wrapSync                    
-      55  13            promises::with_promise_domain                    
-      56  12                                  ctx$run                    
-      57  11                        ..stacktraceoff..                    
-      58  10                                  isolate                    
-      59   9                      withCallingHandlers  [test-stacks.R#16]
-      60   8                          domain$wrapSync                    
-      61   7            promises::with_promise_domain                    
-      62   6                       captureStackTraces                    
-      63   5                               doTryCatch  [test-stacks.R#15]
-      64   4                              tryCatchOne                    
-      65   3                             tryCatchList                    
-      66   2                                 tryCatch                    
-      67   1                                      try                    
+      1   73                                        h                    
+      2   72                       .handleSimpleError                    
+      3   71                                     stop                    
+      4   70                                        A   [test-stacks.R#3]
+      5   69                                        B   [test-stacks.R#7]
+      6   68                             <reactive:C>  [test-stacks.R#11]
+      7   67                         ..stacktraceon..                    
+      8   66                                    .func                    
+      9   65                              withVisible                    
+      10  64                      withCallingHandlers                    
+      11  63                              contextFunc                    
+      12  62                              env$runWith                    
+      13  61                      withCallingHandlers                    
+      14  60                          domain$wrapSync                    
+      15  59            promises::with_promise_domain                    
+      16  58                       captureStackTraces                    
+      17  57                                    force                    
+      18  56                   with_otel_span_context                    
+      19  55                                    force                    
+      20  54                          domain$wrapSync                    
+      21  53            promises::with_promise_domain                    
+      22  52                       withReactiveDomain                    
+      23  51                          domain$wrapSync                    
+      24  50            promises::with_promise_domain                    
+      25  49                                  ctx$run                    
+      26  48                        self$.updateValue                    
+      27  47                        ..stacktraceoff..                    
+      28  46                                        C                    
+      29  45                              renderTable  [test-stacks.R#18]
+      30  44                                     func                    
+      31  43                         ..stacktraceon..                    
+      32  42                                    force                    
+      33  41                              withVisible                    
+      34  40                      withCallingHandlers                    
+      35  39                          domain$wrapSync                    
+      36  38            promises::with_promise_domain                    
+      37  37                       captureStackTraces                    
+      38  36                               doTryCatch                    
+      39  35                              tryCatchOne                    
+      40  34                             tryCatchList                    
+      41  33                                 tryCatch                    
+      42  32                                       do                    
+      43  31                             hybrid_chain                    
+      44  30                               renderFunc                    
+      45  29                        ..stacktraceoff..                    
+      46  28 renderTable({     C() }, server = FALSE)                    
+      47  27                         ..stacktraceon..  [test-stacks.R#17]
+      48  26                              contextFunc                    
+      49  25                              env$runWith                    
+      50  24                      withCallingHandlers                    
+      51  23                          domain$wrapSync                    
+      52  22            promises::with_promise_domain                    
+      53  21                       captureStackTraces                    
+      54  20                                    force                    
+      55  19                   with_otel_span_context                    
+      56  18                                    force                    
+      57  17                          domain$wrapSync                    
+      58  16            promises::with_promise_domain                    
+      59  15                       withReactiveDomain                    
+      60  14                          domain$wrapSync                    
+      61  13            promises::with_promise_domain                    
+      62  12                                  ctx$run                    
+      63  11                        ..stacktraceoff..                    
+      64  10                                  isolate                    
+      65   9                      withCallingHandlers  [test-stacks.R#16]
+      66   8                          domain$wrapSync                    
+      67   7            promises::with_promise_domain                    
+      68   6                       captureStackTraces                    
+      69   5                               doTryCatch  [test-stacks.R#15]
+      70   4                              tryCatchOne                    
+      71   3                             tryCatchList                    
+      72   2                                 tryCatch                    
+      73   1                                      try                    
+      74   0                               causeError  [test-stacks.R#14]
 

tests/testthat/_snaps/tabPanel.md

@@ -353,7 +353,7 @@
       <div class="tabbable">
         <ul class="nav nav-tabs" data-tabsetid="4785">
           <li>
-            <a href="#tab-4785-1" data-toggle="tab" data-bs-toggle="tab"></a>
+            <a href="#tab-4785-1" data-toggle="tab" data-bs-toggle="tab" disabled></a>
           </li>
           <li class="active">
             <a href="#tab-4785-2" data-toggle="tab" data-bs-toggle="tab" data-value="A">A</a>

tests/testthat/helper-otel-interactive-app.R

@@ -0,0 +1,322 @@
+# devtools::load_all(); dev_otel_kitchen()
+
+dev_otel_kitchen <- function() {
+  library(mirai)
+  mirai::daemons(2)
+
+  # Inspiration from
+  # * https://github.com/r-lib/otel/commit/a2ef493ae4b97701e4e178ac527f313580539080
+  # * https://github.com/r-lib/otel/commit/09c0eb6c80d5b907976de8fbaf89798cb11f8e6e#diff-169b8f234d0b208affb106fce375f86fefe2f16dba4ad66495a1dc06c8a4cd7b
+
+  otel_logger <- otel::get_logger("my-app-logger")
+  otel_tracer_name <- "my-app"
+
+  log_and_msg <- function(..., .envir = parent.frame()) {
+    msg <- paste(...)
+    message("  -- ", msg)
+
+    otel_log(msg, logger = otel_logger)
+  }
+
+  my_global_reactive <- reactiveVal(0)
+
+  app <- shinyApp(
+    ui = fluidPage(
+      sliderInput("mymod-x", "x", 1, 10, 5),
+      sliderInput("mymod-y", "y", 1, 10, 5),
+      div("x * y: "),
+      verbatimTextOutput("mymod-txt1"),
+      verbatimTextOutput("mymod-txt2"),
+      verbatimTextOutput("mymod-txt3"),
+      verbatimTextOutput("task_result")
+    ),
+    server = function(input, output, session) {
+      log_and_msg("Start new Shiny session")
+
+      b <- reactiveVal(1)
+      observe(b(42))
+
+      shutdown <- function() {
+        later::later(
+          function() {
+            message("\n\nClosing session for minimal logfire graphs")
+            # session$close()
+            # httpuv::stopAllServers()
+            stopApp()
+            mirai::daemons(0)
+          },
+          delay = 100 / 1000
+        )
+      }
+
+      later::later(
+        function() {
+          if (!session$closed) {
+            log_and_msg("Invoking shutdown after 5s")
+            shutdown()
+          }
+        },
+        delay = 5
+      )
+
+      xMod <- function(id) {
+        moduleServer(id, function(input, output, session) {
+          xVal <- reactiveVal(NULL)
+          yVal <- reactiveVal(NULL)
+          rv <- reactiveValues(x = NULL, y = NULL)
+
+          log_and_msg("Shiny module")
+
+          x_raw <- reactive({
+            isolate({
+              my_global_reactive(my_global_reactive() + 1)
+            })
+
+            x_val <- xVal()
+            req(x_val)
+            log_and_msg(sprintf("X Val: %s", x_val))
+            x_val
+          })
+          x <- debounce(x_raw, 100)
+          y_raw <- reactive({
+            y_val <- input$y
+            log_and_msg(sprintf("Y Val: %s", y_val))
+            # Sys.sleep(0.5)
+            y_val
+          }) |> bindCache(input$y) |> bindEvent(input$y)
+          y <- throttle(y_raw, 100)
+
+          calc <- reactive(label = "barret_calc", {
+            log_and_msg("Doing expensive computation...")
+            x() * y()
+          })
+
+          observe({
+            log_and_msg("x: ", x())
+          })
+
+          output$txt1 <- renderText({
+            calc()
+          }) |>
+            bindCache(x(), y())
+          output$txt2 <- renderText({
+            calc()
+          }) |>
+            bindEvent(list(x(), y()))
+          output$txt3 <- renderText({
+            calc()
+          }) |>
+            bindCache(x(), y()) |>
+            bindEvent(list(x(), y()))
+
+          rand_task <- ExtendedTask$new(function() {
+            mirai::mirai(
+              {
+                # Slow operation goes here
+                Sys.sleep(100 / 1000)
+                sample(1:100, 1)
+              }
+            )
+          })
+
+          observeEvent(input$x, {
+            # Invoke the extended in an observer
+            rand_task$invoke()
+          }, label = "invoke_rand_task")
+
+          output$task_result <- renderText({
+            # React to updated results when the task completes
+            number <- rand_task$result()
+            paste0("Your number is ", number, ".")
+          })
+
+          mydesc <- reactiveFileReader(
+            1000,
+            session,
+            filePath = system.file("DESCRIPTION", package = "shiny"),
+            readFunc = read.dcf
+          )
+          observe({
+            mydesc()
+          })
+
+          myfile <- reactivePoll(
+            1000,
+            session,
+            checkFunc = function() {
+              Sys.time()
+            },
+            # This function returns the content of log_file
+            valueFunc = function() {
+              read.dcf(system.file("DESCRIPTION", package = "shiny"))
+            }
+          )
+
+          observe({
+            myfile()
+          })
+
+          x_prom <- reactive({
+            # t0
+            x_span_id <- force(otel::get_active_span_context()$get_span_id())
+            # message("x_prom span id: ", x_span_id)
+            x_val <- x()
+            log_and_msg("x_prom init")
+            p <- promises::promise(function(resolve, reject) {
+              log_and_msg("x_prom 0")
+              resolve(x_val)
+            })
+            p <- promises::then(p, function(x_val) {
+              log_and_msg("x_prom 1")
+              log_and_msg("Launching mirai")
+              x_val
+              # mirai::mirai_map(seq_len(x_val), function(i) {
+              #   otel::start_local_active_span("slow compute")
+              #   Sys.sleep(i / 10 / 1000)
+              #   i
+              # }) |>
+              #   promises::then(function(vals) {
+              #     max(unlist(vals))
+              #   })
+
+              # mirai::mirai(
+              #   {
+              #     otel::start_local_active_span("slow compute")
+              #     # val
+              #     # Sys.sleep(0.2)
+              #     val
+              #   },
+              #   val = x_val
+              # )
+            })
+            p <- promises::then(p, function(x_val) {
+              log_and_msg("x_prom 2")
+              x_val
+            })
+            p <- promises::then(p, function(x_val) {
+              log_and_msg("x_prom 3")
+              x_val
+            })
+          })
+
+          y_prom <- reactive({
+            y_span_id <- force(otel::get_active_span_context()$get_span_id())
+            # message("y_prom span id: ", y_span_id)
+            y_val <- y()
+            log_and_msg("y_prom init")
+            yp <- promises::promise(function(resolve, reject) {
+              log_and_msg("y_prom 0")
+              resolve(y_val)
+            })
+            log_and_msg("make y_prom 1")
+            yp <- promises::then(yp, function(y_val) {
+              log_and_msg("y_prom 1")
+              y_val
+            })
+            log_and_msg("make y_prom 2")
+            yp <- promises::then(yp, function(y_val) {
+              log_and_msg("y_prom 2")
+              y_val + calc()
+            })
+            log_and_msg("make y_prom 3")
+            yp <- promises::then(yp, function(y_val) {
+              log_and_msg("y_prom 3")
+              y_val
+            })
+
+            log_and_msg(
+              "done y_prom - ",
+              getCurrentContext()$id,
+              " - ",
+              getCurrentContext()$.label
+            )
+            yp
+          })
+
+          observe(label = "proms_observer", {
+            p <- promises::promise_all(
+              x_prom(),
+              y_prom()
+            )
+            p <- promises::then(p, function(vals) {
+              log_and_msg("Vals[1]: ", vals[[1]])
+              log_and_msg("Vals[2]: ", vals[[2]])
+
+              # cat(force)
+
+              # Shut down the app so the telemetry can be seen easily
+              if (vals[[1]] < 6) {
+                updateSliderInput(
+                  "x",
+                  value = vals[[1]] + 1,
+                  session = session
+                )
+              } else {
+                shutdown()
+              }
+            })
+            log_and_msg(
+              "done proms_observer - ",
+              getCurrentContext()$id,
+              " - ",
+              getCurrentContext()$.label
+            )
+            p
+          })
+
+          # |>
+          # bindOtel()
+
+          # Set the value late in the reactive calc
+          observeEvent(
+            {
+              input$x
+            },
+            {
+              rv$x <- input$x
+            },
+            label = "singleObserveEvent"
+          )
+
+          tmp_val <- reactiveVal(NULL)
+
+          # TODO: Not recording updates within the span!!
+          x_calc <- eventReactive(
+            {
+              isolate(tmp_val(1))
+              rv$x
+            },
+            {
+              tmp_val(2)
+              rv$x
+            }
+          )
+          y_calc <- eventReactive(
+            {
+              isolate(tmp_val(3))
+              input$y * 2
+            },
+            {
+              # x_calc()
+              tmp_val(4)
+              input$y * 2 / 2
+            }
+          )
+          # observeEvent(label = "set_y", {
+          #   rv$y <- input$y
+          # })
+          observe(label = "set xVal", {
+            x_calc()
+            xVal(rv$x)
+          })
+          observe(label = "set yVal", {
+            yVal(y_calc())
+          })
+        })
+      }
+      xMod("mymod")
+    }
+  )
+
+  app
+}

tests/testthat/helper-otel.R

@@ -0,0 +1,37 @@
+skip_if_shiny_otel_tracer_is_enabled <- function() {
+  if (shiny_otel_tracer()$is_enabled()) {
+    skip("Skipping stack trace tests when OpenTelemetry is already enabled")
+  }
+}
+
+# Helper function to create a mock otel span
+create_mock_otel_span <- function(name = "test_span") {
+  structure(
+    list(
+      name = name,
+      activate = function(...) NULL,
+      end = function(...) NULL
+    ),
+    class = "otel_span"
+  )
+}
+
+# Helper function to create a mock tracer
+create_mock_tracer <- function() {
+  structure(
+    list(
+      name = "mock_tracer",
+      is_enabled = function() TRUE,
+      start_span = function(name, ...) create_mock_otel_span(name)
+    ),
+    class = "otel_tracer"
+  )
+}
+
+# Helper function to create a mock logger
+create_mock_logger <- function() {
+  structure(
+    list(name = "mock_logger"),
+    class = "otel_logger"
+  )
+}

tests/testthat/helper-stacks.R

@@ -0,0 +1,118 @@
+#' @details `extractStackTrace` takes a list of calls (e.g. as returned
+#'   from `conditionStackTrace(cond)`) and returns a data frame with one
+#'   row for each stack frame and the columns `num` (stack frame number),
+#'   `call` (a function name or similar), and `loc` (source file path
+#'   and line number, if available). It was deprecated after shiny 1.0.5 because
+#'   it doesn't support deep stack traces.
+#' @rdname stacktrace
+#' @export
+extractStackTrace <- function(calls,
+                              full = get_devmode_option("shiny.fullstacktrace", FALSE),
+                              offset = getOption("shiny.stacktraceoffset", TRUE)) {
+
+  srcrefs <- getSrcRefs(calls)
+  if (offset) {
+    # Offset calls vs. srcrefs by 1 to make them more intuitive.
+    # E.g. for "foo [bar.R:10]", line 10 of bar.R will be part of
+    # the definition of foo().
+    srcrefs <- c(utils::tail(srcrefs, -1), list(NULL))
+  }
+  calls <- setSrcRefs(calls, srcrefs)
+
+  callnames <- getCallNames(calls)
+
+  # Hide and show parts of the callstack based on ..stacktrace(on|off)..
+  if (full) {
+    toShow <- rep.int(TRUE, length(calls))
+  } else {
+    # Remove stop(), .handleSimpleError(), and h() calls from the end of
+    # the calls--they don't add any helpful information. But only remove
+    # the last *contiguous* block of them, and then, only if they are the
+    # last thing in the calls list.
+    hideable <- callnames %in% c("stop", ".handleSimpleError", "h")
+    # What's the last that *didn't* match stop/.handleSimpleError/h?
+    lastGoodCall <- max(which(!hideable))
+    toRemove <- length(calls) - lastGoodCall
+    # But don't remove more than 5 levels--that's an indication we might
+    # have gotten it wrong, I guess
+    if (toRemove > 0 && toRemove < 5) {
+      calls <- utils::head(calls, -toRemove)
+      callnames <- utils::head(callnames, -toRemove)
+    }
+
+    toShow <- stripStackTraces(list(callnames))[[1]]
+
+    toShow <-
+      toShow &
+      # doTryCatch, tryCatchOne, and tryCatchList are not informative--they're
+      # just internals for tryCatch
+      !(callnames %in% c("doTryCatch", "tryCatchOne", "tryCatchList")) &
+      # doWithOneRestart and withOneRestart are not informative--they're
+      # just internals for withRestarts
+      !(callnames %in% c("withOneRestart", "doWithOneRestart"))
+  }
+  calls <- calls[toShow]
+
+
+  calls <- rev(calls) # Show in traceback() order
+  index <- rev(which(toShow))
+  width <- floor(log10(max(index))) + 1
+
+  data.frame(
+    num = index,
+    call = getCallNames(calls),
+    loc = getLocs(calls),
+    # category = getCallCategories(calls),
+    stringsAsFactors = FALSE
+  )
+}
+
+cleanLocs <- function(locs) {
+  locs[!grepl("test-stacks\\.R", locs, perl = TRUE)] <- ""
+  # sub("^.*#", "", locs)
+  locs
+}
+
+dumpTests <- function(df) {
+  print(bquote({
+    expect_equal(df$num, .(df$num))
+    expect_equal(df$call, .(df$call))
+    expect_equal(nzchar(df$loc), .(nzchar(df$loc)))
+  }))
+}
+
+# Helper: run a render function whose body throws an error, capture the
+# stack trace, apply fence-based filtering, and return the filtered data
+# frame. The render function body should call a function that calls stop().
+# `needs_session` indicates whether the render function requires
+# shinysession/name parameters (TRUE for markRenderFunction-based renders
+# like renderPlot and renderPrint, FALSE for createRenderFunction-based
+# renders like renderText/renderTable/renderUI/renderImage which can be
+# called with no args).
+captureFilteredRenderTrace <- function(render_fn, needs_session = TRUE) {
+  session <- MockShinySession$new()
+  on.exit(if (!session$isClosed()) session$close())
+
+  res <- try({
+      captureStackTraces({
+        isolate({
+          withReactiveDomain(session, {
+            if (needs_session) {
+              render_fn(shinysession = session, name = "testoutput")
+            } else {
+              render_fn()
+            }
+          })
+        })
+      })
+    },
+    silent = TRUE)
+
+  cond <- attr(res, "condition", exact = TRUE)
+  stopifnot(!is.null(cond))
+  stopifnot(!is.null(conditionStackTrace(cond)))
+
+  suppressMessages(
+    extractStackTrace(conditionStackTrace(cond), full = FALSE)
+  )
+}

tests/testthat/test-actionButton.R

@@ -94,3 +94,30 @@ test_that("Action button allows icon customization", {
   expect_equal(as_character(btn2), as_character(btn3))
   expect_equal(as_character(btn3), as_character(btn4))
 })
+
+test_that("actionLink uses .noWS to prevent underline rendering issues", {
+  # actionLink should generate compact HTML without whitespace between tags
+  # This prevents the underline from extending beyond the visible text
+
+  # Test without icon
+  link <- actionLink("test_link", "Click me")
+  link_html <- as.character(link)
+
+  # Verify no newlines/whitespace between closing > and opening <span
+  expect_false(
+    grepl(">\n\\s+<span", link_html),
+    info = "actionLink should not have whitespace between tags"
+  )
+
+  # Test with icon
+  link_icon <- actionLink("test_link2", "Click me", icon = icon("star"))
+  link_icon_html <- as.character(link_icon)
+
+  # Should also have no whitespace between icon span and label span
+  expect_false(
+    grepl(">\n\\s+<span", link_icon_html),
+    info = "actionLink with icon should not have whitespace between tags"
+  )
+  expect_snapshot(actionLink("foo", "Click me"))
+  expect_snapshot(actionLink("foo", "Click me", icon = icon("star")))
+})

tests/testthat/test-bind-cache.R

@@ -930,7 +930,7 @@ test_that("bindCache reactive visibility - async", {
   k <- reactiveVal(0)
   res <- NULL
   r <- reactive({
-    promise(function(resolve, reject) {
+    promises::promise(function(resolve, reject) {
       if (k() == 0) resolve(invisible(k()))
       else          resolve(k())
     })
@@ -943,21 +943,25 @@ test_that("bindCache reactive visibility - async", {
     })
   })
 
-  flushReact()
-  for (i in 1:3) later::run_now()
+  flush_and_run_later <- function(k) {
+    flushReact()
+    for (i in 1:k) later::run_now()
+  }
+
+  flush_and_run_later(4)
   expect_identical(res, list(value = 0, visible = FALSE))
+
   k(1)
-  flushReact()
-  for (i in 1:3) later::run_now()
+  flush_and_run_later(4)
   expect_identical(res, list(value = 1, visible = TRUE))
+
   # Now fetch from cache
   k(0)
-  flushReact()
-  for (i in 1:3) later::run_now()
+  flush_and_run_later(4)
   expect_identical(res, list(value = 0, visible = FALSE))
+
   k(1)
-  flushReact()
-  for (i in 1:3) later::run_now()
+  flush_and_run_later(4)
   expect_identical(res, list(value = 1, visible = TRUE))
 })
 
@@ -1136,6 +1140,8 @@ test_that("Custom render functions that call installExprFunction", {
 
 
 test_that("cacheWriteHook and cacheReadHook for render functions", {
+  skip_if_shiny_otel_tracer_is_enabled()
+
   write_hook_n <- 0
   read_hook_n  <- 0
 

tests/testthat/test-non-blocking.R

@@ -0,0 +1,275 @@
+# Prevent browser launch in interactive sessions
+withr::local_options(list(shiny.launch.browser = FALSE), .local_envir = teardown_env())
+
+test_that("ShinyAppHandle lifecycle and API (success path)", {
+  app <- shinyApp(
+    ui = fluidPage(),
+    server = function(input, output) {}
+  )
+
+  handle <- startApp(app, launch.browser = FALSE, quiet = TRUE)
+
+  # While running
+
+  expect_equal(handle$status(), "running")
+  expect_match(handle$url(), "^http://")
+  expect_error(handle$result(), "App is still running")
+
+  output <- capture.output(print(handle))
+  expect_match(output[1], "Shiny app handle")
+  expect_match(output[2], "URL:")
+  expect_match(output[3], "running")
+
+  # stop() returns invisible self
+  ret <- withVisible(handle$stop())
+  expect_false(ret$visible)
+  expect_identical(ret$value, handle)
+
+  # After stop
+  expect_equal(handle$status(), "success")
+  expect_null(handle$result())
+
+  output <- capture.output(print(handle))
+  expect_match(output[3], "success")
+
+  # Double stop is a silent no-op
+  expect_no_warning(handle$stop())
+  expect_equal(handle$status(), "success")
+})
+
+test_that("ShinyAppHandle lifecycle (error path)", {
+  app <- shinyApp(
+    ui = fluidPage(),
+    server = function(input, output) {}
+  )
+
+  handle <- startApp(app, launch.browser = FALSE, quiet = TRUE)
+
+  stopApp(stop("test_error", call. = FALSE))
+  while (handle$status() == "running") {
+    later::run_now(timeoutSecs = 1)
+  }
+
+  expect_equal(handle$status(), "error")
+  expect_error(handle$result(), "test_error")
+
+  output <- capture.output(print(handle))
+  expect_match(output[3], "error")
+})
+
+test_that("handle captures result from stopApp", {
+  app <- shinyApp(
+    ui = fluidPage(),
+    server = function(input, output) {}
+  )
+
+  handle <- startApp(app, launch.browser = FALSE, quiet = TRUE)
+
+  stopApp("test_result")
+  while (handle$status() == "running") {
+    later::run_now(timeoutSecs = 1)
+  }
+
+  expect_equal(handle$status(), "success")
+  expect_equal(handle$result(), "test_result")
+})
+
+test_that("non-blocking auto-stops previous app when starting new one", {
+  app1 <- shinyApp(
+    ui = fluidPage(),
+    server = function(input, output) {}
+  )
+  app2 <- shinyApp(
+    ui = fluidPage(),
+    server = function(input, output) {}
+  )
+
+  handle1 <- startApp(app1, launch.browser = FALSE, quiet = TRUE)
+  expect_equal(handle1$status(), "running")
+
+  # Starting a second non-blocking app should auto-stop the first
+  handle2 <- startApp(app2, launch.browser = FALSE, quiet = TRUE)
+  on.exit(handle2$stop(), add = TRUE)
+
+  expect_equal(handle1$status(), "success")
+  expect_equal(handle2$status(), "running")
+
+  handle2$stop()
+})
+
+test_that("replacing a non-blocking app does not leave stale service loops", {
+  generations_seen <- integer(0)
+
+  # Mock serviceApp to record which generation is active when called
+  local_mocked_bindings(
+    serviceApp = function(timeout) {
+      generations_seen[[length(generations_seen) + 1L]] <<-
+        .globals$serviceGeneration
+    },
+    .package = "shiny"
+  )
+
+  app1 <- shinyApp(ui = fluidPage(), server = function(input, output) {})
+  app2 <- shinyApp(ui = fluidPage(), server = function(input, output) {})
+
+  handle1 <- startApp(app1, launch.browser = FALSE, quiet = TRUE)
+  gen1 <- .globals$serviceGeneration
+
+  handle2 <- startApp(app2, launch.browser = FALSE, quiet = TRUE)
+  on.exit(handle2$stop(), add = TRUE)
+  gen2 <- .globals$serviceGeneration
+
+  # Reset and let service loops run
+  generations_seen <- integer(0)
+  while (length(generations_seen) < 5L) later::run_now(timeoutSecs = 1)
+
+  # Only the new generation should be servicing
+  expect_true(length(generations_seen) > 0)
+  expect_true(all(generations_seen == gen2))
+
+  handle2$stop()
+})
+
+test_that("starting a blocking app invalidates stale non-blocking service loops", {
+  service_calls <- 0L
+
+  local_mocked_bindings(
+    serviceApp = function(timeout) {
+      service_calls <<- service_calls + 1L
+    },
+    .package = "shiny"
+  )
+
+  ns <- asNamespace("shiny")
+  g <- get(".globals", envir = ns)
+
+  # Simulate a non-blocking app at generation 1
+  assign("serviceGeneration", 1L, envir = g)
+  assign("stopped", FALSE, envir = g)
+  shiny:::serviceNonBlocking(list(stop = function() {}), 1L)
+
+  # Simulate stopping app 1, then starting a blocking app which bumps generation
+  assign("stopped", TRUE, envir = g)
+  assign("serviceGeneration", 2L, envir = g)
+  assign("stopped", FALSE, envir = g)
+
+  later::run_now(timeoutSecs = 1)
+
+  expect_equal(service_calls, 0L)
+})
+
+test_that("nested runApp in blocking mode still errors", {
+  inner_app <- shinyApp(
+    ui = fluidPage(),
+    server = function(input, output) {}
+  )
+
+  outer_app <- shinyApp(
+    ui = fluidPage(),
+    server = function(input, output) {},
+    onStart = function() {
+      runApp(inner_app, launch.browser = FALSE, quiet = TRUE)
+    }
+  )
+
+  expect_error(
+    runApp(outer_app, launch.browser = FALSE, quiet = TRUE),
+    "from within `runApp"
+  )
+})
+
+test_that("cleanup callbacks run when stopped", {
+  stopped <- FALSE
+  app <- shinyApp(
+    ui = fluidPage(),
+    server = function(input, output) {}
+  )
+  onStop(function() stopped <<- TRUE)
+
+  handle <- startApp(app, launch.browser = FALSE, quiet = TRUE)
+  handle$stop()
+
+  expect_true(stopped)
+})
+
+test_that("old handle doesn't see new app's result", {
+  app1 <- shinyApp(
+    ui = fluidPage(),
+    server = function(input, output) {}
+  )
+
+  handle1 <- startApp(app1, launch.browser = FALSE, quiet = TRUE)
+
+  stopApp("result1")
+  while (handle1$status() == "running") {
+    later::run_now(1)
+  }
+  expect_equal(handle1$result(), "result1")
+
+  # Start and stop app2
+  app2 <- shinyApp(
+    ui = fluidPage(),
+    server = function(input, output) {}
+  )
+  handle2 <- startApp(app2, launch.browser = FALSE, quiet = TRUE)
+
+  stopApp("result2")
+  while (handle2$status() == "running") {
+    later::run_now(timeoutSecs = 1)
+  }
+  expect_equal(handle2$result(), "result2")
+
+  # handle1 should still have its original result
+  expect_equal(handle1$result(), "result1")
+})
+
+test_that("global isRunning() works with non-blocking apps", {
+  app <- shinyApp(
+    ui = fluidPage(),
+    server = function(input, output) {}
+  )
+
+  expect_false(isRunning())
+
+  handle <- startApp(app, launch.browser = FALSE, quiet = TRUE)
+  on.exit(handle$stop(), add = TRUE)
+
+  expect_true(isRunning())
+
+  handle$stop()
+  expect_false(isRunning())
+})
+
+test_that("startup failure clears app state (regression test)", {
+  # If startup fails after initCurrentAppState() but before cleanupOnExit <- FALSE,
+  # the app state must be cleared so subsequent runApp() calls don't fail with
+  # "Can't start a new app while another is running"
+
+  # Create an app that fails during onStart (which runs after initCurrentAppState)
+  failing_app <- shinyApp(
+    ui = fluidPage(),
+    server = function(input, output) {},
+    onStart = function() stop("Intentional startup failure")
+  )
+
+  # This should fail
+  expect_error(
+    startApp(failing_app, launch.browser = FALSE, quiet = TRUE),
+    "Intentional startup failure"
+  )
+
+  # isRunning() should return FALSE - no app is actually running
+  expect_false(isRunning())
+
+  # A subsequent runApp() call should work
+  working_app <- shinyApp(
+    ui = fluidPage(),
+    server = function(input, output) {}
+  )
+
+  handle <- startApp(working_app, launch.browser = FALSE, quiet = TRUE)
+  on.exit(handle$stop(), add = TRUE)
+
+  expect_equal(handle$status(), "running")
+  handle$stop()
+})

tests/testthat/test-otel-attr-srcref.R

@@ -0,0 +1,751 @@
+# Do not move or rearrange this code - it defines helper functions used in multiple tests below
+get_reactive_objects <- function() {
+  # Must use variables, otherwise the source reference is collapsed to a single line
+  r <- reactive({ 42 })
+  rv <- reactiveVal("test")
+  rvs <- reactiveValues(a = 1)
+  o <- observe({ 43 })
+  rt <- renderText({ "text" })
+  oe <- observeEvent({"key"}, { 45 })
+  er <- eventReactive({"key"}, { 46 })
+
+  # Values below this line are to test file location, not file line
+  r1a <- reactive({ 1 }) |> bindCache({"key"})
+  r2a <- reactive({ 2 }) |> bindEvent({"key"})
+  r3a <- reactive({ 3 }) |> bindCache({"key1"}) |> bindEvent({"key2"})
+  r1b <- bindCache(reactive({ 1 }), {"key"})
+  r2b <- bindEvent(reactive({ 2 }), {"key"})
+  r3b <- bindEvent(bindCache(reactive({ 3 }), {"key1"}), {"key2"})
+
+  rt1a <- renderText({"text"}) |> bindCache({"key"})
+  rt2a <- renderText({"text"}) |> bindEvent({"key"})
+  rt3a <- renderText({"text"}) |> bindCache({"key1"}) |> bindEvent({"key2"})
+  rt1b <- bindCache(renderText({"text"}), {"key"})
+  rt2b <- bindEvent(renderText({"text"}), {"key"})
+  rt3b <- bindEvent(bindCache(renderText({"text"}), {"key1"}), {"key2"})
+
+  o2a <- observe({ 44 }) |> bindEvent({"key"})
+  o2b <- bindEvent(observe({ 47 }), {"key"})
+
+  # Debounce and throttle
+  r_debounce <- reactive({ 48 }) |> debounce(1000)
+  r_throttle <- reactive({ 49 }) |> throttle(1000)
+
+  # ExtendedTask
+  ext_task <- ExtendedTask$new(function() { promises::promise_resolve(50) })
+
+  # Reactive with explicit label
+  r_labeled <- reactive({ 51 }, label = "my_reactive")
+  o_labeled <- observe({ 52 }, label = "my_observer")
+
+  # Poll and File
+  r_poll <- reactivePoll(1000, NULL, checkFunc = function() { TRUE}, valueFunc = function() { 53 })
+  r_file <- reactiveFileReader(1000, NULL, filePath = "path/to/file")
+
+  list(
+    reactive = r,
+    reactiveVal = rv,
+    reactiveValues = rvs,
+    observe = o,
+    renderText = rt,
+    observeEvent = oe,
+    eventReactive = er,
+    reactiveCacheA = r1a,
+    reactiveEventA = r2a,
+    reactiveCacheEventA = r3a,
+    reactiveCacheB = r1b,
+    reactiveEventB = r2b,
+    reactiveCacheEventB = r3b,
+    renderCacheA = rt1a,
+    renderEventA = rt2a,
+    renderCacheEventA = rt3a,
+    renderCacheB = rt1b,
+    renderEventB = rt2b,
+    renderCacheEventB = rt3b,
+    observeEventA = o2a,
+    observeEventB = o2b,
+    debounce = r_debounce,
+    throttle = r_throttle,
+    extendedTask = ext_task,
+    reactiveLabeled = r_labeled,
+    observeLabeled = o_labeled,
+    reactivePoll = r_poll,
+    reactiveFileReader = r_file
+  )
+}
+
+
+
+# Helper function to create a mock srcref
+create_mock_srcref <- function(
+  lines = c(10, 15),
+  columns = c(5, 20),
+  filename = "test_file.R"
+) {
+  srcfile <- list(filename = filename)
+  srcref <- structure(
+    c(lines[1], columns[1], lines[2], columns[2], columns[1], columns[2]),
+    class = "srcref"
+  )
+  attr(srcref, "srcfile") <- srcfile
+  srcref
+}
+
+
+test_that("otel_srcref_attributes extracts attributes from srcref object", {
+  srcref <- create_mock_srcref(
+    lines = c(15, 18),
+    columns = c(8, 25),
+    filename = "/path/to/myfile.R"
+  )
+
+  attrs <- otel_srcref_attributes(srcref)
+
+  # Preferred attribute names
+  expect_equal(attrs[["code.file.path"]], "/path/to/myfile.R")
+  expect_equal(attrs[["code.line.number"]], 15)
+  expect_equal(attrs[["code.column.number"]], 8)
+  expect_false("code.function.name" %in% names(attrs))
+
+  # Deprecated attribute names (for backward compatibility)
+  expect_equal(attrs[["code.filepath"]], "/path/to/myfile.R")
+  expect_equal(attrs[["code.lineno"]], 15)
+  expect_equal(attrs[["code.column"]], 8)
+
+  # Test with function name
+  attrs_with_fn <- otel_srcref_attributes(srcref, fn_name = "myFunction")
+
+  # Preferred names
+  expect_equal(attrs_with_fn[["code.file.path"]], "/path/to/myfile.R")
+  expect_equal(attrs_with_fn[["code.line.number"]], 15)
+  expect_equal(attrs_with_fn[["code.column.number"]], 8)
+  expect_equal(attrs_with_fn[["code.function.name"]], "myFunction")
+
+  # Deprecated names
+  expect_equal(attrs_with_fn[["code.filepath"]], "/path/to/myfile.R")
+  expect_equal(attrs_with_fn[["code.lineno"]], 15)
+  expect_equal(attrs_with_fn[["code.column"]], 8)
+})
+
+test_that("otel_srcref_attributes handles NULL srcref", {
+  attrs <- otel_srcref_attributes(NULL)
+  expect_null(attrs)
+})
+
+test_that("otel_srcref_attributes extracts from function with srcref", {
+  mock_func <- function() { "test" }
+  srcref <- create_mock_srcref(
+    lines = c(42, 45),
+    columns = c(12, 30),
+    filename = "function_file.R"
+  )
+
+  with_mocked_bindings(
+    getSrcRefs = function(func) {
+      expect_identical(func, mock_func)
+      list(list(srcref))
+    },
+    {
+      attrs <- otel_srcref_attributes(mock_func)
+
+      expect_equal(attrs[["code.file.path"]], "function_file.R")
+      expect_equal(attrs[["code.line.number"]], 42)
+      expect_equal(attrs[["code.column.number"]], 12)
+      expect_false("code.function.name" %in% names(attrs))
+
+      # Test with function name
+      attrs_with_fn <- otel_srcref_attributes(
+        mock_func,
+        fn_name = "testFunction"
+      )
+
+      expect_equal(attrs_with_fn[["code.file.path"]], "function_file.R")
+      expect_equal(attrs_with_fn[["code.line.number"]], 42)
+      expect_equal(attrs_with_fn[["code.column.number"]], 12)
+      expect_equal(attrs_with_fn[["code.function.name"]], "testFunction")
+    }
+  )
+})
+
+test_that("otel_srcref_attributes handles function without srcref", {
+  mock_func <- function() { "test" }
+
+  with_mocked_bindings(
+    getSrcRefs = function(func) {
+      list(list(NULL))
+    },
+    {
+      attrs <- otel_srcref_attributes(mock_func)
+      expect_null(attrs)
+    }
+  )
+})
+
+test_that("otel_srcref_attributes handles function with empty getSrcRefs", {
+  mock_func <- function() { "test" }
+
+  with_mocked_bindings(
+    getSrcRefs = function(func) {
+      list()  # Empty list
+    },
+    {
+      expect_error(
+        otel_srcref_attributes(mock_func),
+        "subscript out of bounds|attempt to select less than one element"
+      )
+    }
+  )
+})
+
+test_that("otel_srcref_attributes validates srcref class", {
+  invalid_srcref <- structure(
+    c(10, 5, 15, 20, 5, 20),
+    class = "not_srcref"
+  )
+
+  expect_error(
+    otel_srcref_attributes(invalid_srcref),
+    "inherits\\(srcref, \"srcref\"\\) is not TRUE"
+  )
+})
+
+test_that("otel_srcref_attributes drops NULL values", {
+  # Create srcref with missing filename
+  srcref <- structure(
+    c(10, 5, 15, 20, 5, 20),
+    class = "srcref"
+  )
+  attr(srcref, "srcfile") <- list(filename = NULL)
+
+  attrs <- otel_srcref_attributes(srcref)
+
+  # Should only contain lineno and column (both preferred and deprecated)
+  expect_equal(length(attrs), 4)  # 2 preferred + 2 deprecated
+  # Preferred names
+  expect_equal(attrs[["code.line.number"]], 10)
+  expect_equal(attrs[["code.column.number"]], 5)
+  expect_false("code.file.path" %in% names(attrs))
+  expect_false("code.function.name" %in% names(attrs))
+  # Deprecated names
+  expect_equal(attrs[["code.lineno"]], 10)
+  expect_equal(attrs[["code.column"]], 5)
+  expect_false("code.filepath" %in% names(attrs))
+
+  # Test with function name - NULL fn_name should still be dropped
+  attrs_with_null_fn <- otel_srcref_attributes(srcref, fn_name = NULL)
+  expect_equal(length(attrs_with_null_fn), 4)
+  expect_false("code.function.name" %in% names(attrs_with_null_fn))
+
+  # Test with function name provided
+  attrs_with_fn <- otel_srcref_attributes(srcref, fn_name = "testFunc")
+  expect_equal(length(attrs_with_fn), 5)  # 4 location + 1 function name
+  expect_equal(attrs_with_fn[["code.function.name"]], "testFunc")
+})
+
+test_that("otel_srcref_attributes handles missing srcfile", {
+  srcref <- structure(
+    c(10, 5, 15, 20, 5, 20),
+    class = "srcref"
+  )
+  # No srcfile attribute
+
+  attrs <- otel_srcref_attributes(srcref)
+
+  # Should only contain lineno and column (both preferred and deprecated)
+  expect_equal(length(attrs), 4)  # 2 preferred + 2 deprecated
+  # Preferred names
+  expect_equal(attrs[["code.line.number"]], 10)
+  expect_equal(attrs[["code.column.number"]], 5)
+  expect_false("code.file.path" %in% names(attrs))
+  # Deprecated names
+  expect_equal(attrs[["code.lineno"]], 10)
+  expect_equal(attrs[["code.column"]], 5)
+  expect_false("code.filepath" %in% names(attrs))
+})
+
+# Integration tests with reactive functions
+test_that("reactive() captures otel attributes from source reference", {
+  # This test verifies that reactive() functions get otel attributes set
+  # We'll need to mock the internals since we can't easily control srcref in tests
+
+  x <- get_reactive_objects()$reactive
+  attrs <- attr(x, "observable")$.otelAttrs
+
+  expect_equal(attrs[["code.file.path"]], "test-otel-attr-srcref.R")
+  expect_equal(attrs[["code.line.number"]], 4)
+  expect_equal(attrs[["code.column.number"]], 3)
+  expect_equal(attrs[["code.function.name"]], "reactive")
+})
+
+test_that("reactiveVal() captures otel attributes from source reference", {
+  x <- get_reactive_objects()$reactiveVal
+
+  # Test the attribute extraction that would be used in reactiveVal
+  attrs <- attr(x, ".impl")$.otelAttrs
+
+  expect_equal(attrs[["code.file.path"]], "test-otel-attr-srcref.R")
+  expect_equal(attrs[["code.line.number"]], 5)
+  expect_equal(attrs[["code.column.number"]], 3)
+  expect_equal(attrs[["code.function.name"]], "reactiveVal")
+})
+
+test_that("reactiveValues() captures otel attributes from source reference", {
+  x <- get_reactive_objects()$reactiveValues
+
+  attrs <- .subset2(x, "impl")$.otelAttrs
+
+  expect_equal(attrs[["code.file.path"]], "test-otel-attr-srcref.R")
+  expect_equal(attrs[["code.line.number"]], 6)
+  expect_equal(attrs[["code.column.number"]], 3)
+  expect_equal(attrs[["code.function.name"]], "reactiveValues")
+})
+
+test_that("observe() captures otel attributes from source reference", {
+  x <- get_reactive_objects()$observe
+  attrs <- x$.otelAttrs
+
+  expect_equal(attrs[["code.file.path"]], "test-otel-attr-srcref.R")
+  expect_equal(attrs[["code.line.number"]], 7)
+  expect_equal(attrs[["code.column.number"]], 3)
+  expect_equal(attrs[["code.function.name"]], "observe")
+})
+
+test_that("otel attributes integration with render functions", {
+  x <- get_reactive_objects()$renderText
+  attrs <- attr(x, "otelAttrs")
+
+  expect_equal(attrs[["code.file.path"]], "test-otel-attr-srcref.R")
+  expect_equal(attrs[["code.line.number"]], 8)
+  expect_equal(attrs[["code.column.number"]], 20)
+  # Render functions should NOT have code.function.name
+  expect_false("code.function.name" %in% names(attrs))
+})
+
+test_that("observeEvent() captures otel attributes from source reference", {
+  x <- get_reactive_objects()$observeEvent
+  attrs <- x$.otelAttrs
+
+  expect_equal(attrs[["code.file.path"]], "test-otel-attr-srcref.R")
+  expect_equal(attrs[["code.line.number"]], 9)
+  expect_equal(attrs[["code.column.number"]], 3)
+  expect_equal(attrs[["code.function.name"]], "observeEvent")
+})
+
+test_that("otel attributes follow OpenTelemetry semantic conventions", {
+  # Test that the attribute names follow the official OpenTelemetry conventions
+  # https://opentelemetry.io/docs/specs/semconv/registry/attributes/code/
+
+  srcref <- create_mock_srcref(
+    lines = c(1, 1),
+    columns = c(1, 10),
+    filename = "convention_test.R"
+  )
+
+  attrs <- otel_srcref_attributes(srcref)
+
+  # Check that preferred attribute names follow the convention
+  expect_true("code.file.path" %in% names(attrs))
+  expect_true("code.line.number" %in% names(attrs))
+  expect_true("code.column.number" %in% names(attrs))
+  expect_false("code.function.name" %in% names(attrs))
+
+  # Check that deprecated names are also present
+  expect_true("code.filepath" %in% names(attrs))
+  expect_true("code.lineno" %in% names(attrs))
+  expect_true("code.column" %in% names(attrs))
+
+  # Check that values are of correct types (preferred names)
+  expect_true(is.character(attrs[["code.file.path"]]))
+  expect_true(is.numeric(attrs[["code.line.number"]]))
+  expect_true(is.numeric(attrs[["code.column.number"]]))
+
+  # Check that deprecated names have same values
+  expect_equal(attrs[["code.file.path"]], attrs[["code.filepath"]])
+  expect_equal(attrs[["code.line.number"]], attrs[["code.lineno"]])
+  expect_equal(attrs[["code.column.number"]], attrs[["code.column"]])
+
+  # Test with function name
+  attrs_with_fn <- otel_srcref_attributes(srcref, fn_name = "myFunc")
+
+  expect_true("code.function.name" %in% names(attrs_with_fn))
+  expect_true(is.character(attrs_with_fn[["code.function.name"]]))
+  expect_equal(attrs_with_fn[["code.function.name"]], "myFunc")
+})
+
+test_that("dropNulls helper works correctly in otel_srcref_attributes", {
+  # Test with all values present
+  srcref <- create_mock_srcref(
+    lines = c(5, 8),
+    columns = c(3, 15),
+    filename = "complete_test.R"
+  )
+
+  attrs <- otel_srcref_attributes(srcref)
+  expect_equal(length(attrs), 6)  # 3 preferred + 3 deprecated
+
+  # Test with missing filename (NULL)
+  srcref_no_file <- structure(
+    c(5, 3, 8, 15, 3, 15),
+    class = "srcref"
+  )
+  attr(srcref_no_file, "srcfile") <- list(filename = NULL)
+
+  attrs_no_file <- otel_srcref_attributes(srcref_no_file)
+  expect_equal(length(attrs_no_file), 4)  # 2 preferred + 2 deprecated
+  expect_false("code.file.path" %in% names(attrs_no_file))
+  expect_false("code.filepath" %in% names(attrs_no_file))
+})
+
+test_that("otel attributes are used in reactive context execution", {
+  # Test that otel attributes are properly passed through to spans
+  mock_attrs <- list(
+    "code.file.path" = "context_test.R",
+    "code.line.number" = 42L,
+    "code.column.number" = 8L
+  )
+
+  # Test the context info structure used in react.R
+  otel_info <- ctx_otel_info_obj(
+    isRecordingOtel = TRUE,
+    otelLabel = "test_reactive",
+    otelAttrs = mock_attrs
+  )
+
+  expect_true(otel_info$isRecordingOtel)
+  expect_equal(otel_info$otelLabel, "test_reactive")
+  expect_equal(otel_info$otelAttrs, mock_attrs)
+  expect_equal(class(otel_info), "ctx_otel_info")
+})
+
+test_that("otel attributes are combined with session attributes", {
+  # Test that otel srcref attributes are properly combined with session attributes
+  # as happens in the reactive system
+
+  srcref_attrs <- list(
+    "code.file.path" = "session_test.R",
+    "code.line.number" = 15L,
+    "code.column.number" = 5L
+  )
+
+  session_attrs <- list(
+    "session.id" = "test-session-123"
+  )
+
+  # Simulate the combination as done in reactives.R
+  combined_attrs <- c(srcref_attrs, session_attrs)
+
+  expect_equal(length(combined_attrs), 4)
+  expect_equal(combined_attrs[["code.file.path"]], "session_test.R")
+  expect_equal(combined_attrs[["code.line.number"]], 15L)
+  expect_equal(combined_attrs[["session.id"]], "test-session-123")
+})
+
+test_that("eventReactive() captures otel attributes from source reference", {
+  x <- get_reactive_objects()$eventReactive
+  attrs <- attr(x, "observable")$.otelAttrs
+
+  expect_equal(attrs[["code.file.path"]], "test-otel-attr-srcref.R")
+  expect_equal(attrs[["code.line.number"]], 10)
+  expect_equal(attrs[["code.column.number"]], 3)
+  expect_equal(attrs[["code.function.name"]], "eventReactive")
+})
+
+test_that("renderText() with bindCache() captures otel attributes", {
+  x <- get_reactive_objects()$renderCacheA
+  attrs <- attr(x, "otelAttrs")
+
+  expect_equal(attrs[["code.file.path"]], "test-otel-attr-srcref.R")
+  expect_gt(attrs[["code.line.number"]], 12)
+  expect_false("code.function.name" %in% names(attrs))
+})
+
+test_that("renderText() with bindEvent() captures otel attributes", {
+  x <- get_reactive_objects()$renderEventA
+  attrs <- attr(x, "otelAttrs")
+
+  expect_equal(attrs[["code.file.path"]], "test-otel-attr-srcref.R")
+  expect_gt(attrs[["code.line.number"]], 12)
+  expect_false("code.function.name" %in% names(attrs))
+})
+
+test_that(
+  "renderText() with bindCache() |> bindEvent() captures otel attributes",
+  {
+    x <- get_reactive_objects()$renderCacheEventA
+    attrs <- attr(x, "otelAttrs")
+
+    expect_equal(attrs[["code.file.path"]], "test-otel-attr-srcref.R")
+    expect_gt(attrs[["code.line.number"]], 12)
+    expect_false("code.function.name" %in% names(attrs))
+  }
+)
+
+test_that("bindCache() wrapping renderText() captures otel attributes", {
+  x <- get_reactive_objects()$renderCacheB
+  attrs <- attr(x, "otelAttrs")
+
+  expect_equal(attrs[["code.file.path"]], "test-otel-attr-srcref.R")
+  expect_gt(attrs[["code.line.number"]], 12)
+  expect_false("code.function.name" %in% names(attrs))
+})
+
+test_that("bindEvent() wrapping renderText() captures otel attributes", {
+  x <- get_reactive_objects()$renderEventB
+  attrs <- attr(x, "otelAttrs")
+
+  expect_equal(attrs[["code.file.path"]], "test-otel-attr-srcref.R")
+  expect_gt(attrs[["code.line.number"]], 12)
+  expect_false("code.function.name" %in% names(attrs))
+})
+
+test_that(
+  "bindEvent() wrapping bindCache(renderText()) captures otel attributes",
+  {
+    x <- get_reactive_objects()$renderCacheEventB
+    attrs <- attr(x, "otelAttrs")
+
+    expect_equal(attrs[["code.file.path"]], "test-otel-attr-srcref.R")
+    expect_gt(attrs[["code.line.number"]], 12)
+    expect_false("code.function.name" %in% names(attrs))
+  }
+)
+
+test_that("observe() with bindEvent() captures otel attributes", {
+  x <- get_reactive_objects()$observeEventA
+  attrs <- x$.otelAttrs
+
+  expect_equal(attrs[["code.file.path"]], "test-otel-attr-srcref.R")
+  expect_gt(attrs[["code.line.number"]], 12)
+  expect_equal(attrs[["code.function.name"]], "bindEvent")
+})
+
+test_that("bindEvent() wrapping observe() captures otel attributes", {
+  x <- get_reactive_objects()$observeEventB
+  attrs <- x$.otelAttrs
+
+  expect_equal(attrs[["code.file.path"]], "test-otel-attr-srcref.R")
+  expect_gt(attrs[["code.line.number"]], 12)
+  expect_equal(attrs[["code.function.name"]], "bindEvent")
+})
+
+test_that("reactive() with bindCache() captures otel attributes", {
+  x <- get_reactive_objects()$reactiveCacheA
+  attrs <- attr(x, "observable")$.otelAttrs
+
+  expect_equal(attrs[["code.file.path"]], "test-otel-attr-srcref.R")
+  expect_gt(attrs[["code.line.number"]], 12)
+  expect_equal(attrs[["code.function.name"]], "bindCache")
+})
+
+test_that("reactive() with bindEvent() captures otel attributes", {
+  x <- get_reactive_objects()$reactiveEventA
+  attrs <- attr(x, "observable")$.otelAttrs
+
+  expect_equal(attrs[["code.file.path"]], "test-otel-attr-srcref.R")
+  expect_gt(attrs[["code.line.number"]], 12)
+  expect_equal(attrs[["code.function.name"]], "bindEvent")
+})
+
+test_that(
+  "reactive() with bindCache() |> bindEvent() captures otel attributes",
+  {
+    x <- get_reactive_objects()$reactiveCacheEventA
+    attrs <- attr(x, "observable")$.otelAttrs
+
+    expect_equal(attrs[["code.file.path"]], "test-otel-attr-srcref.R")
+    expect_gt(attrs[["code.line.number"]], 12)
+    expect_equal(attrs[["code.function.name"]], "bindEvent")
+  }
+)
+
+test_that("bindCache() wrapping reactive() captures otel attributes", {
+  x <- get_reactive_objects()$reactiveCacheB
+  attrs <- attr(x, "observable")$.otelAttrs
+
+  expect_equal(attrs[["code.file.path"]], "test-otel-attr-srcref.R")
+  expect_gt(attrs[["code.line.number"]], 12)
+  expect_equal(attrs[["code.function.name"]], "bindCache")
+})
+
+test_that("bindEvent() wrapping reactive() captures otel attributes", {
+  x <- get_reactive_objects()$reactiveEventB
+  attrs <- attr(x, "observable")$.otelAttrs
+
+  expect_equal(attrs[["code.file.path"]], "test-otel-attr-srcref.R")
+  expect_gt(attrs[["code.line.number"]], 12)
+  expect_equal(attrs[["code.function.name"]], "bindEvent")
+})
+
+test_that(
+  "bindEvent() wrapping bindCache(reactive()) captures otel attributes",
+  {
+    x <- get_reactive_objects()$reactiveCacheEventB
+    attrs <- attr(x, "observable")$.otelAttrs
+
+    expect_equal(attrs[["code.file.path"]], "test-otel-attr-srcref.R")
+    expect_gt(attrs[["code.line.number"]], 12)
+    expect_equal(attrs[["code.function.name"]], "bindEvent")
+  }
+)
+
+# Tests for debounce/throttle
+test_that("debounce() creates new reactive with otel attributes", {
+  x <- get_reactive_objects()$debounce
+  attrs <- attr(x, "observable")$.otelAttrs
+
+  expect_equal(attrs[["code.file.path"]], "test-otel-attr-srcref.R")
+  expect_gt(attrs[["code.line.number"]], 12)
+  expect_equal(attrs[["code.function.name"]], "debounce")
+})
+
+test_that("throttle() creates new reactive with otel attributes", {
+  x <- get_reactive_objects()$throttle
+  attrs <- attr(x, "observable")$.otelAttrs
+
+  expect_equal(attrs[["code.file.path"]], "test-otel-attr-srcref.R")
+  expect_gt(attrs[["code.line.number"]], 12)
+  expect_equal(attrs[["code.function.name"]], "throttle")
+})
+
+# Tests for ExtendedTask
+test_that("ExtendedTask is created and is an R6 object", {
+  x <- get_reactive_objects()$extendedTask
+  expect_s3_class(x, "ExtendedTask")
+  expect_s3_class(x, "R6")
+
+  attrs <- .subset2(x, ".__enclos_env__")$private$otel_attrs
+
+  expect_equal(attrs[["code.file.path"]], "test-otel-attr-srcref.R")
+  expect_gt(attrs[["code.line.number"]], 12)
+  expect_equal(attrs[["code.function.name"]], "ExtendedTask")
+})
+
+# Tests for reactivePoll
+test_that("reactivePoll() captures otel attributes from source reference", {
+  x <- get_reactive_objects()$reactivePoll
+  impl <- attr(x, "observable", exact = TRUE)
+  attrs <- impl$.otelAttrs
+  otelLabel <- impl$.otelLabel
+
+  expect_equal(as.character(otelLabel), "reactivePoll r_poll")
+
+  expect_equal(attrs[["code.file.path"]], "test-otel-attr-srcref.R")
+  expect_gt(attrs[["code.line.number"]], 12)
+  expect_equal(attrs[["code.function.name"]], "reactivePoll")
+})
+
+# Tests for reactiveFileReader
+test_that("reactiveFileReader() captures otel attributes from source reference", {
+  x <- get_reactive_objects()$reactiveFileReader
+  impl <- attr(x, "observable", exact = TRUE)
+  attrs <- impl$.otelAttrs
+  otelLabel <- impl$.otelLabel
+
+  expect_equal(as.character(otelLabel), "reactiveFileReader r_file")
+
+  expect_equal(attrs[["code.file.path"]], "test-otel-attr-srcref.R")
+  expect_gt(attrs[["code.line.number"]], 12)
+  expect_equal(attrs[["code.function.name"]], "reactiveFileReader")
+})
+
+# Tests for explicit labels
+test_that("reactive() with explicit label still captures otel attributes", {
+  x <- get_reactive_objects()$reactiveLabeled
+  attrs <- attr(x, "observable")$.otelAttrs
+
+  expect_equal(attrs[["code.file.path"]], "test-otel-attr-srcref.R")
+  expect_equal(attrs[["code.line.number"]], 38)
+  expect_equal(attrs[["code.column.number"]], 3)
+  expect_equal(attrs[["code.function.name"]], "reactive")
+
+  # Verify label is preserved
+  label <- attr(x, "observable")$.label
+  expect_equal(as.character(label), "my_reactive")
+})
+
+test_that("observe() with explicit label still captures otel attributes", {
+  x <- get_reactive_objects()$observeLabeled
+  attrs <- x$.otelAttrs
+
+  expect_equal(attrs[["code.file.path"]], "test-otel-attr-srcref.R")
+  expect_equal(attrs[["code.line.number"]], 39)
+  expect_equal(attrs[["code.column.number"]], 3)
+  expect_equal(attrs[["code.function.name"]], "observe")
+
+  # Verify label is preserved
+  expect_equal(x$.label, "my_observer")
+})
+
+# Edge case tests
+test_that("reactive created inside function captures function srcref", {
+  create_reactive <- function() {
+    reactive({ 100 })
+  }
+
+  r <- create_reactive()
+  attrs <- attr(r, "observable")$.otelAttrs
+
+  expect_equal(attrs[["code.file.path"]], "test-otel-attr-srcref.R")
+  # Line number should point to where reactive() is called inside the function
+  expect_true(is.numeric(attrs[["code.line.number"]]))
+  expect_true(is.numeric(attrs[["code.column.number"]]))
+})
+
+test_that("observe created inside function captures function srcref", {
+  create_observer <- function() {
+    observe({ 101 })
+  }
+
+  o <- create_observer()
+  attrs <- o$.otelAttrs
+
+  expect_equal(attrs[["code.file.path"]], "test-otel-attr-srcref.R")
+  expect_true(is.numeric(attrs[["code.line.number"]]))
+  expect_true(is.numeric(attrs[["code.column.number"]]))
+})
+
+test_that("reactive returned from function preserves srcref", {
+  make_counter <- function(initial = 0) {
+    reactive({ initial + 1 })
+  }
+
+  counter <- make_counter(42)
+  attrs <- attr(counter, "observable")$.otelAttrs
+
+  expect_equal(attrs[["code.file.path"]], "test-otel-attr-srcref.R")
+  expect_true(is.numeric(attrs[["code.line.number"]]))
+})
+
+test_that("reactiveVal created in function captures srcref", {
+  create_val <- function() {
+    reactiveVal("initial")
+  }
+
+  rv <- create_val()
+  attrs <- attr(rv, ".impl")$.otelAttrs
+
+  expect_equal(attrs[["code.file.path"]], "test-otel-attr-srcref.R")
+  expect_true(is.numeric(attrs[["code.line.number"]]))
+})
+
+test_that("nested reactive expressions preserve individual srcrefs", {
+  outer_reactive <- reactive({
+    inner_reactive <- reactive({ 200 })
+    inner_reactive
+  })
+
+  outer_attrs <- attr(outer_reactive, "observable")$.otelAttrs
+  expect_equal(outer_attrs[["code.file.path"]], "test-otel-attr-srcref.R")
+  expect_true(is.numeric(outer_attrs[["code.line.number"]]))
+
+  # Get the inner reactive by executing outer
+  withReactiveDomain(MockShinySession$new(), {
+    inner_reactive <- isolate(outer_reactive())
+    inner_attrs <- attr(inner_reactive, "observable")$.otelAttrs
+
+    expect_equal(inner_attrs[["code.file.path"]], "test-otel-attr-srcref.R")
+    expect_true(is.numeric(inner_attrs[["code.line.number"]]))
+    # Inner should have different line number than outer
+    expect_false(inner_attrs[["code.line.number"]] == outer_attrs[["code.line.number"]])
+  })
+})

tests/testthat/test-otel-collect.R

@@ -0,0 +1,142 @@
+test_that("otel_collect_is_enabled works with valid collect levels", {
+  # Test with default "all" option
+  expect_true(otel_collect_is_enabled("none"))
+  expect_true(otel_collect_is_enabled("session"))
+  expect_true(otel_collect_is_enabled("reactive_update"))
+  expect_true(otel_collect_is_enabled("reactivity"))
+  expect_true(otel_collect_is_enabled("all"))
+})
+
+test_that("otel_collect_is_enabled respects hierarchy with 'none' option", {
+  # With "none" option, nothing should be enabled
+  expect_false(otel_collect_is_enabled("session", "none"))
+  expect_false(otel_collect_is_enabled("reactive_update", "none"))
+  expect_false(otel_collect_is_enabled("reactivity", "none"))
+  expect_false(otel_collect_is_enabled("all", "none"))
+  expect_true(otel_collect_is_enabled("none", "none"))
+})
+
+test_that("otel_collect_is_enabled respects hierarchy with 'session' option", {
+  # With "session" option, only "none" and "session" should be enabled
+  expect_true(otel_collect_is_enabled("none", "session"))
+  expect_true(otel_collect_is_enabled("session", "session"))
+  expect_false(otel_collect_is_enabled("reactive_update", "session"))
+  expect_false(otel_collect_is_enabled("reactivity", "session"))
+  expect_false(otel_collect_is_enabled("all", "session"))
+})
+
+test_that("otel_collect_is_enabled respects hierarchy with 'reactive_update' option", {
+  # With "reactive_update" option, "none", "session", and "reactive_update" should be enabled
+  expect_true(otel_collect_is_enabled("none", "reactive_update"))
+  expect_true(otel_collect_is_enabled("session", "reactive_update"))
+  expect_true(otel_collect_is_enabled("reactive_update", "reactive_update"))
+  expect_false(otel_collect_is_enabled("reactivity", "reactive_update"))
+  expect_false(otel_collect_is_enabled("all", "reactive_update"))
+})
+
+test_that("otel_collect_is_enabled respects hierarchy with 'reactivity' option", {
+  # With "reactivity" option, all except "all" should be enabled
+  expect_true(otel_collect_is_enabled("none", "reactivity"))
+  expect_true(otel_collect_is_enabled("session", "reactivity"))
+  expect_true(otel_collect_is_enabled("reactive_update", "reactivity"))
+  expect_true(otel_collect_is_enabled("reactivity", "reactivity"))
+  expect_false(otel_collect_is_enabled("all", "reactivity"))
+})
+
+test_that("otel_collect_is_enabled respects hierarchy with 'all' option", {
+  # With "all" option (default), everything should be enabled
+  expect_true(otel_collect_is_enabled("none", "all"))
+  expect_true(otel_collect_is_enabled("session", "all"))
+  expect_true(otel_collect_is_enabled("reactive_update", "all"))
+  expect_true(otel_collect_is_enabled("reactivity", "all"))
+  expect_true(otel_collect_is_enabled("all", "all"))
+})
+
+test_that("otel_collect_is_enabled uses shiny.otel.collect option", {
+  # Test that option is respected
+  withr::with_options(
+    list(shiny.otel.collect = "session"),
+    {
+      expect_true(otel_collect_is_enabled("none"))
+      expect_true(otel_collect_is_enabled("session"))
+      expect_false(otel_collect_is_enabled("reactive_update"))
+    }
+  )
+
+  withr::with_options(
+    list(shiny.otel.collect = "reactivity"),
+    {
+      expect_true(otel_collect_is_enabled("reactive_update"))
+      expect_true(otel_collect_is_enabled("reactivity"))
+      expect_false(otel_collect_is_enabled("all"))
+    }
+  )
+})
+
+test_that("otel_collect_is_enabled falls back to SHINY_OTEL_COLLECT env var", {
+  # Remove option to test env var fallback
+  withr::local_options(list(shiny.otel.collect = NULL))
+
+  # Test env var is respected
+  withr::local_envvar(list(SHINY_OTEL_COLLECT = "session"))
+  expect_true(otel_collect_is_enabled("none"))
+  expect_true(otel_collect_is_enabled("session"))
+  expect_false(otel_collect_is_enabled("reactive_update"))
+
+  withr::local_envvar(list(SHINY_OTEL_COLLECT = "none"))
+  expect_true(otel_collect_is_enabled("none"))
+  expect_false(otel_collect_is_enabled("session"))
+})
+
+test_that("otel_collect_is_enabled option takes precedence over env var", {
+  # Set conflicting option and env var
+  withr::local_options(shiny.otel.collect = "session")
+  withr::local_envvar(SHINY_OTEL_COLLECT = "all")
+
+  # Option should take precedence
+  expect_true(otel_collect_is_enabled("session"))
+  expect_false(otel_collect_is_enabled("reactive_update"))
+})
+
+test_that("otel_collect_is_enabled defaults to 'all' when no option or env var", {
+  # Remove both option and env var
+  withr::local_options(list(shiny.otel.collect = NULL))
+  withr::local_envvar(list(SHINY_OTEL_COLLECT = NA))
+
+  # Should default to "all"
+  expect_true(otel_collect_is_enabled("all"))
+  expect_true(otel_collect_is_enabled("reactivity"))
+  expect_true(otel_collect_is_enabled("none"))
+})
+
+# Tests for as_otel_collect()
+test_that("as_otel_collect validates and returns valid collect levels", {
+  expect_equal(as_otel_collect("none"), "none")
+  expect_equal(as_otel_collect("session"), "session")
+  expect_equal(as_otel_collect("reactive_update"), "reactive_update")
+  expect_equal(as_otel_collect("reactivity"), "reactivity")
+  expect_equal(as_otel_collect("all"), "all")
+})
+
+test_that("as_otel_collect uses default value", {
+  expect_equal(as_otel_collect(), "all")
+})
+
+test_that("as_otel_collect errors on invalid input types", {
+  expect_error(as_otel_collect(123), "`collect` must be a character vector.")
+  expect_error(as_otel_collect(NULL), "`collect` must be a character vector.")
+  expect_error(as_otel_collect(TRUE), "`collect` must be a character vector.")
+  expect_error(as_otel_collect(list("all")), "`collect` must be a character vector.")
+})
+
+test_that("as_otel_collect errors on invalid collect levels", {
+  expect_error(as_otel_collect("invalid"), "'arg' should be one of")
+  expect_error(as_otel_collect("unknown"), "'arg' should be one of")
+  expect_error(as_otel_collect(""), "'arg' should be one of")
+})
+
+test_that("as_otel_collect errors on multiple values", {
+  # match.arg with several.ok = FALSE should error on multiple values
+  expect_error(as_otel_collect(c("all", "none")), "'arg' must be of length 1")
+  expect_error(as_otel_collect(c("session", "reactivity")), "'arg' must be of length 1")
+})

tests/testthat/test-otel-error.R

@@ -0,0 +1,231 @@
+skip_on_cran()
+skip_if_not_installed("otelsdk")
+
+create_mock_session <- function() {
+  session <- MockShinySession$new()
+  session$token <- "test-session-token"
+  session
+}
+
+expect_session_warning <- function(session, warning) {
+  testthat::expect_warning(
+    capture.output(
+      type = "message",
+      {
+        session$flushReact()
+      }
+    ),
+    warning
+  )
+}
+
+exception_trace_events <- function(traces) {
+  unlist(lapply(traces, function(trace) {
+    if (is.null(trace$events)) return(list())
+    events <- Filter(function(event) {
+      !is.null(event$attributes) &&
+        !is.null(event$attributes[["exception.message"]])
+    }, trace$events)
+    events
+  }), recursive = FALSE)
+}
+
+test_server_with_otel_error <- function(session, server, expr, sanitize = FALSE, args = list()) {
+  stopifnot(inherits(session, "MockShinySession"))
+  stopifnot(is.function(server))
+
+  traces <- with_shiny_otel_record({ 42 })$traces
+  expect_length(traces, 0)
+
+  withr::with_options(
+    list(
+      shiny.otel.collect = "all",
+      shiny.otel.sanitize.errors = sanitize
+    ),
+    {
+      info <- with_shiny_otel_record({
+        # rlang quosure magic to capture and pass through `expr`
+        testServer(server, {{ expr }}, args = args, session = session)
+      })
+    }
+  )
+
+  info$traces
+}
+
+
+test_that("mark_otel_exception_as_seen() returns modified condition", {
+  cnd <- simpleError("test error")
+  result <- mark_otel_exception_as_seen(cnd)
+
+  expect_true(inherits(result, "error"))
+  expect_true(inherits(result, "condition"))
+  expect_equal(conditionMessage(result), "test error")
+  expect_true(isTRUE(result$.shiny_otel_exception))
+})
+
+test_that("mark_otel_exception_as_seen() marks error as seen", {
+  cnd <- simpleError("test error")
+  expect_false(has_seen_otel_exception(cnd))
+
+  cnd <- mark_otel_exception_as_seen(cnd)
+  expect_true(has_seen_otel_exception(cnd))
+})
+
+
+test_that("set_otel_exception_status() records sanitized errors by default", {
+  server <- function(input, output, session) {
+    r1 <- reactive(label = "r1", {
+      stop("test error in r1")
+    })
+
+    r2 <- reactive(label = "r2", {
+      r1()
+    })
+
+    observe(label = "obs", {
+      r2()
+    })
+  }
+
+  session <- create_mock_session()
+  traces <- test_server_with_otel_error(
+    sanitize = NULL,
+    session,
+    server,
+    {
+      # Expect an error to be thrown as warning
+      expect_session_warning(session, "test error in r1")
+    }
+  )
+
+  # IDK why, I don't have time to debug
+  skip_if(length(traces) > 3, "Too many traces collected; otelsdk traces are polluted. Run in single test file only: testthat::test_file(testthat::test_path('test-otel-error.R'))`")
+
+  # Find traces with exception events (should only be one)
+  exception_events <- exception_trace_events(traces)
+
+  # Exception should be recorded only once at the original point of failure
+  expect_equal(length(exception_events), 1)
+  expect_match(
+    exception_events[[1]]$attributes[["exception.message"]],
+    "Check your logs or contact the app author for clarification."
+  )
+})
+
+test_that("set_otel_exception_status() records exception only once in reactive context", {
+  server <- function(input, output, session) {
+    r1 <- reactive(label = "r1", {
+      stop("test error in r1")
+    })
+
+    r2 <- reactive(label = "r2", {
+      r1()
+    })
+
+    observe(label = "obs", {
+      r2()
+    })
+  }
+
+  session <- create_mock_session()
+  traces <- test_server_with_otel_error(session, server, {
+    # Expect an error to be thrown as warning
+    expect_session_warning(session, "test error in r1")
+  })
+
+  # Find traces with error status
+  for (trace in traces) {
+    expect_equal(trace$status, "error")
+  }
+
+  # Find traces with exception events (should only be one)
+  exception_events <- exception_trace_events(traces)
+
+  # Exception should be recorded only once at the original point of failure
+  expect_equal(length(exception_events), 1)
+  expect_match(
+    exception_events[[1]]$attributes[["exception.message"]],
+    "test error in r1"
+  )
+})
+
+test_that("set_otel_exception_status() records exception for multiple independent errors", {
+  server <- function(input, output, session) {
+    r1 <- reactive(label = "r1", {
+      stop("error in r1")
+    })
+
+    r2 <- reactive(label = "r2", {
+      stop("error in r2")
+    })
+
+    observe(label = "obs1", {
+      r1()
+    })
+
+    observe(label = "obs2", {
+      r2()
+    })
+  }
+
+  session <- create_mock_session()
+  traces <- test_server_with_otel_error(session, server, {
+    # Both observers should error
+    expect_session_warning(session, "error in r1")
+  })
+
+  # Find traces with exception events
+  exception_events <- exception_trace_events(traces)
+
+  # Each unique error should be recorded once
+  expect_gte(length(exception_events), 1)
+})
+
+test_that("set_otel_exception_status() does not record shiny.custom.error", {
+  server <- function(input, output, session) {
+    r <- reactive(label = "r", {
+      cnd <- simpleError("custom error")
+      class(cnd) <- c("shiny.custom.error", class(cnd))
+      stop(cnd)
+    })
+
+    observe(label = "obs", {
+      r()
+    })
+  }
+
+  session <- create_mock_session()
+  traces <- test_server_with_otel_error(session, server, {
+    expect_session_warning(session, "custom error")
+  })
+
+  # Find traces with error status (should be none for custom errors)
+  for (trace in traces) {
+    expect_true(trace$status != "error")
+  }
+})
+
+test_that("set_otel_exception_status() does not record shiny.silent.error", {
+  server <- function(input, output, session) {
+    r <- reactive(label = "r", {
+      cnd <- simpleError("silent error")
+      class(cnd) <- c("shiny.silent.error", class(cnd))
+      stop(cnd)
+    })
+
+    observe(label = "obs", {
+      r()
+    })
+  }
+
+  session <- create_mock_session()
+  traces <- test_server_with_otel_error(session, server, {
+    expect_no_error(session$flushReact())
+  })
+
+  # Find traces with error status (should be none for silent errors)
+  for (trace in traces) {
+    expect_true(trace$status != "error")
+  }
+})

tests/testthat/test-otel-extended-task.R

@@ -0,0 +1,220 @@
+# Tests for ExtendedTask otel behavior
+
+ex_task_42 <- function() {
+  ExtendedTask$new(function() {
+    promises::promise_resolve(42)
+  })
+}
+
+test_that("ExtendedTask captures otel collection state at initialization", {
+  # Test that has_otel_collect is called at init, not at invoke time
+  withr::local_options(list(shiny.otel.collect = "reactivity"))
+
+  # Enable otel tracing
+  local_mocked_bindings(
+    otel_is_tracing_enabled = function() TRUE
+  )
+
+  task <- ex_task_42()
+
+  # Check that is_recording_otel is captured at init time
+  expect_true(task$.__enclos_env__$private$is_recording_otel)
+})
+
+test_that("ExtendedTask sets is_recording_otel to FALSE when otel disabled", {
+  # Enable otel tracing
+  local_mocked_bindings(
+    otel_is_tracing_enabled = function() FALSE
+  )
+
+  # Test with all level
+  withr::with_options(list(shiny.otel.collect = "all"), {
+    task1 <- ex_task_42()
+    expect_false(task1$.__enclos_env__$private$is_recording_otel)
+  })
+
+  # Test with reactivity level
+  withr::with_options(list(shiny.otel.collect = "reactivity"), {
+    task1 <- ex_task_42()
+    expect_false(task1$.__enclos_env__$private$is_recording_otel)
+  })
+
+  # Test with session level (should be FALSE)
+  withr::with_options(list(shiny.otel.collect = "session"), {
+    task2 <- ex_task_42()
+    expect_false(task2$.__enclos_env__$private$is_recording_otel)
+  })
+
+  # Test with none level (should be FALSE)
+  withr::with_options(list(shiny.otel.collect = "none"), {
+    task3 <- ex_task_42()
+    expect_false(task3$.__enclos_env__$private$is_recording_otel)
+  })
+})
+
+test_that("ExtendedTask sets is_recording_otel based on has_otel_collect at init", {
+  # Enable otel tracing
+  local_mocked_bindings(
+    otel_is_tracing_enabled = function() TRUE
+  )
+
+  # Test with all level
+  withr::with_options(list(shiny.otel.collect = "all"), {
+    task1 <- ex_task_42()
+    expect_true(task1$.__enclos_env__$private$is_recording_otel)
+  })
+
+  # Test with reactivity level
+  withr::with_options(list(shiny.otel.collect = "reactivity"), {
+    task1 <- ex_task_42()
+    expect_true(task1$.__enclos_env__$private$is_recording_otel)
+  })
+
+  # Test with session level (should be FALSE)
+  withr::with_options(list(shiny.otel.collect = "session"), {
+    task2 <- ex_task_42()
+    expect_false(task2$.__enclos_env__$private$is_recording_otel)
+  })
+
+  # Test with none level (should be FALSE)
+  withr::with_options(list(shiny.otel.collect = "none"), {
+    task3 <- ex_task_42()
+    expect_false(task3$.__enclos_env__$private$is_recording_otel)
+  })
+})
+
+test_that("ExtendedTask uses init-time otel setting even if option changes later", {
+
+  # Enable otel tracing
+  local_mocked_bindings(
+    otel_is_tracing_enabled = function() TRUE
+  )
+
+  # Test that changing the option after init doesn't affect the task
+  withr::with_options(list(shiny.otel.collect = "reactivity"), {
+    task <- ex_task_42()
+  })
+
+  # Capture the initial state
+  expect_true(task$.__enclos_env__$private$is_recording_otel)
+
+  # Change the option after initialization
+  withr::with_options(list(shiny.otel.collect = "none"), {
+    # The task should still have the init-time setting
+    expect_true(task$.__enclos_env__$private$is_recording_otel)
+  })
+
+})
+
+test_that("ExtendedTask respects session level otel collection", {
+  # Test that session level doesn't enable reactivity spans
+  withr::local_options(list(shiny.otel.collect = "session"))
+
+  task <- ex_task_42()
+
+  # Should not record otel at session level
+  expect_false(task$.__enclos_env__$private$is_recording_otel)
+})
+
+test_that("ExtendedTask respects reactive_update level otel collection", {
+  # Test that reactive_update level doesn't enable reactivity spans
+  withr::local_options(list(shiny.otel.collect = "reactive_update"))
+
+  task <- ex_task_42()
+
+  # Should not record otel at reactive_update level
+  expect_false(task$.__enclos_env__$private$is_recording_otel)
+})
+
+test_that("ExtendedTask creates span only when is_recording_otel is TRUE", {
+  skip_if_not_installed("otelsdk")
+  # Test that span is only created when otel is enabled
+  withr::local_options(list(shiny.otel.collect = "reactivity"))
+
+  span_created <- FALSE
+
+  local_mocked_bindings(
+    start_otel_span = function(...) {
+      span_created <<- TRUE
+      create_mock_otel_span("extended_task")
+    },
+    otel_is_tracing_enabled = function() TRUE
+  )
+
+  with_shiny_otel_record({
+    withReactiveDomain(MockShinySession$new(), {
+      task <- ex_task_42()
+
+      # Reset the flag
+      span_created <- FALSE
+
+      # Invoke the task
+      isolate({
+        task$invoke()
+      })
+    })
+  })
+
+
+  # Span should have been created because is_recording_otel is TRUE
+  expect_true(span_created)
+})
+
+test_that("ExtendedTask does not create span when is_recording_otel is FALSE", {
+  # Test that span is not created when otel is disabled
+  withr::local_options(list(shiny.otel.collect = "none"))
+
+  span_created <- FALSE
+
+  local_mocked_bindings(
+    start_otel_span = function(...) {
+      span_created <<- TRUE
+      create_mock_otel_span("extended_task")
+    }
+  )
+
+  withReactiveDomain(MockShinySession$new(), {
+    task <- ex_task_42()
+
+    # Invoke the task
+    isolate({
+      task$invoke()
+    })
+  })
+
+  # Span should not have been created because is_recording_otel is FALSE
+  expect_false(span_created)
+})
+
+
+test_that("Multiple ExtendedTask invocations use same is_recording_otel value", {
+  # Enable otel tracing
+  withr::local_options(list(shiny.otel.collect = "reactivity"))
+  local_mocked_bindings(
+    otel_is_tracing_enabled = function() TRUE
+  )
+
+  withReactiveDomain(MockShinySession$new(), {
+    task <- ex_task_42()
+
+    # Verify is_recording_otel is TRUE at init
+    expect_true(task$.__enclos_env__$private$is_recording_otel)
+
+    # Change option after initialization (should not affect the task)
+    withr::with_options(
+      list(shiny.otel.collect = "none"),
+      {
+        # The task should still have the init-time setting
+        expect_true(task$.__enclos_env__$private$is_recording_otel)
+
+        # Verify is_recording_otel doesn't change on invocation
+        isolate({
+          task$invoke()
+        })
+
+        # Still should be TRUE after invoke
+        expect_true(task$.__enclos_env__$private$is_recording_otel)
+      }
+    )
+  })
+})

tests/testthat/test-otel-label.R

@@ -0,0 +1,284 @@
+# Tests for label methods used in otel-collect.R
+test_that("otel_span_label_reactive generates correct labels", {
+  # Create mock reactive with observable attribute
+  x_reactive <- reactive({ 42 })
+
+  # Create mock observable with label
+  x_observe <- observe({ 42 })
+
+  # Test without domain
+  result <- otel_span_label_reactive(x_reactive, domain = MockShinySession$new())
+  expect_equal(result, "reactive mock-session:x_reactive")
+
+  # Test with cache class
+  x_reactive_cache <- bindCache(x_reactive, {"cacheKey"})
+  result <- otel_span_label_reactive(x_reactive_cache, domain = NULL)
+  expect_equal(result, "reactive cache x_reactive_cache")
+
+  x_reactive_cache <- x_reactive |> bindCache({"cacheKey"})
+  result <- otel_span_label_reactive(x_reactive_cache, domain = NULL)
+  expect_equal(result, "reactive cache x_reactive_cache")
+  x_reactive_cache <- reactive({42}) |> bindCache({"cacheKey"})
+  result <- otel_span_label_reactive(x_reactive_cache, domain = NULL)
+  expect_equal(result, "reactive cache x_reactive_cache")
+
+  # Test with event class
+  x_reactive_event <- bindEvent(x_reactive, {"eventKey"})
+  result <- otel_span_label_reactive(x_reactive_event, domain = NULL)
+  expect_equal(result, "reactive event x_reactive_event")
+  x_reactive_event <- x_reactive |> bindEvent({"eventKey"})
+  result <- otel_span_label_reactive(x_reactive_event, domain = NULL)
+  expect_equal(result, "reactive event x_reactive_event")
+  result <- otel_span_label_reactive(x_reactive |> bindEvent({"eventKey"}), domain = NULL)
+  expect_equal(result, "reactive event <anonymous>")
+  x_reactive_event <- reactive({42}) |> bindEvent({"eventKey"})
+  result <- otel_span_label_reactive(x_reactive_event, domain = NULL)
+  expect_equal(result, "reactive event x_reactive_event")
+
+  # x_reactive_both <- bindCache(bindEvent(x_reactive, {"eventKey"}), {"cacheKey"})
+  # result <- otel_span_label_reactive(x_reactive_both, domain = NULL)
+  # expect_equal(result, "reactive event cache x_reactive_both")
+
+  x_reactive_both2 <- bindEvent(bindCache(x_reactive, {"cacheKey"}), {"eventKey"})
+  result <- otel_span_label_reactive(x_reactive_both2, domain = NULL)
+  expect_equal(result, "reactive cache event x_reactive_both2")
+})
+
+test_that("reactive bindCache labels are created", {
+  x_reactive <- reactive({ 42 })
+  x_reactive_cache <- bindCache(x_reactive, {"cacheKey"})
+
+  expect_equal(
+    as.character(attr(x_reactive_cache, "observable")$.label),
+    "x_reactive_cache"
+  )
+
+  f_cache <- function() {
+    bindCache(x_reactive, {"cacheKey"})
+  }
+  x_reactive_cache <- f_cache()
+  expect_equal(
+    as.character(attr(x_reactive_cache, "observable")$.label),
+    "cachedReactive(x_reactive)"
+  )
+  expect_equal(
+    otel_span_label_reactive(x_reactive_cache, domain = NULL),
+    "reactive cache <anonymous>"
+  )
+})
+
+test_that("ExtendedTask otel labels are created", {
+  skip_if_not_installed("otelsdk")
+  # Record everything
+  localOtelCollect("all")
+
+  info <- with_shiny_otel_record({
+    ex_task <- ExtendedTask$new(function() { promises::then(promises::promise_resolve(42), force) })
+
+    ex_task$invoke()
+    while(!later::loop_empty()) {
+      later::run_now()
+    }
+  })
+
+  trace <- info$traces[[1]]
+
+  expect_equal(trace$name, "ExtendedTask ex_task")
+
+  # Module test
+  withReactiveDomain(MockShinySession$new(), {
+    info <- with_shiny_otel_record({
+      ex2_task <- ExtendedTask$new(function() { promises::then(promises::promise_resolve(42), force) })
+      ex2_task$invoke()
+      while(!later::loop_empty()) {
+        later::run_now()
+      }
+    })
+  })
+
+  trace <- info$traces[[1]]
+
+  expect_equal(trace$name, "ExtendedTask mock-session:ex2_task")
+})
+
+
+test_that("otel_span_label_reactive with pre-defined label", {
+  x_reactive <- reactive({ 42 }, label = "counter")
+
+  result <- otel_span_label_reactive(x_reactive, domain = MockShinySession$new())
+  expect_equal(result, "reactive mock-session:counter")
+
+  result <- otel_span_label_reactive(x_reactive, domain = NULL)
+  expect_equal(result, "reactive counter")
+})
+
+test_that("observer labels are preserved", {
+  x_observe <- observe({ 42 }, label = "my_observer")
+  expect_equal(x_observe$.label, "my_observer")
+  expect_equal(otel_span_label_observer(x_observe, domain = NULL), "observe my_observer")
+
+  x_observe <- observe({ 42 })
+  expect_equal(x_observe$.label, "x_observe")
+  expect_equal(otel_span_label_observer(x_observe, domain = NULL), "observe x_observe")
+
+  f <- function() {
+    observe({ 42 })
+  }
+
+  x_observe <- f()
+  expect_equal(x_observe$.label, as_default_label("observe({\n    42\n})"))
+  expect_equal(otel_span_label_observer(x_observe, domain = NULL), "observe <anonymous>")
+})
+
+test_that("otel_span_label_observer generates correct labels", {
+  x_observe <- observe({ 42 }, label = "test_observer" )
+
+  result <- otel_span_label_observer(x_observe, domain = MockShinySession$new())
+  expect_equal(result, "observe mock-session:test_observer")
+  result <- otel_span_label_observer(x_observe, domain = NULL)
+  expect_equal(result, "observe test_observer")
+
+  x_observe_event <- bindEvent(x_observe, {"eventKey"})
+  result <- otel_span_label_observer(x_observe_event, domain = NULL)
+  expect_equal(result, "observe event x_observe_event")
+
+  x_observe_event <- observe({ 42 }, label = "test_observer" ) |> bindEvent({"eventKey"})
+  result <- otel_span_label_observer(x_observe_event, domain = NULL)
+  expect_equal(result, "observe event x_observe_event")
+
+  result <- otel_span_label_observer(observe({ 42 }, label = "test_observer" ) |> bindEvent({"eventKey"}), domain = NULL)
+  expect_equal(result, "observe event <anonymous>")
+
+  x_observe <- observe({ 42 }, label = "test_observer" )
+  x_observe_event <- x_observe |> bindEvent({"eventKey"})
+  result <- otel_span_label_observer(x_observe_event, domain = NULL)
+  expect_equal(result, "observe event x_observe_event")
+})
+
+test_that("throttle otel span label is correct", {
+  x_reactive <- reactive({ 42 })
+  x_throttled1 <- throttle(x_reactive, 1000)
+  x_throttled2 <- x_reactive |> throttle(1000)
+  x_throttled3 <- reactive({ 42 }) |> throttle(1000)
+
+  expect_equal(
+    as.character(attr(x_throttled1, "observable")$.label),
+    "throttle x_throttled1 result"
+  )
+  expect_equal(
+    as.character(attr(x_throttled2, "observable")$.label),
+    "throttle x_throttled2 result"
+  )
+  expect_equal(
+    as.character(attr(x_throttled3, "observable")$.label),
+    "throttle x_throttled3 result"
+  )
+
+  expect_equal(attr(x_throttled1, "observable")$.otelLabel, "throttle x_throttled1")
+  expect_equal(attr(x_throttled2, "observable")$.otelLabel, "throttle x_throttled2")
+  expect_equal(attr(x_throttled3, "observable")$.otelLabel, "throttle x_throttled3")
+})
+
+test_that("debounce otel span label is correct", {
+  x_reactive <- reactive({ 42 })
+  x_debounced1 <- debounce(x_reactive, 1000)
+  x_debounced2 <- x_reactive |> debounce(1000)
+  x_debounced3 <- reactive({ 42 }) |> debounce(1000)
+
+  expect_equal(
+    as.character(attr(x_debounced1, "observable")$.label),
+    "debounce x_debounced1 result"
+  )
+  expect_equal(
+    as.character(attr(x_debounced2, "observable")$.label),
+    "debounce x_debounced2 result"
+  )
+  expect_equal(
+    as.character(attr(x_debounced3, "observable")$.label),
+    "debounce x_debounced3 result"
+  )
+
+  expect_equal(attr(x_debounced1, "observable")$.otelLabel, "debounce x_debounced1")
+  expect_equal(attr(x_debounced2, "observable")$.otelLabel, "debounce x_debounced2")
+  expect_equal(attr(x_debounced3, "observable")$.otelLabel, "debounce x_debounced3")
+})
+
+test_that("otel_span_label_observer handles module namespacing", {
+  x_observe <- observe({ 42 }, label = "clicks" )
+  result <- otel_span_label_observer(x_observe, domain = MockShinySession$new())
+  expect_equal(result, "observe mock-session:clicks")
+})
+
+test_that("otel_span_label_render_function generates correct labels", {
+  x_render <- renderText({ "Hello" })
+  mock_domain <- MockShinySession$new()
+
+  testthat::local_mocked_bindings(
+    getCurrentOutputInfo = function(session) {
+      list(name = "plot1")
+    }
+  )
+
+  result <- otel_span_label_render_function(x_render, domain = NULL)
+  expect_equal(result, "output plot1")
+
+  result <- otel_span_label_render_function(x_render, domain = mock_domain)
+  expect_equal(result, "output mock-session:plot1")
+
+  x_render_event <- bindEvent(x_render, {"eventKey"})
+  result <- otel_span_label_render_function(x_render_event, domain = mock_domain)
+  expect_equal(result, "output event mock-session:plot1")
+
+  x_render_cache <- bindCache(x_render, {"cacheKey"})
+  result <- otel_span_label_render_function(x_render_cache, domain = mock_domain)
+  expect_equal(result, "output cache mock-session:plot1")
+
+  x_render_both <- bindEvent(bindCache(x_render, {"cacheKey"}), {"eventKey"})
+  result <- otel_span_label_render_function(x_render_both, domain = mock_domain)
+  expect_equal(result, "output cache event mock-session:plot1")
+})
+
+
+test_that("otel_span_label_render_function handles cache and event classes", {
+  testthat::local_mocked_bindings(
+    getCurrentOutputInfo = function(session) {
+      list(name = "table1")
+    }
+  )
+
+  x_render <- renderText({ "Hello" })
+  x_render_event <- bindEvent(x_render, {"eventKey"})
+  x_render_cache <- bindCache(x_render, {"cacheKey"})
+  x_render_both <- bindEvent(bindCache(x_render, {"cacheKey"}), {"eventKey"})
+  mock_domain <- MockShinySession$new()
+
+  result <- otel_span_label_render_function(x_render, domain = NULL)
+  expect_equal(result, "output table1")
+
+  result <- otel_span_label_render_function(x_render, domain = mock_domain)
+  expect_equal(result, "output mock-session:table1")
+
+  result <- otel_span_label_render_function(x_render_event, domain = mock_domain)
+  expect_equal(result, "output event mock-session:table1")
+
+  result <- otel_span_label_render_function(x_render_cache, domain = mock_domain)
+  expect_equal(result, "output cache mock-session:table1")
+
+  result <- otel_span_label_render_function(x_render_both, domain = mock_domain)
+  expect_equal(result, "output cache event mock-session:table1")
+})
+
+test_that("otel_label_upgrade handles anonymous labels", {
+  # Test default labels with parentheses get converted to <anonymous>
+  result <- otel_label_upgrade(as_default_label("observe({})"), domain = NULL)
+  expect_equal(result, "<anonymous>")
+
+  result <- otel_label_upgrade(as_default_label("eventReactive(input$btn, {})"), domain = NULL)
+  expect_equal(result, "<anonymous>")
+
+  # Test regular labels are kept as-is
+  result <- otel_label_upgrade(as_default_label("my_observer"), domain = NULL)
+  expect_equal(as.character(result), "my_observer")
+  result <- otel_label_upgrade("my_observer", domain = NULL)
+  expect_equal(result, "my_observer")
+})

tests/testthat/test-otel-mock.R

@@ -0,0 +1,309 @@
+skip_on_cran()
+skip_if_not_installed("otelsdk")
+
+expect_code_attrs <- function(trace, expected_fn_name = NULL) {
+  testthat::expect_true(!is.null(trace))
+  testthat::expect_true(is.list(trace$attributes))
+
+  # Check preferred attribute names
+  testthat::expect_true(is.character(trace$attributes[["code.file.path"]]))
+  testthat::expect_equal(trace$attributes[["code.file.path"]], "test-otel-mock.R")
+  testthat::expect_true(is.numeric(trace$attributes[["code.line.number"]]))
+  testthat::expect_true(is.numeric(trace$attributes[["code.column.number"]]))
+
+  # Check deprecated attribute names (for backward compatibility)
+  testthat::expect_true(is.character(trace$attributes[["code.filepath"]]))
+  testthat::expect_equal(trace$attributes[["code.filepath"]], "test-otel-mock.R")
+  testthat::expect_true(is.numeric(trace$attributes[["code.lineno"]]))
+  testthat::expect_true(is.numeric(trace$attributes[["code.column"]]))
+
+  # Verify deprecated names match preferred names
+  testthat::expect_equal(
+    trace$attributes[["code.file.path"]],
+    trace$attributes[["code.filepath"]]
+  )
+  testthat::expect_equal(
+    trace$attributes[["code.line.number"]],
+    trace$attributes[["code.lineno"]]
+  )
+  testthat::expect_equal(
+    trace$attributes[["code.column.number"]],
+    trace$attributes[["code.column"]]
+  )
+
+  # Check code.function.name if expected
+  if (!is.null(expected_fn_name)) {
+    testthat::expect_true(
+      is.character(trace$attributes[["code.function.name"]])
+    )
+    testthat::expect_equal(
+      trace$attributes[["code.function.name"]],
+      expected_fn_name
+    )
+  }
+
+  invisible(trace)
+}
+MOCK_SESSION_TOKEN <- "test-session-token"
+expect_session_id <- function(trace) {
+  testthat::expect_true(!is.null(trace))
+  testthat::expect_true(is.list(trace$attributes))
+  testthat::expect_true(is.character(trace$attributes[["session.id"]]))
+  testthat::expect_equal(trace$attributes[["session.id"]], MOCK_SESSION_TOKEN)
+
+  invisible(trace)
+}
+
+expect_trace <- function(traces, name, pos = 1, expected_fn_name = NULL) {
+  # Filter to traces with the given name
+  trace_set <- traces[which(names(traces) == name)]
+  testthat::expect_gte(length(trace_set), pos)
+
+  # Get the trace at the given position
+  trace <- trace_set[[pos]]
+  testthat::expect_true(is.list(trace))
+
+  expect_code_attrs(trace, expected_fn_name = expected_fn_name)
+  expect_session_id(trace)
+
+  trace
+}
+
+create_mock_session <- function() {
+  session <- MockShinySession$new()
+  session$token <- MOCK_SESSION_TOKEN
+  session
+}
+
+test_server_with_otel <- function(session, server, expr, bind = "all", args = list()) {
+  stopifnot(inherits(session, "MockShinySession"))
+  stopifnot(is.function(server))
+
+  withr::with_options(list(shiny.otel.collect = bind), {
+    info <- with_shiny_otel_record({
+      # rlang quosure magic to capture and pass through `expr`
+      testServer(server, {{ expr }}, args = args, session = session)
+    })
+  })
+
+  info$traces
+}
+
+for (bind in c("all", "reactivity")) {
+  test_that(paste0("bind='", bind, "' handles observers"), {
+    server <- function(input, output, session) {
+      observe({
+        42
+      })
+
+      my_observe <- observe({
+        43
+      })
+
+      observe({
+        44
+      }, label = "labeled observer")
+    }
+
+    session <- create_mock_session()
+    traces <- test_server_with_otel(session, server, bind = bind, {
+      # probably not needed to do anything here
+      session$flushReact()
+    })
+
+    expect_trace(traces, "observe mock-session:<anonymous>", 1, "observe")
+    expect_trace(traces, "observe mock-session:my_observe", 1, "observe")
+    expect_trace(traces, "observe mock-session:labeled observer", 1, "observe")
+  })
+
+  test_that(paste0("bind='", bind, "' handles reactiveVal / reactiveValues"), {
+    server <- function(input, output, session) {
+      rv <- reactiveVal(0)
+      rv2 <- (function() {reactiveVal(0)})()  # test anonymous reactiveVal
+      rv3 <- reactiveVal(0, "labeled_rv")
+
+      observe({
+        isolate({
+          rv(rv() + 1)
+          rv2(rv2() + 1)
+          rv3(rv3() + 1)
+        })
+      })
+    }
+
+    session <- create_mock_session()
+    traces <- test_server_with_otel(session, server, bind = bind, {
+      session$flushReact()
+      expect_equal(rv(), 1)
+    })
+
+    expect_trace(traces, "observe mock-session:<anonymous>", 1, "observe")
+
+    # TODO-future: Add tests to see the `Set reactiveVal mock-session:rv` logs
+    # Requires: https://github.com/r-lib/otelsdk/issues/21
+  })
+
+  test_that(paste0("bind='", bind, "' handles reactive"), {
+    server <- function(input, output, session) {
+      r <- reactive({ 42 })
+      r2 <- (function() {reactive({ r() })})()  # test anonymous reactive
+      r3 <- reactive({ r2() }, label = "labeled_rv")
+
+      observe(label = "obs_r3", {
+        r3()
+      })
+    }
+
+    session <- create_mock_session()
+    traces <- test_server_with_otel(session, server, bind = bind, {
+      session$flushReact()
+      session$flushReact()
+      session$flushReact()
+      expect_equal(r(), 42)
+      expect_equal(r2(), 42)
+      expect_equal(r3(), 42)
+    })
+
+    observe_trace <- expect_trace(
+      traces, "observe mock-session:obs_r3", 1, "observe"
+    )
+    r_trace <- expect_trace(traces, "reactive mock-session:r", 1, "reactive")
+    r2_trace <- expect_trace(
+      traces, "reactive mock-session:<anonymous>", 1, "reactive"
+    )
+    r3_trace <- expect_trace(
+      traces, "reactive mock-session:labeled_rv", 1, "reactive"
+    )
+
+    expect_equal(r_trace$parent, r2_trace$span_id)
+    expect_equal(r2_trace$parent, r3_trace$span_id)
+    expect_equal(r3_trace$parent, observe_trace$span_id)
+  })
+
+
+  test_that(paste0("bind='", bind, "' outputs are supported"), {
+    server <- function(input, output, session) {
+      output$txt <- renderText({
+        "Hello, world!"
+      })
+    }
+
+    session <- create_mock_session()
+    traces <- test_server_with_otel(session, server, bind = bind, {
+      session$flushReact()
+      session$flushReact()
+      session$flushReact()
+      expect_equal(output$txt, "Hello, world!")
+    })
+
+    # Outputs (render functions) should NOT have code.function.name
+    trace <- expect_trace(traces, "output mock-session:txt", 1, NULL)
+    expect_false("code.function.name" %in% names(trace$attributes))
+  })
+
+  test_that(paste0("bind='", bind, "' extended tasks are supported"), {
+    server <- function(input, output, session) {
+      rand_task <- ExtendedTask$new(function() {
+        promise_resolve(42) |> promises::then(function(value) {
+          value
+        })
+      })
+
+      observe(label = "invoke task", {
+        rand_task$invoke()
+      })
+
+      output$result <- renderText({
+        # React to updated results when the task completes
+        number <- rand_task$result()
+        paste0("Your number is ", number, ".")
+      })
+    }
+
+    session <- create_mock_session()
+    traces <- test_server_with_otel(session, server, bind = bind, {
+      session$flushReact()
+
+      while (!later::loop_empty()) {
+        later::run_now()
+        session$flushReact()
+      }
+      session$flushReact()
+    })
+
+    invoke_obs <- expect_trace(
+      traces, "observe mock-session:invoke task", 1, "observe"
+    )
+    # Render functions should NOT have code.function.name
+    render1_trace <- expect_trace(traces, "output mock-session:result", 1, NULL)
+    expect_false("code.function.name" %in% names(render1_trace$attributes))
+
+    ex_task_trace <- expect_trace(
+      traces, "ExtendedTask mock-session:rand_task", 1, "ExtendedTask"
+    )
+
+    render2_trace <- expect_trace(
+      traces, "output mock-session:result", pos = 2, NULL
+    )
+    expect_false("code.function.name" %in% names(render2_trace$attributes))
+
+    expect_equal(invoke_obs$span_id, ex_task_trace$parent)
+  })
+
+}
+
+
+test_that("bind = 'reactivity' traces reactive components", {
+  server <- function(input, output, session) {
+    r <- reactive({ 42 })
+
+    observe(label = "test_obs", {
+      r()
+    })
+
+    output$txt <- renderText({
+      "Hello"
+    })
+  }
+
+  session <- create_mock_session()
+  traces <- test_server_with_otel(session, server, bind = "reactivity", {
+    session$flushReact()
+    expect_equal(r(), 42)
+  })
+
+  # Should trace reactive components (equivalent to "all")
+  expect_trace(traces, "observe mock-session:test_obs", 1, "observe")
+  expect_trace(traces, "reactive mock-session:r", 1, "reactive")
+  # Render functions should NOT have code.function.name
+  txt_trace <- expect_trace(traces, "output mock-session:txt", 1, NULL)
+  expect_false("code.function.name" %in% names(txt_trace$attributes))
+})
+
+
+for (bind in c("reactive_update", "session", "none")) {
+  test_that(paste0("bind = '", bind, "' traces reactive components"), {
+    server <- function(input, output, session) {
+      r <- reactive({ 42 })
+
+      observe(label = "test_obs", {
+        r()
+      })
+
+      output$txt <- renderText({
+        "Hello"
+      })
+    }
+
+    session <- create_mock_session()
+    traces <- test_server_with_otel(session, server, bind = bind, {
+      session$flushReact()
+      expect_equal(r(), 42)
+    })
+    trace_names <- names(traces)
+
+    expect_false(any(grepl("observe", trace_names)))
+    expect_false(any(grepl("reactive", trace_names)))
+    expect_false(any(grepl("output", trace_names)))
+  })
+}

tests/testthat/test-otel-reactive-update.R

@@ -0,0 +1,229 @@
+# Tests for otel-reactive-update.R functions
+
+# Helper function to create a mock otel span
+create_mock_otel_span <- function(name, attributes = NULL, ended = FALSE) {
+  structure(
+    list(name = name, attributes = attributes, ended = ended),
+    class = c("mock_otel_span", "otel_span")
+  )
+}
+
+test_that("otel_span_reactive_update_init returns early when otel not enabled", {
+  domain <- MockShinySession$new()
+
+  # Convince has_otel_collect to return FALSE
+  withr::local_options(list(shiny.otel.collect = "none"))
+
+  # Should return early without creating span
+  result <- otel_span_reactive_update_init(domain = domain)
+  expect_null(result)
+  expect_null(domain$userData[["_otel_span_reactive_update"]])
+})
+
+test_that("otel_span_reactive_update_init sets up session cleanup on first call", {
+  callback_added <- FALSE
+  TestMockShinySession <- R6::R6Class(
+    "TestMockShinySession",
+    inherit = MockShinySession,
+    portable = FALSE,
+    lock_objects = FALSE,
+    public = list(
+      # Mock onSessionEnded to track if callback is added
+      onSessionEnded = function(callback) {
+        callback_added <<- TRUE
+        expect_true(is.function(callback))
+      }
+    )
+  )
+  domain <- TestMockShinySession$new()
+
+  withr::local_options(list(shiny.otel.collect = "reactive_update"))
+
+  local_mocked_bindings(
+    has_otel_collect = function(level) level == "reactive_update",
+    start_otel_span = function(name, ..., attributes = NULL) create_mock_otel_span(name, attributes = attributes),
+    otel_session_id_attrs = function(domain) list(session_id = "mock-session-id")
+  )
+
+  otel_span_reactive_update_init(domain = domain)
+
+  expect_true(callback_added)
+  expect_true(domain$userData[["_otel_has_reactive_cleanup"]])
+  expect_equal(
+    domain$userData[["_otel_span_reactive_update"]],
+    create_mock_otel_span("reactive_update", attributes = list(session_id = "mock-session-id"))
+  )
+})
+
+test_that("otel_span_reactive_update_init errors when span already exists", {
+  domain <- MockShinySession$new()
+  domain$token <- "mock-session-token"
+
+  # Set up existing span
+  existing_otel_span <- create_mock_otel_span("reactive_update", attributes = list(session.id = "mock-session-token"))
+  domain$userData[["_otel_span_reactive_update"]] <- existing_otel_span
+
+  local_mocked_bindings(
+    has_otel_collect = function(level) level == "reactive_update"
+  )
+
+  expect_error(
+    otel_span_reactive_update_init(domain = domain),
+    "Reactive update span already exists"
+  )
+})
+
+test_that("otel_span_reactive_update_init doesn't setup cleanup twice", {
+  TestMockShinySession <- R6::R6Class(
+    "TestMockShinySession",
+    inherit = MockShinySession,
+    portable = FALSE,
+    lock_objects = FALSE,
+    public = list(
+      # Mock onSessionEnded to track how many times callback is added
+      callback_count = 0,
+      onSessionEnded = function(callback) {
+        self$callback_count <- self$callback_count + 1
+        expect_true(is.function(callback))
+      }
+    )
+  )
+  domain <- TestMockShinySession$new()
+
+  # Set cleanup flag manually
+  domain$userData[["_otel_has_reactive_cleanup"]] <- TRUE
+
+  local_mocked_bindings(
+    has_otel_collect = function(level) level == "reactive_update",
+    start_otel_span = function(...) create_mock_otel_span("reactive_update")
+  )
+
+  otel_span_reactive_update_init(domain = domain)
+
+  # Should not have called onSessionEnded since cleanup was already set
+  expect_equal(domain$callback_count, 0)
+})
+
+test_that("otel_span_reactive_update_teardown ends span when it exists", {
+  domain <- MockShinySession$new()
+  mock_otel_span <- create_mock_otel_span("reactive_update")
+  domain$userData[["_otel_span_reactive_update"]] <- mock_otel_span
+
+  span_ended <- FALSE
+
+  local_mocked_bindings(
+    end_span = function(span) {
+      span_ended <<- TRUE
+      expect_equal(span, mock_otel_span)
+    },
+    .package = "otel"
+  )
+
+  otel_span_reactive_update_teardown(domain = domain)
+
+  expect_true(span_ended)
+  expect_null(domain$userData[["_otel_span_reactive_update"]])
+})
+
+test_that("otel_span_reactive_update_teardown handles missing span gracefully", {
+  domain <- MockShinySession$new()
+
+  # No span exists
+  expect_null(domain$userData[["_otel_span_reactive_update"]])
+
+  # Should not error
+  expect_no_error(otel_span_reactive_update_teardown(domain = domain))
+})
+
+test_that("with_otel_span_reactive_update executes expr without span", {
+  domain <- MockShinySession$new()
+
+  # No span exists
+  test_value <- "initial"
+
+  local_mocked_bindings(
+    is_otel_span = function(x) FALSE
+  )
+
+  result <- with_otel_span_reactive_update({
+    test_value <- "modified"
+    "result_value"
+  }, domain = domain)
+
+  expect_equal(result, "result_value")
+  expect_equal(test_value, "modified")
+})
+
+test_that("with_otel_span_reactive_update executes expr with active span", {
+  domain <- MockShinySession$new()
+  mock_otel_span <- create_mock_otel_span("reactive_update")
+  domain$userData[["_otel_span_reactive_update"]] <- mock_otel_span
+
+  span_was_active <- FALSE
+  test_value <- "initial"
+
+  local_mocked_bindings(
+    with_active_span = function(span, expr) {
+      span_was_active <<- TRUE
+      expect_equal(span, mock_otel_span)
+      force(expr)
+    },
+    .package = "otel"
+  )
+
+  result <- with_otel_span_reactive_update({
+    test_value <- "modified"
+    "result_value"
+  }, domain = domain)
+
+  expect_true(span_was_active)
+  expect_equal(result, "result_value")
+  expect_equal(test_value, "modified")
+})
+
+test_that("session cleanup callback works correctly", {
+  TestMockShinySession <- R6::R6Class(
+    "TestMockShinySession",
+    inherit = MockShinySession,
+    portable = FALSE,
+    lock_objects = FALSE,
+    public = list(
+      # Mock onSessionEnded to capture the callback
+      onSessionEnded = function(callback) {
+        self$cleanup_callback <<- callback
+      },
+      cleanup_callback = NULL
+    )
+  )
+  domain <- TestMockShinySession$new()
+  mock_otel_span <- create_mock_otel_span("reactive_update")
+
+  with_mocked_bindings(
+    has_otel_collect = function(level) level == "reactive_update",
+    start_otel_span = function(...) mock_otel_span,
+    otel_session_id_attrs = function(domain) list(session_id = "test"),
+    {
+      otel_span_reactive_update_init(domain = domain)
+    }
+  )
+
+  # Verify cleanup callback was registered
+  expect_true(is.function(domain$cleanup_callback))
+
+  # Set up span and test cleanup
+  domain$userData[["_otel_span_reactive_update"]] <- mock_otel_span
+  domain$userData[["_otel_has_reactive_cleanup"]] <- TRUE
+
+  span_ended <- FALSE
+
+  with_mocked_bindings(
+    otel_span_reactive_update_teardown = function(domain = NULL) {
+      span_ended <<- TRUE
+    },
+    {
+      # Execute the cleanup callback
+      domain$cleanup_callback()
+      expect_true(span_ended)
+    }
+  )
+})

tests/testthat/test-otel-session.R

@@ -0,0 +1,288 @@
+# Tests for otel-session.R functions
+
+# Helper function to create a mock domain with request info
+create_mock_session_domain <- function(
+  token = "test-session-123",
+  request = list(),
+  session_ended_callbacks = list()
+) {
+  TestMockShinySession <- R6::R6Class(
+    "TestMockShinySession",
+    inherit = MockShinySession,
+    portable = FALSE,
+    lock_objects = FALSE,
+    public = list(
+      # Mock onSessionEnded to capture the callback
+      onSessionEnded = function(callback) {
+        expect_true(is.function(callback))
+        self$cleanup_callbacks <- c(self$cleanup_callbacks, list(callback))
+      },
+      cleanup_callbacks = NULL,
+      request_val = NULL
+    ),
+    active = list(
+      request = function(value) {
+        if (!missing(value)) {
+          self$request_val <- value
+        } else {
+          self$request_val
+        }
+      }
+
+    )
+  )
+
+  domain <- TestMockShinySession$new()
+
+  domain$request <- request
+  domain$token <- token
+
+  domain
+}
+
+test_that("otel_span_session_start returns early when otel not enabled", {
+  domain <- create_mock_session_domain()
+  test_value <- "initial"
+
+  # Mock has_otel_collect to return FALSE
+  withr::local_options(list(shiny.otel.collect = "none"))
+
+  result <- otel_span_session_start({
+    test_value <- "modified"
+    "result_value"
+  }, domain = domain)
+
+  expect_equal(result, "result_value")
+  expect_equal(test_value, "modified")
+  # Should not have registered any callbacks
+  expect_length(domain$cleanup_callbacks, 0)
+})
+
+test_that("otel_span_session_start sets up session end callback", {
+  domain <- create_mock_session_domain(
+    token = "session-456",
+    request = list(PATH_INFO = "/app", HTTP_HOST = "localhost")
+  )
+
+  test_value <- "initial"
+
+  # Mock dependencies
+  withr::local_options(list(shiny.otel.collect = "session"))
+
+  local_mocked_bindings(
+    as_attributes = function(x) x,
+    .package = "otel"
+  )
+
+  with_mocked_bindings(
+    has_otel_collect = function(level) level == "session",
+    otel_session_id_attrs = function(domain) list(session.id = domain$token),
+    otel_session_attrs = function(domain) list(PATH_INFO = "/app"),
+    with_otel_span = function(name, expr, attributes = NULL) {
+      expect_equal(name, "session_start")
+      expect_true("session.id" %in% names(attributes))
+      expect_equal(attributes[["session.id"]], "session-456")
+      force(expr)
+    },
+    {
+
+      expect_length(domain$cleanup_callbacks, 0)
+
+      result <- otel_span_session_start({
+        test_value <- "modified"
+        "result_value"
+      }, domain = domain)
+
+      expect_equal(result, "result_value")
+      expect_equal(test_value, "modified")
+      expect_length(domain$cleanup_callbacks, 0)
+
+    }
+  )
+})
+
+test_that("otel_span_session_end returns early when otel not enabled", {
+  domain <- create_mock_session_domain()
+  test_value <- "initial"
+
+  # Mock has_otel_collect to return FALSE
+  withr::local_options(list(shiny.otel.collect = "none"))
+
+  result <- otel_span_session_end({
+    test_value <- "modified"
+    "result_value"
+  }, domain = domain)
+
+  expect_equal(result, "result_value")
+  expect_equal(test_value, "modified")
+})
+
+test_that("otel_span_session_end creates span when enabled", {
+  domain <- create_mock_session_domain(token = "session-end-test")
+
+  span_created <- FALSE
+  test_value <- "initial"
+
+  # Mock dependencies
+  withr::local_options(list(shiny.otel.collect = "session"))
+
+  with_mocked_bindings(
+    has_otel_collect = function(level) level == "session",
+    otel_session_id_attrs = function(domain) list(session.id = domain$token),
+    with_otel_span = function(name, expr, attributes = NULL) {
+      span_created <<- TRUE
+      expect_equal(name, "session_end")
+      expect_equal(attributes[["session.id"]], "session-end-test")
+      force(expr)
+    },
+    {
+      result <- otel_span_session_end({
+        test_value <- "modified"
+        "result_value"
+      }, domain = domain)
+
+      expect_equal(result, "result_value")
+      expect_equal(test_value, "modified")
+      expect_true(span_created)
+    }
+  )
+})
+
+test_that("otel_session_attrs extracts request attributes correctly", {
+  # Test with full request info
+  domain <- create_mock_session_domain(
+    request = list(
+      PATH_INFO = "/myapp/page",
+      HTTP_HOST = "example.com",
+      HTTP_ORIGIN = "https://example.com",
+      SERVER_PORT = "8080"
+    )
+  )
+
+  attrs <- otel_session_attrs(domain)
+
+  expect_equal(attrs$server.path, "/myapp/page")
+  expect_equal(attrs$server.address, "example.com")
+  expect_equal(attrs$server.origin, "https://example.com")
+  expect_equal(attrs$server.port, 8080L)  # Should be converted to integer
+})
+
+test_that("otel_session_attrs handles websocket PATH_INFO", {
+  domain <- create_mock_session_domain(
+    request = list(
+      PATH_INFO = "/myapp/websocket/",
+      HTTP_HOST = "localhost"
+    )
+  )
+
+  attrs <- otel_session_attrs(domain)
+
+  # Should strip websocket suffix
+  expect_equal(attrs$server.path, "/myapp/")
+})
+
+test_that("otel_session_attrs handles missing request fields", {
+  # Test with minimal request info
+  domain <- create_mock_session_domain(
+    request = list(
+      HTTP_HOST = "localhost"
+    )
+  )
+
+  attrs <- otel_session_attrs(domain)
+
+  expect_equal(attrs$server.path, "")
+  expect_equal(attrs$server.address, "localhost")
+  expect_equal(attrs$server.origin, "")
+  expect_equal(attrs$server.port, NA_integer_)
+})
+
+test_that("otel_session_attrs handles empty request", {
+  domain <- create_mock_session_domain(request = list())
+
+  attrs <- otel_session_attrs(domain)
+
+  expect_equal(attrs$server.path, "")
+  expect_equal(attrs$server.address, "")
+  expect_equal(attrs$server.origin, "")
+  expect_equal(attrs$server.port, NA_integer_)
+})
+
+test_that("otel_session_attrs handles invalid SERVER_PORT gracefully", {
+  domain <- create_mock_session_domain(
+    request = list(SERVER_PORT = "invalid")
+  )
+
+  # Should not error even with invalid port
+  attrs <- otel_session_attrs(domain)
+
+  # Should remain as string if conversion fails
+  expect_equal(attrs$server.port, "invalid")
+})
+
+test_that("otel_session_id_attrs returns correct session ID", {
+  domain <- create_mock_session_domain(token = "unique-session-token")
+
+  attrs <- otel_session_id_attrs(domain)
+
+  expect_equal(attrs$session.id, "unique-session-token")
+  expect_length(attrs, 1)
+})
+
+test_that("otel_session_id_attrs handles missing token", {
+  domain <- create_mock_session_domain(token = NULL)
+
+  attrs <- otel_session_id_attrs(domain)
+
+  expect_null(attrs$session.id)
+})
+
+test_that("integration test - session start with full request", {
+  domain <- create_mock_session_domain(
+    token = "integration-test-session",
+    request = list(
+      PATH_INFO = "/dashboard/",
+      HTTP_HOST = "shiny.example.com",
+      HTTP_ORIGIN = "https://shiny.example.com",
+      SERVER_PORT = "3838"
+    )
+  )
+
+  session_callback <- NULL
+  span_attributes <- NULL
+
+  # Mock dependencies
+  withr::local_options(list(shiny.otel.collect = "session"))
+
+  local_mocked_bindings(
+    as_attributes = function(x) x,
+    .package = "otel"
+  )
+
+  with_mocked_bindings(
+    has_otel_collect = function(level) level == "session",
+    otel_session_id_attrs = otel_session_id_attrs,  # Use real function
+    otel_session_attrs = otel_session_attrs,        # Use real function
+    with_otel_span = function(name, expr, attributes = NULL) {
+      span_attributes <<- attributes
+      force(expr)
+    },
+    otel_log = function(...) {},  # Mock log function
+    {
+
+      expect_length(domain$cleanup_callbacks, 0)
+
+      result <- otel_span_session_start({
+        "test_result"
+      }, domain = domain)
+
+      expect_equal(result, "test_result")
+
+      # Check span attributes include both session ID and request info
+      expect_equal(span_attributes[["session.id"]], "integration-test-session")
+      expect_equal(span_attributes[["server.path"]], "/dashboard/")
+      expect_equal(span_attributes[["server.address"]], "shiny.example.com")
+      expect_equal(span_attributes[["server.port"]], 3838L)
+    }
+  )
+})

tests/testthat/test-otel-shiny.R

@@ -0,0 +1,143 @@
+# Tests for otel-shiny.R functions
+
+test_that("otel_tracer_name constant is correct", {
+  expect_equal(otel_tracer_name, "co.posit.r-package.shiny")
+})
+
+
+test_that("start_otel_span calls otel::start_span with correct parameters", {
+  mock_tracer <- create_mock_tracer()
+  mock_span <- create_mock_otel_span()
+  start_span_called <- FALSE
+
+  local_mocked_bindings(
+    start_span = function(name, ..., tracer = NULL) {
+      start_span_called <<- TRUE
+      expect_equal(name, "test_span")
+      expect_equal(tracer, mock_tracer)
+      mock_span
+    },
+    .package = "otel"
+  )
+  local_mocked_bindings(
+    shiny_otel_tracer = function() mock_tracer,
+  )
+
+  result <- start_otel_span("test_span", extra_param = "value")
+
+  expect_true(start_span_called)
+  expect_equal(result, mock_span)
+})
+
+test_that("is_otel_span correctly identifies otel spans", {
+  # Test with otel_span object
+  otel_span <- create_mock_otel_span()
+  expect_true(is_otel_span(otel_span))
+
+  # Test with non-otel objects
+  expect_false(is_otel_span("string"))
+  expect_false(is_otel_span(123))
+  expect_false(is_otel_span(list()))
+  expect_false(is_otel_span(NULL))
+
+  # Test with object that has different class
+  other_obj <- structure(list(), class = "other_class")
+  expect_false(is_otel_span(other_obj))
+})
+
+test_that("testthat__is_testing detects testing environment", {
+  # Test when TESTTHAT env var is set to "true"
+  withr::with_envvar(list(TESTTHAT = "true"), {
+    expect_true(testthat__is_testing())
+  })
+
+  # Test when TESTTHAT env var is not set
+  withr::with_envvar(list(TESTTHAT = NA), {
+    expect_false(testthat__is_testing())
+  })
+
+  # Test when TESTTHAT env var is set to other values
+  withr::with_envvar(list(TESTTHAT = "false"), {
+    expect_false(testthat__is_testing())
+  })
+
+  withr::with_envvar(list(TESTTHAT = ""), {
+    expect_false(testthat__is_testing())
+  })
+})
+
+test_that("otel_log calls otel::log with correct parameters", {
+  mock_logger <- create_mock_logger()
+  log_called <- FALSE
+
+  local_mocked_bindings(
+    log = function(msg, ..., severity = NULL, logger = NULL) {
+      log_called <<- TRUE
+      expect_equal(msg, "test message")
+      expect_equal(severity, "warn")
+      expect_equal(logger, mock_logger)
+    },
+    .package = "otel"
+  )
+  local_mocked_bindings(
+    shiny_otel_logger = function() mock_logger,
+  )
+
+  otel_log("test message", severity = "warn")
+  expect_true(log_called)
+})
+
+test_that("otel_log uses default severity and logger", {
+  mock_logger <- create_mock_logger()
+  log_called <- FALSE
+
+  local_mocked_bindings(
+    log = function(msg, ..., severity = NULL, logger = NULL) {
+      log_called <<- TRUE
+      expect_equal(msg, "default test")
+      expect_equal(severity, "info")  # Default severity
+      expect_equal(logger, mock_logger)  # Default logger
+    },
+    .package = "otel"
+  )
+  local_mocked_bindings(
+    shiny_otel_logger = function() mock_logger,
+  )
+
+  otel_log("default test")
+  expect_true(log_called)
+})
+
+
+test_that("integration test - start_otel_span with custom parameters", {
+  mock_tracer <- create_mock_tracer()
+  mock_span <- create_mock_otel_span()
+  start_span_params <- list()
+
+  local_mocked_bindings(
+    start_span = function(name, ..., tracer = NULL) {
+      start_span_params <<- list(
+        name = name,
+        tracer = tracer,
+        extra_args = list(...)
+      )
+      mock_span
+    },
+    .package = "otel"
+  )
+  local_mocked_bindings(
+    shiny_otel_tracer = function() mock_tracer,
+  )
+
+  result <- start_otel_span(
+    "custom_span",
+    attributes = list(key = "value"),
+    parent = "parent_span"
+  )
+
+  expect_equal(result, mock_span)
+  expect_equal(start_span_params$name, "custom_span")
+  expect_equal(start_span_params$tracer, mock_tracer)
+  expect_equal(start_span_params$extra_args$attributes, list(key = "value"))
+  expect_equal(start_span_params$extra_args$parent, "parent_span")
+})

tests/testthat/test-otel-with.R

@@ -0,0 +1,316 @@
+test_that("withOtelCollect sets collection level temporarily", {
+  # Save original option
+  original <- getOption("shiny.otel.collect")
+  on.exit(options(shiny.otel.collect = original), add = TRUE)
+
+  # Set a baseline option
+  options(shiny.otel.collect = "all")
+
+  # Test that withOtelCollect temporarily changes the option
+  result <- withOtelCollect("none", {
+    getOption("shiny.otel.collect")
+  })
+
+  expect_equal(result, "none")
+
+  # Verify option is restored after expression
+  expect_equal(getOption("shiny.otel.collect"), "all")
+})
+
+test_that("withOtelCollect returns value of expr", {
+  result <- withOtelCollect("none", {
+    42
+  })
+
+  expect_equal(result, 42)
+
+  # Test with more complex return value
+  result <- withOtelCollect("reactivity", {
+    list(a = 1, b = "test")
+  })
+
+  expect_equal(result, list(a = 1, b = "test"))
+})
+
+test_that("withOtelCollect validates collect level", {
+  expect_error(
+    withOtelCollect("invalid", { 1 }),
+    "'arg' should be one of"
+  )
+
+  expect_error(
+    withOtelCollect(123, { 1 }),
+    "`collect` must be a character vector"
+  )
+
+  expect_error(
+    withOtelCollect(c("all", "none"), { 1 }),
+    "'arg' must be of length 1"
+  )
+})
+
+test_that("withOtelCollect rejects session and reactive_update levels", {
+  expect_error(
+    withOtelCollect("session", { 1 }),
+    "'arg' should be one of"
+  )
+
+  expect_error(
+    withOtelCollect("reactive_update", { 1 }),
+    "'arg' should be one of"
+  )
+})
+
+test_that("withOtelCollect works with all valid collect levels", {
+  for (level in c("none", "reactivity", "all")) {
+    result <- withOtelCollect(level, {
+      getOption("shiny.otel.collect")
+    })
+    expect_equal(result, level)
+  }
+})
+
+test_that("withOtelCollect nests correctly", {
+  original <- getOption("shiny.otel.collect")
+  on.exit(options(shiny.otel.collect = original), add = TRUE)
+
+  options(shiny.otel.collect = "all")
+
+  result <- withOtelCollect("reactivity", {
+    outer <- getOption("shiny.otel.collect")
+    inner <- withOtelCollect("none", {
+      getOption("shiny.otel.collect")
+    })
+    restored <- getOption("shiny.otel.collect")
+
+    list(outer = outer, inner = inner, restored = restored)
+  })
+
+  expect_equal(result$outer, "reactivity")
+  expect_equal(result$inner, "none")
+  expect_equal(result$restored, "reactivity")
+  expect_equal(getOption("shiny.otel.collect"), "all")
+})
+
+test_that("withOtelCollect restores option even on error", {
+  original <- getOption("shiny.otel.collect")
+  on.exit(options(shiny.otel.collect = original), add = TRUE)
+
+  options(shiny.otel.collect = "all")
+
+  expect_error(
+    withOtelCollect("none", {
+      stop("test error")
+    }),
+    "test error"
+  )
+
+  # Option should still be restored
+  expect_equal(getOption("shiny.otel.collect"), "all")
+})
+
+test_that("localOtelCollect sets collection level in function scope", {
+  original <- getOption("shiny.otel.collect")
+  on.exit(options(shiny.otel.collect = original), add = TRUE)
+
+  options(shiny.otel.collect = "all")
+
+  test_func <- function() {
+    localOtelCollect("none")
+    getOption("shiny.otel.collect")
+  }
+
+  result <- test_func()
+  expect_equal(result, "none")
+
+  # Option should be restored after function exits
+  expect_equal(getOption("shiny.otel.collect"), "all")
+})
+
+test_that("localOtelCollect returns previous collect value invisibly", {
+  original <- getOption("shiny.otel.collect")
+  on.exit(options(shiny.otel.collect = original), add = TRUE)
+
+  options(shiny.otel.collect = "all")
+
+  result <- withVisible(localOtelCollect("none"))
+
+  # Should return a list with the old option value
+  expect_type(result$value, "list")
+  expect_equal(result$value$shiny.otel.collect, "all")
+  expect_false(result$visible)
+})
+
+test_that("localOtelCollect validates collect level", {
+  expect_error(
+    localOtelCollect("invalid"),
+    "'arg' should be one of"
+  )
+
+  expect_error(
+    localOtelCollect(NULL),
+    "`collect` must be a character vector"
+  )
+
+  expect_error(
+    localOtelCollect(c("all", "none")),
+    "'arg' must be of length 1"
+  )
+})
+
+test_that("localOtelCollect rejects session and reactive_update levels", {
+  expect_error(
+    localOtelCollect("session"),
+    "'arg' should be one of"
+  )
+
+  expect_error(
+    localOtelCollect("reactive_update"),
+    "'arg' should be one of"
+  )
+})
+
+test_that("localOtelCollect works with all valid collect levels", {
+  for (level in c("none", "reactivity", "all")) {
+    test_func <- function() {
+      localOtelCollect(level)
+      getOption("shiny.otel.collect")
+    }
+    result <- test_func()
+    expect_equal(result, level)
+  }
+})
+
+test_that("localOtelCollect respects envir parameter", {
+  original <- getOption("shiny.otel.collect")
+  on.exit(options(shiny.otel.collect = original), add = TRUE)
+
+  options(shiny.otel.collect = "all")
+
+  outer_func <- function() {
+    env <- environment()
+
+    inner_func <- function() {
+      localOtelCollect("none", envir = env)
+    }
+
+    inner_func()
+    getOption("shiny.otel.collect")
+  }
+
+  result <- outer_func()
+  expect_equal(result, "none")
+  expect_equal(getOption("shiny.otel.collect"), "all")
+})
+
+test_that("localOtelCollect scope is limited to function", {
+  original <- getOption("shiny.otel.collect")
+  on.exit(options(shiny.otel.collect = original), add = TRUE)
+
+  options(shiny.otel.collect = "all")
+
+  func1 <- function() {
+    localOtelCollect("reactivity")
+    getOption("shiny.otel.collect")
+  }
+
+  func2 <- function() {
+    localOtelCollect("none")
+    getOption("shiny.otel.collect")
+  }
+
+  result1 <- func1()
+  result2 <- func2()
+
+  expect_equal(result1, "reactivity")
+  expect_equal(result2, "none")
+  expect_equal(getOption("shiny.otel.collect"), "all")
+})
+
+test_that("withOtelCollect and localOtelCollect work together", {
+  original <- getOption("shiny.otel.collect")
+  on.exit(options(shiny.otel.collect = original), add = TRUE)
+
+  options(shiny.otel.collect = "all")
+
+  result <- withOtelCollect("reactivity", {
+    outer <- getOption("shiny.otel.collect")
+
+    test_func <- function() {
+      localOtelCollect("none")
+      getOption("shiny.otel.collect")
+    }
+
+    inner <- test_func()
+    restored <- getOption("shiny.otel.collect")
+
+    list(outer = outer, inner = inner, restored = restored)
+  })
+
+  expect_equal(result$outer, "reactivity")
+  expect_equal(result$inner, "none")
+  expect_equal(result$restored, "reactivity")
+  expect_equal(getOption("shiny.otel.collect"), "all")
+})
+
+test_that("withOtelCollect affects otel_collect_is_enabled", {
+  # This tests integration with the otel collection system
+  original <- getOption("shiny.otel.collect")
+  on.exit(options(shiny.otel.collect = original), add = TRUE)
+
+  options(shiny.otel.collect = "all")
+
+  # With "none", nothing except "none" should be enabled
+  result <- withOtelCollect("none", {
+    list(
+      none = otel_collect_is_enabled("none"),
+      session = otel_collect_is_enabled("session"),
+      reactivity = otel_collect_is_enabled("reactivity")
+    )
+  })
+
+  expect_true(result$none)
+  expect_false(result$session)
+  expect_false(result$reactivity)
+
+  # With "reactivity", reactivity and below should be enabled, but not "all"
+  result <- withOtelCollect("reactivity", {
+    list(
+      none = otel_collect_is_enabled("none"),
+      session = otel_collect_is_enabled("session"),
+      reactive_update = otel_collect_is_enabled("reactive_update"),
+      reactivity = otel_collect_is_enabled("reactivity"),
+      all = otel_collect_is_enabled("all")
+    )
+  })
+
+  expect_true(result$none)
+  expect_true(result$session)
+  expect_true(result$reactive_update)
+  expect_true(result$reactivity)
+  expect_false(result$all)
+})
+
+test_that("localOtelCollect affects otel_collect_is_enabled", {
+  original <- getOption("shiny.otel.collect")
+  on.exit(options(shiny.otel.collect = original), add = TRUE)
+
+  options(shiny.otel.collect = "all")
+
+  test_func <- function() {
+    localOtelCollect("reactivity")
+    list(
+      session = otel_collect_is_enabled("session"),
+      reactive_update = otel_collect_is_enabled("reactive_update"),
+      reactivity = otel_collect_is_enabled("reactivity"),
+      all = otel_collect_is_enabled("all")
+    )
+  }
+
+  result <- test_func()
+
+  expect_true(result$session)
+  expect_true(result$reactive_update)
+  expect_true(result$reactivity)
+  expect_false(result$all)
+})

tests/testthat/test-plot-coordmap.R

@@ -1,3 +1,4 @@
+skip_if_not_installed("ggplot2")
 library(ggplot2)
 
 # Sort a list by the names of its keys
@@ -348,12 +349,20 @@ test_that("ggplot coordmap with various scales and coords", {
     sortList(list(left=10, right=20, bottom=0, top=5))
   )
 
+  coord_transform_universal <- function(...) {
+    if (packageVersion("ggplot2") >= "4.0.0") {
+      coord_transform(...)
+    } else {
+      coord_trans(...)
+    }
+  }
+
   # Log scales and log coord transformations
   dat <- data.frame(xvar = c(10^-1, 10^3), yvar = c(2^-2, 2^4))
   p <- ggplot(dat, aes(xvar, yvar)) + geom_point() +
     scale_x_log10(expand = c(0 ,0)) +
     scale_y_continuous(expand = c(0, 0)) +
-    coord_trans(y = "log2")
+    coord_transform_universal(y = "log2")
   png(tmpfile)
   m <- getGgplotCoordmap(print(p), 500, 400, 72)
   dev.off()

tests/testthat/test-promise-domains.R

@@ -1,6 +1,6 @@
 with_several_promise_domains <- function(expr) {
   withReactiveDomain(MockShinySession$new(), {
-    promises::with_promise_domain(reactivePromiseDomain(), {
+    with_promise_domain(reactivePromiseDomain(), {
       captureStackTraces({
         expr
       })

tests/testthat/test-reactives.R

@@ -14,6 +14,140 @@ test_that("can access reactive values directly", {
   expect_equal(y(), 4)
 })
 
+describe("srcfilealias in reactive labels", {
+  # When a #line directive specifies a path that differs from the srcfilecopy
+  # filename, R's parser wraps the srcfile in a srcfilealias whose $lines is
+  # NULL. This is exactly what happens in sourceUTF8() when the normalized path
+  # differs from the original.
+  parse_as_srcfilealias <- function(user_code) {
+    code <- c('#line 1 "/absolute/path/to/app.R"', user_code)
+    src <- base::srcfilecopy("app.R", code, isFile = TRUE)
+    exprs <- parse(text = code, keep.source = TRUE, srcfile = src)
+    list(code = code, exprs = exprs, srcrefs = attr(exprs, "srcref"))
+  }
+
+  it("getSrcfileLines() resolves lines from srcfilealias", {
+    parsed <- parse_as_srcfilealias("my_val <- reactiveVal(1)")
+
+    srcref <- parsed$srcrefs[[1]]
+    srcfile <- attr(srcref, "srcfile", exact = TRUE)
+
+    expect_s3_class(srcfile, "srcfilealias")
+    expect_null(srcfile$lines)
+
+    result <- getSrcfileLines(srcfile, srcref)
+    expect_false(is.null(result$lines))
+    expect_equal(result$lines, parsed$code)
+    expect_match(result$lines[result$line_num], "my_val <- reactiveVal")
+  })
+
+  it("getSrcfileLines() works with regular srcfile", {
+    code <- c("x <- 1", "y <- 2")
+    src <- base::srcfilecopy("test.R", code, isFile = TRUE)
+    exprs <- parse(text = code, keep.source = TRUE, srcfile = src)
+
+    srcref <- attr(exprs, "srcref")[[1]]
+    srcfile <- attr(srcref, "srcfile", exact = TRUE)
+
+    expect_false(inherits(srcfile, "srcfilealias"))
+
+    result <- getSrcfileLines(srcfile, srcref)
+    expect_equal(result$lines, code)
+    expect_equal(result$line_num, 1L)
+  })
+
+  it("rassignSrcrefToLabel() extracts label from srcfilealias", {
+    parsed <- parse_as_srcfilealias("my_val <- reactiveVal(1)")
+    srcref <- parsed$srcrefs[[1]]
+
+    label <- rassignSrcrefToLabel(srcref, defaultLabel = "fallback")
+    expect_equal(label, "my_val")
+  })
+
+  it("rexprSrcrefToLabel() extracts label from srcfilealias", {
+    parsed <- parse_as_srcfilealias("my_r <- reactive({ 1 + 1 })")
+
+    # rexprSrcrefToLabel() expects the srcref of the reactive body (the { }),
+    # not the entire assignment. This mirrors how exprToLabel() calls it with
+    # the srcref from the body of the expression created by installExprFunction.
+    assign_expr <- parsed$exprs[[1]]
+    reactive_body <- assign_expr[[3]][[2]]  # reactive( <body> )
+    body_srcrefs <- attr(reactive_body, "srcref")
+    srcref <- body_srcrefs[[1]]
+
+    label <- rexprSrcrefToLabel(srcref, defaultLabel = "fallback", fnName = "reactive")
+    expect_equal(label, "my_r")
+  })
+})
+
+test_that("sourceUTF8() auto-labels reactives despite srcfilealias", {
+  # sourceUTF8() uses normalizePath() in its #line directive but the original
+  # path for srcfilecopy. When these differ (e.g. macOS /tmp -> /private/tmp),
+  # R creates a srcfilealias whose $lines is NULL. When they match (e.g.
+  # Ubuntu), the #line directive still remaps line numbers. getSrcfileLines()
+  # handles both cases by using srcref[7] (the pre-remap line number).
+  tmp <- tempfile(fileext = ".R")
+  on.exit(unlink(tmp), add = TRUE)
+
+  reactiveConsole(TRUE)
+  on.exit(reactiveConsole(FALSE), add = TRUE)
+
+  writeLines(c(
+    "my_val <- reactiveVal(1)",
+    "my_react <- reactive({ my_val() + 1 })"
+  ), tmp)
+
+  env <- new.env(parent = globalenv())
+  sourceUTF8(tmp, envir = env)
+
+  # reactiveVal label (uses rassignSrcrefToLabel)
+  rv_impl <- attr(env$my_val, ".impl", exact = TRUE)
+  expect_equal(
+    rv_impl$.__enclos_env__$private$label,
+    "my_val"
+  )
+
+  # reactive label (uses rexprSrcrefToLabel via exprToLabel)
+  r_observable <- attr(env$my_react, "observable", exact = TRUE)
+  expect_equal(as.character(r_observable$.label), "my_react")
+})
+
+describe("srcfilealias filename selection", {
+  parse_as_srcfilealias <- function(user_code, alias_path = "/absolute/path/to/app.R") {
+    code <- c(sprintf('#line 1 "%s"', alias_path), user_code)
+    src <- base::srcfilecopy("app.R", code, isFile = TRUE)
+    exprs <- parse(text = code, keep.source = TRUE, srcfile = src)
+    list(code = code, exprs = exprs, srcrefs = attr(exprs, "srcref"))
+  }
+
+  it("getSrcfileFilename() prefers original unless package file", {
+    lib <- normalizePath(.libPaths()[[1]], winslash = "/", mustWork = FALSE)
+    pkg_path <- file.path(lib, "pkg", "R", "foo.R")
+
+    parsed_pkg <- parse_as_srcfilealias("x <- 1", alias_path = pkg_path)
+    srcref_pkg <- parsed_pkg$srcrefs[[1]]
+    srcfile_pkg <- attr(srcref_pkg, "srcfile", exact = TRUE)
+    expect_equal(getSrcfileFilename(srcfile_pkg), pkg_path)
+
+    parsed_user <- parse_as_srcfilealias("y <- 2", alias_path = "/tmp/user.R")
+    srcref_user <- parsed_user$srcrefs[[1]]
+    srcfile_user <- attr(srcref_user, "srcfile", exact = TRUE)
+    expect_equal(getSrcfileFilename(srcfile_user), "app.R")
+  })
+})
+
+test_that("isPackageFile() uses path-boundary matching", {
+  lib <- normalizePath(.libPaths()[[1]], winslash = "/", mustWork = FALSE)
+
+  # A path like "{lib}Extra/foo.R" shares the prefix but is NOT inside the lib
+  fake_path <- paste0(lib, "Extra/foo.R")
+  expect_false(isPackageFile(fake_path))
+
+  # A path actually inside the library SHOULD match
+  real_path <- file.path(lib, "pkg", "R", "foo.R")
+  expect_true(isPackageFile(real_path))
+})
+
 test_that("errors in throttled/debounced reactives are catchable", {
   reactiveConsole(TRUE)
   on.exit(reactiveConsole(FALSE))

tests/testthat/test-reactivity.r

@@ -144,7 +144,7 @@ test_that("reactiveValues keys are sorted", {
 })
 
 test_that("reactiveValues() has useful print method", {
-  verify_output(test_path("print-reactiveValues.txt"), {
+  expect_snapshot_output({
     x <- reactiveValues(x = 1, y = 2, z = 3)
     x
   })
@@ -1656,4 +1656,3 @@ test_that("Contexts can be masked off via promise domains", {
     later::run_now(all=FALSE)
   }
 })
-

tests/testthat/test-stacks-deep.R

@@ -8,7 +8,9 @@ formatError <- function(err, full = FALSE, offset = TRUE, cleanPaths = TRUE) {
     suppressWarnings(
       suppressMessages(
         withCallingHandlers(
-          printError(err, full = full, offset = offset),
+          {
+            printError(err, full = full, offset = offset)
+          },
           warning = function(cnd) {
             cat(conditionMessage(cnd), "\n", sep = "", file = stderr())
           },
@@ -89,6 +91,10 @@ describe("deep stack trace filtering", {
 })
 
 test_that("deep stack capturing", {
+  # base::tryCatch internals changed in 4.5.2
+  skip_unless_r(">= 4.5.2")
+  skip_if_not_installed("testthat", "3.3.0")
+
   `%...>%` <- promises::`%...>%`
   `%...!%` <- promises::`%...!%`
   finally <- promises::finally
@@ -234,6 +240,7 @@ test_that("stack trace stripping works", {
 })
 
 test_that("coro async generator deep stack count is low", {
+  skip_if_not_installed("coro")
   gen <- coro::async_generator(function() {
     for (i in 1:50) {
       await(coro::async_sleep(0.001))

tests/testthat/test-stacks.R

@@ -26,98 +26,19 @@ causeError <- function(full) {
   suppressMessages(df <- extractStackTrace(conditionStackTrace(cond), full = full))
   df$loc <- cleanLocs(df$loc)
   # Compensate for this test being called from different call sites;
-  # whack the
-  df <- head(df, -sys.nframe())
+  # whack the top n frames off using the `num` frame column
+  df <- df[df$num >= sys.nframe(), ]
   df$num <- df$num - sys.nframe()
   df
 }
 
-#' @details `extractStackTrace` takes a list of calls (e.g. as returned
-#'   from `conditionStackTrace(cond)`) and returns a data frame with one
-#'   row for each stack frame and the columns `num` (stack frame number),
-#'   `call` (a function name or similar), and `loc` (source file path
-#'   and line number, if available). It was deprecated after shiny 1.0.5 because
-#'   it doesn't support deep stack traces.
-#' @rdname stacktrace
-#' @export
-extractStackTrace <- function(calls,
-                              full = get_devmode_option("shiny.fullstacktrace", FALSE),
-                              offset = getOption("shiny.stacktraceoffset", TRUE)) {
-
-  srcrefs <- getSrcRefs(calls)
-  if (offset) {
-    # Offset calls vs. srcrefs by 1 to make them more intuitive.
-    # E.g. for "foo [bar.R:10]", line 10 of bar.R will be part of
-    # the definition of foo().
-    srcrefs <- c(utils::tail(srcrefs, -1), list(NULL))
-  }
-  calls <- setSrcRefs(calls, srcrefs)
-
-  callnames <- getCallNames(calls)
-
-  # Hide and show parts of the callstack based on ..stacktrace(on|off)..
-  if (full) {
-    toShow <- rep.int(TRUE, length(calls))
-  } else {
-    # Remove stop(), .handleSimpleError(), and h() calls from the end of
-    # the calls--they don't add any helpful information. But only remove
-    # the last *contiguous* block of them, and then, only if they are the
-    # last thing in the calls list.
-    hideable <- callnames %in% c("stop", ".handleSimpleError", "h")
-    # What's the last that *didn't* match stop/.handleSimpleError/h?
-    lastGoodCall <- max(which(!hideable))
-    toRemove <- length(calls) - lastGoodCall
-    # But don't remove more than 5 levels--that's an indication we might
-    # have gotten it wrong, I guess
-    if (toRemove > 0 && toRemove < 5) {
-      calls <- utils::head(calls, -toRemove)
-      callnames <- utils::head(callnames, -toRemove)
-    }
-
-    # This uses a ref-counting scheme. It might make sense to switch this
-    # to a toggling scheme, so the most recent ..stacktrace(on|off)..
-    # directive wins, regardless of what came before it.
-    # Also explicitly remove ..stacktraceon.. because it can appear with
-    # score > 0 but still should never be shown.
-    score <- rep.int(0, length(callnames))
-    score[callnames == "..stacktraceoff.."] <- -1
-    score[callnames == "..stacktraceon.."] <- 1
-    toShow <- (1 + cumsum(score)) > 0 & !(callnames %in% c("..stacktraceon..", "..stacktraceoff..", "..stacktracefloor.."))
-
-    # doTryCatch, tryCatchOne, and tryCatchList are not informative--they're
-    # just internals for tryCatch
-    toShow <- toShow & !(callnames %in% c("doTryCatch", "tryCatchOne", "tryCatchList"))
-  }
-  calls <- calls[toShow]
-
-  calls <- rev(calls) # Show in traceback() order
-  index <- rev(which(toShow))
-  width <- floor(log10(max(index))) + 1
-
-  data.frame(
-    num = index,
-    call = getCallNames(calls),
-    loc = getLocs(calls),
-    # category = getCallCategories(calls),
-    stringsAsFactors = FALSE
-  )
-}
-
-cleanLocs <- function(locs) {
-  locs[!grepl("test-stacks\\.R", locs, perl = TRUE)] <- ""
-  # sub("^.*#", "", locs)
-  locs
-}
-
-dumpTests <- function(df) {
-  print(bquote({
-    expect_equal(df$num, .(df$num))
-    expect_equal(df$call, .(df$call))
-    expect_equal(nzchar(df$loc), .(nzchar(df$loc)))
-  }))
-}
-
 test_that("integration tests", {
+  if (shiny_otel_tracer()$is_enabled()) {
+    announce_snapshot_file(name = "stacks.md")
+
+    skip("Skipping stack trace tests when OpenTelemetry is already enabled")
+  }
+
   # The expected call stack can be changed by other packages (namely, promises).
   # If promises changes its internals, it can break this test on CRAN. Because
   # CRAN package releases are generally not synchronized (that is, promises and
@@ -127,15 +48,15 @@ test_that("integration tests", {
   # problems on CRAN.
   skip_on_cran()
 
-  df <- causeError(full = FALSE)
-  # dumpTests(df)
+  df_integration_slim <- causeError(full = FALSE)
+  # dumpTests(df_integration_slim)
 
-  expect_snapshot(df)
+  expect_snapshot(df_integration_slim)
 
-  df <- causeError(full = TRUE)
+  df_integration_full <- causeError(full = TRUE)
 
-  expect_snapshot(df)
-  # dumpTests(df)
+  expect_snapshot(df_integration_full)
+  # dumpTests(df_integration_full)
 })
 
 test_that("shiny.error", {
@@ -260,3 +181,170 @@ test_that("observeEvent is not overly stripped (#4162)", {
   expect_match(st_str, "A__", all = FALSE)
   expect_match(st_str, "B__", all = FALSE)
 })
+
+test_that("renderPlot stack trace fences hide internal rendering pipeline (#4357)", {
+  skip_on_cran()
+
+  skip_if_shiny_otel_tracer_is_enabled()
+
+  userFunc <- function() {
+    stop("test error in renderPlot")
+  }
+
+  df <- captureFilteredRenderTrace(renderPlot({ userFunc() }))
+
+  expect_true("userFunc" %in% df$call)
+
+  # Internal rendering pipeline frames should NOT appear in the filtered
+  # stack trace. These are Shiny internals between the stack trace fences
+  # that currently leak through due to missing fences.
+  internal_render_frames <- c(
+    "drawPlot",
+    "drawReactive",
+    "renderFunc",
+    "startPNG"
+  )
+
+  leaked <- df$call[df$call %in% internal_render_frames]
+  expect_length(leaked, 0)
+})
+
+test_that("renderPrint stack trace fences hide internal rendering pipeline (#4357)", {
+  skip_on_cran()
+
+  skip_if_shiny_otel_tracer_is_enabled()
+
+  userFunc <- function() {
+    stop("test error in renderPrint")
+  }
+
+  df <- captureFilteredRenderTrace(renderPrint({ userFunc() }))
+
+  expect_true("userFunc" %in% df$call)
+
+  internal_render_frames <- c("renderFunc")
+  leaked <- df$call[df$call %in% internal_render_frames]
+  expect_length(leaked, 0)
+})
+
+test_that("renderText stack trace fences hide internal rendering pipeline (#4357)", {
+  skip_on_cran()
+
+  skip_if_shiny_otel_tracer_is_enabled()
+
+  userFunc <- function() {
+    stop("test error in renderText")
+  }
+
+  df <- captureFilteredRenderTrace(renderText({ userFunc() }), needs_session = FALSE)
+
+  expect_true("userFunc" %in% df$call)
+
+  internal_render_frames <- c("renderFunc")
+  leaked <- df$call[df$call %in% internal_render_frames]
+  expect_length(leaked, 0)
+})
+
+test_that("renderUI stack trace fences hide internal rendering pipeline (#4357)", {
+  skip_on_cran()
+
+  skip_if_shiny_otel_tracer_is_enabled()
+
+  userFunc <- function() {
+    stop("test error in renderUI")
+  }
+
+  df <- captureFilteredRenderTrace(renderUI({ userFunc() }), needs_session = FALSE)
+
+  expect_true("userFunc" %in% df$call)
+
+  internal_render_frames <- c("renderFunc")
+  leaked <- df$call[df$call %in% internal_render_frames]
+  expect_length(leaked, 0)
+})
+
+test_that("renderTable stack trace fences hide internal rendering pipeline (#4357)", {
+  skip_on_cran()
+
+  skip_if_shiny_otel_tracer_is_enabled()
+
+  userFunc <- function() {
+    stop("test error in renderTable")
+  }
+
+  df <- captureFilteredRenderTrace(
+    renderTable({ userFunc() }, server = FALSE),
+    needs_session = FALSE
+  )
+
+  expect_true("userFunc" %in% df$call)
+
+  internal_render_frames <- c("renderFunc")
+  leaked <- df$call[df$call %in% internal_render_frames]
+  expect_length(leaked, 0)
+})
+
+test_that("renderImage stack trace fences hide internal rendering pipeline (#4357)", {
+  skip_on_cran()
+
+  skip_if_shiny_otel_tracer_is_enabled()
+
+  userFunc <- function() {
+    stop("test error in renderImage")
+  }
+
+  df <- captureFilteredRenderTrace(
+    renderImage({ userFunc() }, deleteFile = FALSE),
+    needs_session = FALSE
+  )
+
+  expect_true("userFunc" %in% df$call)
+
+  internal_render_frames <- c("renderFunc")
+  leaked <- df$call[df$call %in% internal_render_frames]
+  expect_length(leaked, 0)
+})
+
+test_that("legacyRenderDataTable stack trace fences hide internal rendering pipeline (#4357)", {
+  skip_on_cran()
+
+  skip_if_shiny_otel_tracer_is_enabled()
+
+  userFunc <- function() {
+    stop("test error in renderDataTable")
+  }
+
+  df <- captureFilteredRenderTrace(
+    legacyRenderDataTable({ userFunc() })
+  )
+
+  expect_true("userFunc" %in% df$call)
+
+  internal_render_frames <- c("renderFunc")
+  leaked <- df$call[df$call %in% internal_render_frames]
+  expect_length(leaked, 0)
+})
+
+test_that("markRenderFunction preserves user frames outside reactive domain", {
+  skip_on_cran()
+
+  skip_if_shiny_otel_tracer_is_enabled()
+
+  # htmlwidgets-style: exprToFunction + markRenderFunction, no ..stacktraceon..
+  renderWidgetLike <- function(expr, env = parent.frame(), quoted = FALSE) {
+    if (!quoted) expr <- substitute(expr)
+    func <- exprToFunction(expr, env, TRUE)
+    renderFunc <- function() { func() }
+    markRenderFunction(textOutput, renderFunc)
+  }
+
+  userFunc <- function() stop("boom")
+  render_fn <- renderWidgetLike({ userFunc() })
+
+  res <- try(captureStackTraces({ render_fn() }), silent = TRUE)
+  cond <- attr(res, "condition", exact = TRUE)
+  df <- extractStackTrace(conditionStackTrace(cond), full = FALSE)
+
+  expect_true("userFunc" %in% df$call)
+})
+

tests/testthat/test-test-server-app.R

@@ -1,6 +1,3 @@
-library(shiny)
-library(testthat)
-
 test_that("testServer works with dir app", {
   # app.R
   testServer(test_path("..", "test-modules", "06_tabsets"), {
@@ -47,6 +44,7 @@ test_that("runTests works with a dir app that calls modules and uses testServer"
 })
 
 test_that("runTests works with a dir app that calls modules that return reactives and use brushing", {
+  skip_if_not_installed("ggplot2")
   app <- test_path("..", "test-modules", "107_scatterplot")
   run <- testthat::expect_output(
     print(runTests(app)),

tests/testthat/test-test-server-nesting.R

@@ -1,6 +1,3 @@
-library(shiny)
-library(testthat)
-
 test_that("Nested modules", {
   child <- function(id) {
     moduleServer(id, function(input, output, session) {

tests/testthat/test-test-server-scope.R

@@ -1,6 +1,3 @@
-library(shiny)
-library(testthat)
-
 test_that("Variables outside of the module are inaccessible", {
   module <- local({
     outside <- 123

tests/testthat/test-test-server.R

@@ -1,7 +1,5 @@
-library(shiny)
-library(testthat)
+skip_if_not_installed("future")
 library(future, warn.conflicts = FALSE)
-library(promises)
 
 test_that("handles observers", {
   server <- function(input, output, session) {
@@ -290,6 +288,9 @@ test_that("works with async", {
 })
 
 test_that("works with multiple promises in parallel", {
+  # This test is inherently about timing which is against CRAN's policy.
+  testthat::skip_on_cran()
+
   server <- function(input, output, session) {
     output$txt1 <- renderText({
       future({
@@ -746,7 +747,7 @@ test_that("promise chains evaluate in correct order", {
 
   server <- function(input, output, session) {
     r1 <- reactive({
-      promise(function(resolve, reject) {
+      promises::promise(function(resolve, reject) {
         pushMessage("promise 1")
         resolve(input$go)
       })$then(function(value) {
@@ -755,7 +756,7 @@ test_that("promise chains evaluate in correct order", {
       })
     })
     r2 <- reactive({
-      promise(function(resolve, reject) {
+      promises::promise(function(resolve, reject) {
         pushMessage("promise 2")
         resolve(input$go)
       })$then(function(value) {