github/shiny
1
1
Fork 0
mirror of https://github.com/rstudio/shiny.git synced 2026-01-08 22:48:21 -05:00
Code Issues Packages Projects Releases Wiki Activity

feat: Add {otel} support (#4269)

Browse Source
This commit is contained in:
Barret Schloerke
2025-10-14 15:40:36 -04:00
committed by GitHub
parent a01fcc5194
commit 48d255a235
39 changed files with 2095 additions and 301 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
.vscode/settings.json vendored
View File

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

15
DESCRIPTION
View File

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

3
NAMESPACE
View File

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

32
NEWS.md
View File

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

6
R/bind-cache.R
View File

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

42
R/bind-event.R
View File

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

5
R/conditions.R
View File

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

69
R/extended-task.R
View File

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

4
R/globals.R
View File

@@ -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__")
})

24
R/otel-attr-srcref.R Normal file
View File

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

221
R/otel-bind.R Normal file
View File

@@ -0,0 +1,221 @@
# - OpenTelemetry -----------------------------------
# * Integration locations:
# * √ Server:
# * Start reactive_update when reactive busy count > 0
# * End reactive_update when reactive busy count == 0
# * √ Reactives: val, values, expr, render fn, observe
# * Combinations:
# * √ debounce() / throttle()
# * bindCache()
# * √ bindEvent()
# * X - bindProgress()
# * Special functions:
# * ExtendedTask()
# * Extended task links to submission reactive
# * Reactive update that gets result links to the extended task
# * √ observeEvent()
# * √ eventReactive()
# * TODO: Not recording updates within the span!!
# * Maybe enhance all `withReactiveDomain()` calls?
# * Global options:
# * √ shiny.otel.bind:
# * "all", "none" - all or nothing
# * "session" - Adds session start/end events
# * "reactive_update" - Spans for any reactive update. (Includes `"session"` features).
# * "reactivity" - Spans for all reactive things. (Includes `"reactive_update"` features).
# * Private methods:
# * bind_otel_*() - Methods that binds the reactive object to OpenTelemetry spans
# * Note: When adding otel to an object, prepend a class of `FOO.otel`. Then add a dispatch method for `bindOtel.FOO.otel()` that declares the object already has been bound.
# * with_no_otel_bind(expr) - Will not bind any reactives created within `expr` to OpenTelemetry spans.
# - TODO: -----------------------------------
# * Span status for success/failure (render function and regular reactive exprs?)
# * Error handling is not an "exception" for fatal logs
# * Connect `user.id` to be their user name: https://opentelemetry.io/docs/specs/semconv/registry/attributes/user/
# * Tests with otel recording
# ------------------------------------------
# # 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
#'
#' `bind_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 (ospan) will inherit from the parent span.
#' This works well and we can think of the hierarchy as a tree. With
#' `options("shiny.otel.bind" = <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.bind" = "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.bind" = "all"), { ... })`.
#'
#' @param x The object to add caching to.
#' @param ... Future parameter expansion.
#' @noRd
NULL
bind_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
}
bind_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
}
bind_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 <- ospan_label_reactive(x, domain = impl$.domain)
class(x) <- c("reactiveExpr.otel", class(x))
x
}
bind_otel_observe <- function(x) {
x$.isRecordingOtel <- TRUE
x$.otelLabel <- ospan_label_observer(x, domain = x$.domain)
class(x) <- c("Observer.otel", class(x))
invisible(x)
}
bind_otel_shiny_render_function <- function(x) {
valueFunc <- x
span_label <- NULL
ospan_attrs <- attr(x, "otelAttrs")
renderFunc <- function(...) {
# Dynamically determine the span label given the current reactive domain
if (is.null(span_label)) {
span_label <<-
ospan_label_render_function(x, domain = getDefaultReactiveDomain())
}
with_shiny_ospan_async(
span_label,
{
valueFunc(...)
},
attributes = ospan_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."
# ))
# }

193
R/otel-label.R Normal file
View File

@@ -0,0 +1,193 @@
# observe mymod:<anonymous>
# observe <anonymous>
# observe mylabel (edited)
# -- 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
ospan_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"]]
ospan_label <- otel_label_upgrade(label, domain = domain)
sprintf("%s %s", fn_name, ospan_label)
}
ospan_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"
)
ospan_label <- otel_label_upgrade(
getCurrentOutputInfo(session = domain)$name,
domain = domain
)
sprintf("%s %s", fn_name, ospan_label)
}
ospan_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"
)
ospan_label <- otel_label_upgrade(x$.label, domain = domain)
sprintf("%s %s", fn_name, ospan_label)
}
# -- Set reactive value(s) ----------------------------------------------------
otel_label_set_reactive_val <- function(label, ..., domain) {
sprintf(
"Set reactiveVal %s",
otel_label_upgrade(label, domain = domain)
)
}
otel_label_set_reactive_values <- function(label, key, ..., domain) {
sprintf(
"Set reactiveValues %s$%s",
otel_label_upgrade(label, domain = domain),
key
)
}
# -- ExtendedTask -------------------------------------------------------------
otel_label_extended_task <- function(label, suffix = NULL, ..., domain) {
sprintf(
"ExtendedTask %s",
otel_label_upgrade(label, domain = domain)
)
}
otel_label_extended_task_add_to_queue <- function(label, ..., domain) {
sprintf(
"%s add to queue",
otel_label_extended_task(label, domain = domain)
)
}
otel_label_extended_task_set_reactive_val <- function(label, name, ..., domain) {
sprintf(
"Set %s %s",
otel_label_extended_task(label, domain = domain),
name
)
}
# -- Debounce / Throttle -------------------------------------------------------
otel_label_debounce <- function(label, ..., domain) {
sprintf(
"reactive debounce %s",
otel_label_upgrade(label, domain = domain)
)
}
otel_label_throttle <- function(label, ..., domain) {
sprintf(
"reactive throttle %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)
}

98
R/otel-reactive-update.R Normal file
View File

@@ -0,0 +1,98 @@
OSPAN_REACTIVE_UPDATE_NAME <- "reactive_update"
# * `session$userData[["_otel_reactive_update_ospan"]]` - The active reactive update span (or `NULL`)
# * `session$userData[["_otel_has_reactive_cleanup"]]` - Whether the reactive span cleanup has been set
has_reactive_ospan_cleanup <- function(domain) {
isTRUE(domain$userData[["_otel_has_reactive_cleanup"]])
}
set_reactive_ospan_cleanup <- function(domain) {
domain$userData[["_otel_has_reactive_cleanup"]] <- TRUE
}
reactive_update_ospan_is_active <- function(domain) {
isTRUE(domain$userData[["_otel_reactive_update_is_active"]])
}
set_reactive_ospan_is_active <- function(domain) {
domain$userData[["_otel_reactive_update_is_active"]] <- TRUE
}
clear_reactive_ospan_is_active <- function(domain) {
domain$userData[["_otel_reactive_update_is_active"]] <- NULL
}
#' Create a `reactive_update` OpenTelemetry span
#'
#' 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 `end_reactive_update_ospan()`
#' @noRd
create_reactive_update_ospan <- function(..., domain) {
if (!has_otel_bind("reactive_update")) return()
if (!has_reactive_ospan_cleanup(domain)) {
# Clean up any dangling reactive span
domain$onSessionEnded(function() {
if (has_reactive_ospan_cleanup(domain)) {
end_reactive_update_ospan(domain = domain)
}
})
set_reactive_ospan_cleanup(domain)
}
prev_ospan <- domain$userData[["_otel_reactive_update_ospan"]]
if (is_ospan(prev_ospan)) {
stop("Reactive update span already exists")
}
reactive_update_ospan <- create_shiny_ospan(
OSPAN_REACTIVE_UPDATE_NAME,
...,
# options = list(
# parent = NA # Always start a new root span
# ),
attributes = otel_session_id_attrs(domain)
)
domain$userData[["_otel_reactive_update_ospan"]] <- reactive_update_ospan
return(invisible())
}
#' End a `reactive_update` OpenTelemetry span
#' @param ... Ignored
#' @param domain The reactive domain to associate with the span
#' @return Invisibly returns.
#' @seealso `create_reactive_update_ospan()`
#' @noRd
end_reactive_update_ospan <- function(..., domain) {
reactive_update_ospan <- domain$userData[["_otel_reactive_update_ospan"]]
if (is_ospan(reactive_update_ospan)) {
otel::end_span(reactive_update_ospan)
domain$userData[["_otel_reactive_update_ospan"]] <- NULL
}
}
#' 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_reactive_update_active_ospan <- function(expr, ..., domain) {
reactive_update_ospan <- domain$userData[["_otel_reactive_update_ospan"]]
if (!is_ospan(reactive_update_ospan)) {
return(force(expr))
}
# Given the reactive 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(reactive_update_ospan, {force(expr)})
}

82
R/otel-session.R Normal file
View File

@@ -0,0 +1,82 @@
# 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
use_session_start_ospan_async <- function(expr, ..., domain) {
if (!has_otel_bind("session")) {
return(force(expr))
}
id_attrs <- otel_session_id_attrs(domain)
domain$onSessionEnded(function() {
# On close, add session.end event
otel_log("session.end", attributes = id_attrs, severity = "info")
})
# Wrap the server initialization
with_shiny_ospan_async(
"session_start",
expr,
attributes = otel::as_attributes(c(
id_attrs,
otel_session_attrs(domain)
))
)
}
with_session_end_ospan_async <- function(expr, ..., domain) {
if (!has_otel_bind("session")) {
return(force(expr))
}
id_attrs <- otel_session_id_attrs(domain)
with_shiny_ospan_async(
"session_end",
expr,
attributes = id_attrs
)
}
# -- Helpers -------------------------------
otel_session_attrs <- function(domain) {
attrs <- list(
PATH_INFO =
sub(
"/websocket/$", "/",
domain[["request"]][["PATH_INFO"]] %||% ""
),
HTTP_HOST = domain[["request"]][["HTTP_HOST"]] %||% "",
HTTP_ORIGIN = domain[["request"]][["HTTP_ORIGIN"]] %||% "",
QUERY_STRING = domain[["request"]][["QUERY_STRING"]] %||% "",
SERVER_PORT = domain[["request"]][["SERVER_PORT"]] %||% ""
)
try({
attrs[["SERVER_PORT"]] <- as.integer(attrs[["SERVER_PORT"]])
})
attrs
}
otel_session_id_attrs <- function(domain) {
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 = domain$token
)
}

77
R/otel-with.R Normal file
View File

@@ -0,0 +1,77 @@
otel_bind_choices <- c(
"none",
"session",
"reactive_update",
"reactivity",
"all"
)
# Check if the bind level is sufficient
otel_bind_is_enabled <- function(
impl_level,
# Listen to option and fall back to the env var
opt_bind_level = getOption("shiny.otel.bind", Sys.getenv("SHINY_OTEL_BIND", "all"))
) {
opt_bind_level <- as_otel_bind(opt_bind_level)
which(opt_bind_level == otel_bind_choices) >=
which(impl_level == otel_bind_choices)
}
# Check if tracing is enabled and if the bind level is sufficient
has_otel_bind <- function(bind) {
# Only check pkg author input iff loaded with pkgload
if (IS_SHINY_LOCAL_PKG) {
stopifnot(length(bind) == 1, any(bind == otel_bind_choices))
}
otel_is_tracing_enabled() && otel_bind_is_enabled(bind)
}
# with_otel_bind <- function(
# expr,
# ...,
# # bind = getOption("shiny.otel.bind", "all")
# bind
# ) {
# rlang::check_dots_empty()
# bind <- as_otel_bind(bind)
# withr::with_options(
# list(
# shiny.otel.bind = bind
# ),
# expr
# )
# }
# Run expr with otel binding disabled
with_no_otel_bind <- function(expr) {
withr::with_options(
list(
shiny.otel.bind = "none"
),
expr
)
}
## -- Helpers -----------------------------------------------------
# shiny.otel.bind 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_bind <- function(bind = "all") {
if (!is.character(bind)) {
stop("`bind` must be a character vector.")
}
# Match to bind enum
bind <- match.arg(bind, otel_bind_choices, several.ok = FALSE)
return(bind)
}

82
R/otel.R Normal file
View File

@@ -0,0 +1,82 @@
#' @importFrom promises
#' with_ospan_async
#' with_ospan_promise_domain
#' local_ospan_promise_domain
NULL
otel_tracer_name <- "co.posit.r-package.shiny"
with_shiny_ospan_async <- function(name, expr, ..., attributes = NULL) {
with_ospan_async(name, expr, ..., attributes = attributes, tracer = get_tracer())
}
create_shiny_ospan <- function(name, ...) {
otel::start_span(name, ..., tracer = get_tracer())
}
# # TODO: Set attributes on the current active span
# # 5. Set attributes on the current active span
# set_ospan_attrs(status = 200L)
# -- Helpers --------------------------------------------------------------
is_ospan <- function(x) {
inherits(x, "otel_span")
}
testthat__is_testing <- function() {
# testthat::is_testing()
identical(Sys.getenv("TESTTHAT"), "true")
}
otel_log <- function(
msg,
...,
severity = "info",
logger = get_ospan_logger()
) {
otel::log(msg, ..., severity = severity, logger = logger)
}
otel_is_tracing_enabled <- function(tracer = get_tracer()) {
otel::is_tracing_enabled(tracer)
}
get_ospan_logger <- local({
logger <- NULL
function() {
if (!is.null(logger)) {
return(logger)
}
if (testthat__is_testing()) {
# Don't cache the logger in unit tests. It interferes with logger provider
# injection in otelsdk::with_otel_record().
return(otel::get_logger())
}
logger <<- otel::get_logger()
logger
}
})
# Inspired by httr2:::get_tracer().
# Using local scope avoids an environment object lookup on each call.
get_tracer <- local({
tracer <- NULL
function() {
if (!is.null(tracer)) {
return(tracer)
}
if (testthat__is_testing()) {
# Don't cache the tracer in unit tests. It interferes with tracer provider
# injection in otelsdk::with_otel_record().
return(otel::get_tracer())
}
tracer <<- otel::get_tracer()
tracer
}
})

66
R/react.R
View File

@@ -16,6 +16,49 @@ processId <- local({
}
})
ctx_otel_info_obj <- function(
isRecordingOtel = FALSE,
otelLabel = "<unknown>",
otelAttrs = NULL) {
structure(
list(
isRecordingOtel = isRecordingOtel,
otelLabel = otelLabel,
otelAttrs = otelAttrs
),
class = "ctx_otel_info"
)
}
with_context_ospan_async <- 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
with_reactive_update_active_ospan(domain = domain, {
if (isRecordingOtel) {
with_shiny_ospan_async(
otelLabel,
expr,
attributes = otelAttrs
)
} else {
force(expr)
}
})
}
#' @include graph.R
Context <- R6Class(
'Context',
@@ -33,11 +76,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 +93,25 @@ 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."
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_context_ospan_async(.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)
})
})
})
})

2
R/reactive-domains.R
View File

@@ -95,6 +95,8 @@ getDefaultReactiveDomain <- function() {
#' @rdname domains
#' @export
withReactiveDomain <- function(domain, expr) {
# TODO: Integrate `promises:::with_otel_active_span_promise_domain(expr)`
promises::with_promise_domain(createVarPromiseDomain(.globals, "domain", domain), expr)
}

508
R/reactives.R
View File

@@ -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_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,21 @@ ReactiveVal <- R6Class(
#'
#' @export
reactiveVal <- function(value = NULL, label = NULL) {
call_srcref <- attr(sys.call(), "srcref", exact = TRUE)
if (missing(label)) {
call <- sys.call()
label <- rvalSrcrefToLabel(attr(call, "srcref", exact = TRUE))
label <- rassignSrcrefToLabel(
call_srcref,
defaultLabel = paste0("reactiveVal", createUniqueId(4)),
fnName = "reactiveVal"
)
}
rv <- ReactiveVal$new(value, label)
structure(
if (!is.null(call_srcref)) {
rv$.otelAttrs <- otel_srcref_attributes(call_srcref)
}
ret <- structure(
function(x) {
if (missing(x)) {
rv$get()
@@ -224,6 +248,12 @@ reactiveVal <- function(value = NULL, label = NULL) {
label = label,
.impl = rv
)
if (has_otel_bind("reactivity")) {
ret <- bind_otel_reactive_val(ret)
}
ret
}
#' @rdname freezeReactiveValue
@@ -262,8 +292,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
) {
if (is.null(srcref))
return(defaultLabel)
@@ -287,7 +320,10 @@ rvalSrcrefToLabel <- function(srcref,
firstLine <- substring(lines[srcref[1]], srcref[2] - 1)
m <- regexec("\\s*([^[:space:]]+)\\s*(<-|=)\\s*reactiveVal\\b", firstLine)
m <- regexec(
paste0("\\s*([^[:space:]]+)\\s*(<-|=)\\s*", fnName, "\\b"),
firstLine
)
if (m[[1]][1] == -1) {
return(defaultLabel)
}
@@ -330,6 +366,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 +445,17 @@ ReactiveValues <- R6Class(
return(invisible())
}
if ((!is.null(domain)) && .isRecordingOtel) {
# Do not include updates to input or clientData unless _some_ reactivity has occured
if (has_reactive_ospan_cleanup(domain) || !(.label == "input" || .label == "clientData")) {
otel_log(
otel_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 +629,29 @@ 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 <- attr(sys.call(), "srcref", exact = TRUE)
if (!is.null(call_srcref)) {
impl$.label <- rassignSrcrefToLabel(
call_srcref,
# Pass through the random default label created in ReactiveValues$new()
defaultLabel = impl$.label,
fnName = "reactiveValues"
)
impl$.otelAttrs <- otel_srcref_attributes(call_srcref)
}
impl$mset(args)
# Add otel binding after `$mset()` so that we don't log the initial values
# Add otel binding after `.label` so that any logging uses the correct label
values <- maybeAddReactiveValuesOtel(values)
values
}
@@ -597,10 +666,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 binding be attempted?
.createReactiveValues <- function(values = NULL, readonly = FALSE,
ns = identity) {
ns = identity, withOtel = TRUE) {
structure(
ret <- structure(
list(
impl = values,
readonly = readonly,
@@ -608,6 +678,20 @@ checkName <- function(x) {
),
class='reactivevalues'
)
if (withOtel) {
ret <- maybeAddReactiveValuesOtel(ret)
}
ret
}
maybeAddReactiveValuesOtel <- function(x) {
if (!has_otel_bind("reactivity")) {
return(x)
}
bind_otel_reactive_values(x)
}
#' @export
@@ -831,6 +915,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 +973,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
@@ -1017,12 +1115,24 @@ reactive <- function(
label <- exprToLabel(userExpr, "reactive", label)
o <- Observable$new(func, label, domain, ..stacktraceon = ..stacktraceon)
structure(
call_srcref <- attr(sys.call(), "srcref", exact = TRUE)
if (!is.null(call_srcref)) {
o$.otelAttrs <- otel_srcref_attributes(call_srcref)
}
ret <- structure(
o$getValue,
observable = o,
cacheHint = list(userExpr = zap_srcref(userExpr)),
class = c("reactiveExpr", "reactive", "function")
)
if (has_otel_bind("reactivity")) {
ret <- bind_otel_reactive_expr(ret)
}
ret
}
# Given the srcref to a reactive expression, attempts to figure out what the
@@ -1030,7 +1140,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)
@@ -1053,7 +1163,7 @@ rexprSrcrefToLabel <- function(srcref, defaultLabel) {
firstLine <- substring(lines[srcref[1]], 1, srcref[2] - 1)
m <- regexec("(.*)(<-|=)\\s*reactive\\s*\\($", firstLine)
m <- regexec(paste0("(.*)(<-|=)\\s*", fnName, "\\s*\\($"), firstLine)
if (m[[1]][1] == -1) {
return(defaultLabel)
}
@@ -1127,6 +1237,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 +1275,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)) {
@@ -1441,6 +1566,15 @@ observe <- function(
autoDestroy = autoDestroy,
..stacktraceon = ..stacktraceon
)
call_srcref <- attr(sys.call(), "srcref", exact = TRUE)
if (!is.null(call_srcref)) {
o$.otelAttrs <- otel_srcref_attributes(call_srcref)
}
if (has_otel_bind("reactivity")) {
o <- bind_otel_observe(o)
}
invisible(o)
}
@@ -1830,32 +1964,61 @@ coerceToFunc <- function(x) {
reactivePoll <- function(intervalMillis, session, checkFunc, valueFunc) {
intervalMillis <- coerceToFunc(intervalMillis)
rv <- reactiveValues(cookie = isolate(checkFunc()))
label <- "<anonymous>"
try(silent = TRUE, {
reactiveFileReader_call_srcref <- attr(sys.call(-1), "srcref", exact = TRUE)
fnName <- "reactiveFileReader"
label <- rassignSrcrefToLabel(
reactiveFileReader_call_srcref,
defaultLabel = "<anonymous>",
fnName = fnName
)
})
if (label == "<anonymous>") {
# If reactiveFileReader couldn't figure out a label,
# try reactivePoll instead.
call_srcref <- attr(sys.call(), "srcref", exact = TRUE)
fnName <- "reactivePoll"
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_bind({
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
@@ -2017,6 +2180,8 @@ isolate <- function(expr) {
} else {
reactId <- rLog$noReactId
}
# Do not track ospans for `isolate()`
ctx <- Context$new(getDefaultReactiveDomain(), '[isolate]', type='isolate', reactId = reactId)
on.exit(ctx$invalidate())
# Matching ..stacktraceon../..stacktraceoff.. pair
@@ -2294,18 +2459,19 @@ observeEvent <- function(eventExpr, handlerExpr,
eventQ <- exprToQuo(eventExpr, event.env, event.quoted)
handlerQ <- exprToQuo(handlerExpr, handler.env, handler.quoted)
label <- quoToLabel(eventQ, "observeEvent", label)
handler <- inject(observe(
!!handlerQ,
label = label,
suspended = suspended,
priority = priority,
domain = domain,
autoDestroy = TRUE,
..stacktraceon = TRUE
))
with_no_otel_bind({
handler <- inject(observe(
!!handlerQ,
label = label,
suspended = suspended,
priority = priority,
domain = domain,
autoDestroy = TRUE,
..stacktraceon = TRUE
))
})
o <- inject(bindEvent(
ignoreNULL = ignoreNULL,
@@ -2333,14 +2499,29 @@ 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)
call_srcref <- attr(sys.call(), "srcref", exact = TRUE)
if (is.null(label)) {
label <- rassignSrcrefToLabel(
call_srcref,
defaultLabel = exprToLabel(userEventExpr, "eventReactive", label),
fnName = "eventReactive"
)
}
with_no_otel_bind({
value_r <- inject(reactive(!!valueQ, domain = domain, label = label))
})
invisible(inject(bindEvent(
ignoreNULL = ignoreNULL,
ignoreInit = ignoreInit,
label = label,
!!eventQ,
x = reactive(!!valueQ, domain = domain, label = label)
x = value_r
)))
}
@@ -2456,71 +2637,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 <- attr(sys.call(), "srcref", exact = TRUE)
label <- rassignSrcrefToLabel(
call_srcref,
defaultLabel = "<anonymous>",
fnName = "debounce"
)
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_bind({
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", 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)
})
with_no_otel_bind({
# 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 +2741,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 <- attr(sys.call(), "srcref", exact = TRUE)
label <- rassignSrcrefToLabel(
call_srcref,
defaultLabel = "<anonymous>",
fnName = "throttle"
)
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_bind({
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_bind({
# 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
}

23
R/runapp.R
View File

@@ -84,13 +84,22 @@
#' 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)) {
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
local_ospan_promise_domain()
on.exit({
handlerManager$clear()
}, add = TRUE)

21
R/server.R
View File

@@ -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
)
use_session_start_ospan_async(domain = shinysession, {
do.call(
# No corresponding ..stacktraceoff; the server func is pure
# user code
wrapFunctionLabel(appvars$server, "server",
..stacktraceon = TRUE
),
args
)
})
})
})
},
update = {

17
R/shiny-options.R
View File

@@ -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,21 @@ 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.bind (defaults to `Sys.getenv("SHINY_OTEL_BIND", "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. (Includes `"reactive_update"` features).
#' * `"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 starting your Shiny app.}
#' \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)`.}
#' }
#'
#'

6
R/shiny-package.R
View File

@@ -41,3 +41,9 @@ release_bullets <- function() {
"Update static imports: `staticimports::import()`"
)
}
# To get around R CMD check lint
`_ignore` <- function() {
otelsdk::with_otel_record
}

45
R/shiny.R
View File

@@ -1056,6 +1056,21 @@ ShinySession <- R6Class(
class(e) <- c("shiny.error.fatal", class(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 =
# Do not expose errors to otel if sanitization is enabled
if (getOption("shiny.otel.sanitize.errors", TRUE)) {
sanitized_error()
} else {
e
}
))
)
private$unhandledErrorCallbacks$invoke(e, onError = printError)
.globals$onUnhandledErrorCallbacks$invoke(e, onError = printError)
@@ -1073,7 +1088,9 @@ ShinySession <- R6Class(
}
# ..stacktraceon matches with the top-level ..stacktraceoff..
withReactiveDomain(self, {
private$closedCallbacks$invoke(onError = printError, ..stacktraceon = TRUE)
with_session_end_ospan_async(domain = self, {
private$closedCallbacks$invoke(onError = printError, ..stacktraceon = TRUE)
})
})
},
isClosed = function() {
@@ -1142,7 +1159,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_bind(observe(..stacktraceon = FALSE, {
private$sendMessage(recalculating = list(
name = name, status = 'recalculating'
@@ -1151,10 +1169,14 @@ ShinySession <- R6Class(
# This shinyCallingHandlers should maybe be at a higher level,
# to include the $then/$catch calls below?
hybrid_chain(
# TODO: Move ospan wrapper here to capture return value
hybrid_chain(
{
private$withCurrentOutput(name, {
shinyCallingHandlers(func())
# TODO: Error handling must be done within ospan methods to get the proper status value. There is currently no way to access a already closed span from within `func()`.
with_reactive_update_active_ospan({
shinyCallingHandlers(func())
}, domain = self)
})
},
catch = function(cond) {
@@ -1179,9 +1201,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 +1265,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.
@@ -2195,6 +2215,8 @@ ShinySession <- R6Class(
if (private$busyCount == 0L) {
rLog$asyncStart(domain = self)
private$sendMessage(busy = "busy")
create_reactive_update_ospan(domain = self)
}
private$busyCount <- private$busyCount + 1L
},
@@ -2216,6 +2238,8 @@ ShinySession <- R6Class(
private$startCycle()
}
})
end_reactive_update_ospan(domain = self)
}
}
)
@@ -2723,3 +2747,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."))
}

30
R/shinywrappers.R
View File

@@ -134,7 +134,12 @@ markRenderFunction <- function(
else renderFunc(...)
}
structure(
otelAttrs <-
otel_srcref_attributes(
attr(renderFunc, "wrappedFunc", exact = TRUE)
)
ret <- structure(
wrappedRenderFunc,
class = c("shiny.render.function", "function"),
outputFunc = uiFunc,
@@ -142,8 +147,15 @@ markRenderFunction <- function(
hasExecuted = hasExecuted,
cacheHint = cacheHint,
cacheWriteHook = cacheWriteHook,
cacheReadHook = cacheReadHook
cacheReadHook = cacheReadHook,
otelAttrs = otelAttrs
)
if (has_otel_bind("reactivity")) {
ret <- bind_otel_shiny_render_function(ret)
}
ret
}
#' @export
@@ -271,9 +283,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 +331,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 +393,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.
@@ -815,9 +825,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()) {

32
R/utils-lang.R
View File

@@ -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")
}

4
R/utils.R
View File

@@ -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)
}

2
inst/www/shared/busy-indicators/busy-indicators.css
View File

@@ -1,2 +1,2 @@
/*! shiny 1.11.1.9000 | (c) 2012-2025 Posit Software, PBC. | License: GPL-3 | file LICENSE */
/*! shiny 1.11.1.9001 | (c) 2012-2025 Posit Software, PBC. | License: GPL-3 | 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}

2
inst/www/shared/shiny-autoreload.js
View File

@@ -1,3 +1,3 @@
/*! shiny 1.11.1.9000 | (c) 2012-2025 Posit Software, PBC. | License: GPL-3 | file LICENSE */
/*! shiny 1.11.1.9001 | (c) 2012-2025 Posit Software, PBC. | License: GPL-3 | 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

2
inst/www/shared/shiny-showcase.css
View File

@@ -1,2 +1,2 @@
/*! shiny 1.11.1.9000 | (c) 2012-2025 Posit Software, PBC. | License: GPL-3 | file LICENSE */
/*! shiny 1.11.1.9001 | (c) 2012-2025 Posit Software, PBC. | License: GPL-3 | 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}

2
inst/www/shared/shiny-showcase.js
View File

@@ -1,3 +1,3 @@
/*! shiny 1.11.1.9000 | (c) 2012-2025 Posit Software, PBC. | License: GPL-3 | file LICENSE */
/*! shiny 1.11.1.9001 | (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();})();
//# sourceMappingURL=shiny-showcase.js.map

2
inst/www/shared/shiny-testmode.js
View File

@@ -1,3 +1,3 @@
/*! shiny 1.11.1.9000 | (c) 2012-2025 Posit Software, PBC. | License: GPL-3 | file LICENSE */
/*! shiny 1.11.1.9001 | (c) 2012-2025 Posit Software, PBC. | License: GPL-3 | 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

4
inst/www/shared/shiny.js
View File

@@ -1,4 +1,4 @@
/*! shiny 1.11.1.9000 | (c) 2012-2025 Posit Software, PBC. | License: GPL-3 | file LICENSE */
/*! shiny 1.11.1.9001 | (c) 2012-2025 Posit Software, PBC. | License: GPL-3 | 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.11.1.9001";
const { inputBindings, fileInputBinding: fileInputBinding2 } = initInputBindings();
const { outputBindings } = initOutputBindings();
setFileInputBinding(fileInputBinding2);

4
inst/www/shared/shiny.min.js vendored
View File

File diff suppressed because one or more lines are too long

17
man/shinyOptions.Rd
View File

@@ -130,6 +130,23 @@ 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.bind (defaults to \code{Sys.getenv("SHINY_OTEL_BIND", "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. (Includes \code{"reactive_update"} features).
\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 starting your Shiny app.}
\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)}.}
}
}

2
package.json
View File

@@ -5,7 +5,7 @@
"url": "git+https://github.com/rstudio/shiny.git"
},
"name": "@posit/shiny",
"version": "1.11.1-alpha.9000",
"version": "1.11.1-alpha.9001",
"license": "GPL-3.0-only",
"main": "",
"browser": "",

156
tests/testthat/_snaps/stacks.md
View File

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

491
tests/testthat/helper-barret.R Normal file
View File

@@ -0,0 +1,491 @@
# Personal debugging function -------------------------------
# system("air format ./R/bind-otel.R")
# Rscript -e "devtools::load_all(); devtools::load_all(\"~/rstudio/ellmer/ellmer.nosync\"); dev_barret()"
# # TODO: Remove this function when done debugging
# dev_barret <- function() {
# ## Ospan pkgs
# # pak::pak("cran::mirai", upgrade = TRUE)
# # pak::pak("r-lib/httr2#729")
# # pak::pak("tidyverse/ellmer#526")
# ## Prettier tool calls
# # pak::pak("rstudio/shinychat/pkg-r")
# withr::with_options(
# list(
# OTEL_TRACES_EXPORTER = Sys.getenv("LOGFIRE_OTEL_TRACES_EXPORTER"),
# OTEL_EXPORTER_OTLP_ENDPOINT = Sys.getenv(
# "LOGFIRE_OTEL_EXPORTER_OTLP_ENDPOINT"
# ),
# OTEL_EXPORTER_OTLP_HEADERS = Sys.getenv(
# "LOGFIRE_OTEL_EXPORTER_OTLP_HEADERS"
# ),
# OTEL_LOGS_EXPORTER = Sys.getenv("LOGFIRE_OTEL_LOGS_EXPORTER"),
# OTEL_LOG_LEVEL = Sys.getenv("LOGFIRE_OTEL_LOG_LEVEL"),
# OTEL_METRICS_EXPORTER = Sys.getenv("LOGFIRE_OTEL_METRICS_EXPORTER")
# ),
# {
# mirai::daemons(1)
# bind_val <- "none"
# # bind_val <- "all"
# # Enhanced from: https://posit-dev.github.io/shinychat/r/articles/tool-ui.html#alternative-html-display
# get_weather_forecast <- ellmer::tool(
# function(lat, lon, location_name) {
# mirai::mirai(
# {
# otel::log_info(
# "Getting weather forecast",
# logger = otel::get_logger("weather-app")
# )
# forecast_data <- weathR::point_tomorrow(lat, lon, short = FALSE)
# forecast_table <- gt::as_raw_html(gt::gt(forecast_data))
# list(data = forecast_data, table = forecast_table)
# },
# lat = lat,
# lon = lon
# ) |>
# promises::then(function(forecast_info) {
# ellmer::ContentToolResult(
# forecast_info$data,
# extra = list(
# display = list(
# html = forecast_info$table,
# title = paste("Weather Forecast for", location_name)
# )
# )
# )
# })
# },
# name = "get_weather_forecast",
# description = "Get the weather forecast for a location.",
# arguments = list(
# lat = ellmer::type_number("Latitude"),
# lon = ellmer::type_number("Longitude"),
# location_name = ellmer::type_string(
# "Name of the location for display to the user"
# )
# ),
# annotations = ellmer::tool_annotations(
# title = "Weather Forecast",
# icon = bsicons::bs_icon("cloud-sun")
# )
# )
# client <- ellmer::chat_anthropic("Be terse.")
# client$register_tool(get_weather_forecast)
# ui <- bslib::page_fillable(
# shinychat::chat_mod_ui("chat", height = "100%"),
# actionButton(
# "close_btn",
# label = "",
# class = "btn-close",
# style = "position: fixed; top: 6px; right: 6px;"
# )
# )
# server <- function(input, output, session) {
# with_no_otel_bind({
# chat_server <- shinychat::chat_mod_server("chat", client, session)
# })
# with_no_otel_bind({
# observeEvent(input$close_btn, {
# stopApp()
# })
# })
# # with_no_otel_bind({
# # output$boom <- renderUI({
# # stop("Boom!")
# # })
# # })
# with_no_otel_bind({
# counter <- reactiveVal(1)
# observeEvent(chat_server$last_turn(), {
# counter(counter() + 1)
# })
# observeEvent(counter(), label = "barret_is_lazy", {
# if (counter() == 1) {
# later::later(
# function() {
# chat_server$update_user_input(
# value = "What is the weather in Atlanta, GA?",
# submit = TRUE
# )
# },
# delay = 1
# )
# } else {
# later::later(
# function() {
# later::later(
# function() {
# message("Stopping app")
# stopApp()
# },
# delay = 0.5
# )
# message("Stopping session")
# session$close()
# },
# delay = 3
# )
# }
# })
# })
# }
# app <- shinyApp(ui, server)
# runApp(app, port = 8080, launch.browser = TRUE)
# }
# )
# }
# -------------------------------------------------------------------
#
#
#
#
#
#
#
#
#
#
#
#
#
#
#
#
#
#
#
#
#
#
#
#
#
#
#
# - Kitchen sink app ---------------------------------
dev_barret_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
# TODO: Maybe the name is the folder name, similar to shinyapps.io naming
# Maybe set from a function call somewhere?
# otel_tracer <- otel::get_tracer("my-app")
otel_logger <- otel::get_logger("my-app-logger")
# options("shiny.otel.tracer" = otel_tracer)
# withr::with_environment(globalenv(), {
otel_tracer_name <- "my-app"
# })
log_and_msg <- function(..., .envir = parent.frame()) {
msg <- paste(...)
message(" -- ", msg)
# otel::log_info(msg, tracer = session$userData[["_otel_tracer"]])
# TODO: Remove the logger param once function is removed from Shiny package
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-txt"),
# bslib::input_task_button("recalculate", "Recalculate"),
verbatimTextOutput("task_result")
),
server = function(input, output, session) {
log_and_msg("Start new Shiny session")
b <- reactiveVal(1)
observe(b(42))
# shiny::bindOtel(TRUE)
shutdown <- function() {
later::later(
function() {
message("\n\nClosing session for minimal logfire graphs")
# session$close()
# httpuv::stopAllServers()
stopApp()
mirai::daemons(0)
},
delay = 100 / 1000
)
}
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)
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$txt <- renderText({
calc()
}) |>
bindCache(x(), y())
rand_task <- ExtendedTask$new(function() {
mirai::mirai(
{
# Slow operation goes here
Sys.sleep(100 / 1000)
sample(1:100, 1)
}
)
})
# # Make button state reflect task.
# # If using R >=4.1, you can do this instead:
# # rand_task <- ExtendedTask$new(...) |> bind_task_button("recalculate")
# bslib::bind_task_button(rand_task, "recalculate")
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
}

4
tests/testthat/test-stacks-deep.R
View File

@@ -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())
},