From 48d255a235d8c2646d2a975569edf2617f131634 Mon Sep 17 00:00:00 2001 From: Barret Schloerke Date: Tue, 14 Oct 2025 15:40:36 -0400 Subject: [PATCH] feat: Add `{otel}` support (#4269) --- .vscode/settings.json | 1 + DESCRIPTION | 15 +- NAMESPACE | 3 + NEWS.md | 32 +- R/bind-cache.R | 6 +- R/bind-event.R | 42 +- R/conditions.R | 5 +- R/extended-task.R | 69 ++- R/globals.R | 4 + R/otel-attr-srcref.R | 24 + R/otel-bind.R | 221 ++++++++ R/otel-label.R | 193 +++++++ R/otel-reactive-update.R | 98 ++++ R/otel-session.R | 82 +++ R/otel-with.R | 77 +++ R/otel.R | 82 +++ R/react.R | 66 ++- R/reactive-domains.R | 2 + R/reactives.R | 508 +++++++++++++----- R/runapp.R | 23 +- R/server.R | 21 +- R/shiny-options.R | 17 +- R/shiny-package.R | 6 + R/shiny.R | 45 +- R/shinywrappers.R | 30 +- R/utils-lang.R | 32 +- R/utils.R | 4 +- .../busy-indicators/busy-indicators.css | 2 +- inst/www/shared/shiny-autoreload.js | 2 +- inst/www/shared/shiny-showcase.css | 2 +- inst/www/shared/shiny-showcase.js | 2 +- inst/www/shared/shiny-testmode.js | 2 +- inst/www/shared/shiny.js | 4 +- inst/www/shared/shiny.min.js | 4 +- man/shinyOptions.Rd | 17 + package.json | 2 +- tests/testthat/_snaps/stacks.md | 156 +++--- tests/testthat/helper-barret.R | 491 +++++++++++++++++ tests/testthat/test-stacks-deep.R | 4 +- 39 files changed, 2095 insertions(+), 301 deletions(-) create mode 100644 R/otel-attr-srcref.R create mode 100644 R/otel-bind.R create mode 100644 R/otel-label.R create mode 100644 R/otel-reactive-update.R create mode 100644 R/otel-session.R create mode 100644 R/otel-with.R create mode 100644 R/otel.R create mode 100644 tests/testthat/helper-barret.R diff --git a/.vscode/settings.json b/.vscode/settings.json index 695c9248b..93c9ae7a9 100644 --- a/.vscode/settings.json +++ b/.vscode/settings.json @@ -6,6 +6,7 @@ "[r]": { "files.trimTrailingWhitespace": true, "files.insertFinalNewline": true, + "editor.formatOnSave": false, }, "[typescript]": { "editor.defaultFormatter": "esbenp.prettier-vscode", diff --git a/DESCRIPTION b/DESCRIPTION index 9cafb265c..5391507b8 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Type: Package Package: shiny Title: Web Application Framework for R -Version: 1.11.1.9000 +Version: 1.11.1.9001 Authors@R: c( person("Winston", "Chang", , "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' diff --git a/NAMESPACE b/NAMESPACE index 65d93444c..93304b631 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -388,9 +388,12 @@ importFrom(promises,"%...!%") importFrom(promises,"%...>%") importFrom(promises,as.promise) importFrom(promises,is.promising) +importFrom(promises,local_ospan_promise_domain) importFrom(promises,promise) importFrom(promises,promise_reject) importFrom(promises,promise_resolve) +importFrom(promises,with_ospan_async) +importFrom(promises,with_ospan_promise_domain) importFrom(rlang,"%||%") importFrom(rlang,"fn_body<-") importFrom(rlang,"fn_fmls<-") diff --git a/NEWS.md b/NEWS.md index c50ffd113..90fee0a2d 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,33 @@ # shiny (development version) +## OpenTelemetry support (#4269) + +* Added support for [OpenTelemetry](https://opentelemetry.io/) via [`{otel}`](https://otel.r-lib.org/index.html). By default, if `otel::is_tracing_enabled()` returns `TRUE`, then `{shiny}` will record all OpenTelemetery spans. See [`{otelsdk}`'s Collecting Telemetry Data](https://otelsdk.r-lib.org/reference/collecting.html) for more details on configuring OpenTelemetry. + +* Supported values for `options(shiny.otel.bind)` (or `Sys.getenv("SHINY_OTEL_BIND")`): + * `"none"` - No Shiny OpenTelemetry tracing. + * `"session"` - Adds session start/end spans. + * `"reactive_update"` - Spans for any synchronous/asynchronous reactive update. (Includes `"session"` features). + * `"reactivity"` - Spans for all reactive expressions. (Includes `"reactive_update"` features). + * `"all"` [default] - All Shiny OpenTelemetry tracing. Currently equivalent to `"reactivity"`. + +* Spans are recorded for: + * `session_start`: Wraps the calling of the `server()` function. Also contains HTTP request within the attributes. + * `session_end`: Wraps the calling of the `onSessionEnded()` handlers. + * `reactive_update`: Signals the start of when Shiny knows something is to be calculated. This span ends when there are no more reactive updates (promises or synchronous) to be calculated. + * `reactive`, `observe`, `output`: Captures the calculation (including any async promise chains) of a reactive expression (`reactive()`), an observer (`observe()`), or an output render function (`render*()`). + * `reactive debounce`, `reactive throttle`: Captures the calculation (including any async promise chains) of a `debounce()`d or `throttle()`d reactive expression. + * `ExtendedTask`: Captures the calculation (including any async promise chains) of an `ExtendedTask`. + +* OpenTelemetry Logs are recorded for: + * `Set reactiveVal ` - When a `reactiveVal()` is set + * `Set reactiveValues $` - 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 ` - When an `ExtendedTask`'s respective reactive value (e.g., `status`, `value`, and `error`) is set. + * ` 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 diff --git a/R/bind-cache.R b/R/bind-cache.R index 013a1db5d..80a8da35d 100644 --- a/R/bind-cache.R +++ b/R/bind-cache.R @@ -478,7 +478,7 @@ bindCache.default <- function(x, ...) { bindCache.reactiveExpr <- function(x, ..., cache = "app") { check_dots_unnamed() - label <- exprToLabel(substitute(key), "cachedReactive") + label <- exprToLabel(substitute(x), "cachedReactive") domain <- reactive_get_domain(x) # Convert the ... to a function that returns their evaluated values. @@ -494,8 +494,8 @@ bindCache.reactiveExpr <- function(x, ..., cache = "app") { rm(x) # Hacky workaround for issue with `%>%` preventing GC: # https://github.com/tidyverse/magrittr/issues/229 - if (exists(".GenericCallEnv") && exists(".", envir = .GenericCallEnv)) { - rm(list = ".", envir = .GenericCallEnv) + if (exists(".GenericCallEnv") && exists(".", envir = .GenericCallEnv, inherits = FALSE)) { + rm(list = ".", envir = .GenericCallEnv, inherits = FALSE) } diff --git a/R/bind-event.R b/R/bind-event.R index 31cebb096..43f0aeaf7 100644 --- a/R/bind-event.R +++ b/R/bind-event.R @@ -199,28 +199,39 @@ bindEvent.reactiveExpr <- function(x, ..., ignoreNULL = TRUE, ignoreInit = FALSE label <- label %||% sprintf('bindEvent(%s, %s)', attr(x, "observable", exact = TRUE)$.label, quos_to_label(qs)) + x_classes <- class(x) + # Don't hold on to the reference for x, so that it can be GC'd rm(x) initialized <- FALSE - res <- reactive(label = label, domain = domain, ..stacktraceon = FALSE, { - hybrid_chain( - eventFunc(), - function(value) { - if (ignoreInit && !initialized) { - initialized <<- TRUE - req(FALSE) + with_no_otel_bind({ + res <- reactive(label = label, domain = domain, ..stacktraceon = FALSE, { + hybrid_chain( + { + eventFunc() + }, + function(value) { + if (ignoreInit && !initialized) { + initialized <<- TRUE + req(FALSE) + } + + req(!ignoreNULL || !isNullEvent(value)) + + 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) } diff --git a/R/conditions.R b/R/conditions.R index 2b3ae0161..1c128e6c4 100644 --- a/R/conditions.R +++ b/R/conditions.R @@ -556,8 +556,9 @@ dropTrivialTestFrames <- function(callnames) { "testthat::test_local" ) - firstGoodCall <- min(which(!hideable)) - toRemove <- firstGoodCall - 1L + # Remove everything from inception to calling the test + # It shouldn't matter how you get there, just that you're finally testing + toRemove <- max(which(hideable)) c( rep_len(FALSE, toRemove), diff --git a/R/extended-task.R b/R/extended-task.R index 800b72d35..7ead173dd 100644 --- a/R/extended-task.R +++ b/R/extended-task.R @@ -116,10 +116,41 @@ ExtendedTask <- R6Class("ExtendedTask", portable = TRUE, cloneable = FALSE, #' read reactive inputs and pass them as arguments. initialize = function(func) { private$func <- func - private$rv_status <- reactiveVal("initial") - private$rv_value <- reactiveVal(NULL) - private$rv_error <- reactiveVal(NULL) + + # Do not show these private reactive values in otel spans + with_no_otel_bind({ + private$rv_status <- reactiveVal("initial") + private$rv_value <- reactiveVal(NULL) + private$rv_error <- reactiveVal(NULL) + }) + private$invocation_queue <- fastmap::fastqueue() + + domain <- getDefaultReactiveDomain() + + # Set a label for the reactive values for easier debugging + # Go up an extra sys.call() to get the user's call to ExtendedTask$new() + # The first sys.call() is to `initialize(...)` + call_srcref <- attr(sys.call(-1), "srcref", exact = TRUE) + label <- rassignSrcrefToLabel( + call_srcref, + defaultLabel = "", + 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) } ) diff --git a/R/globals.R b/R/globals.R index d80647899..fb26afa46 100644 --- a/R/globals.R +++ b/R/globals.R @@ -25,3 +25,7 @@ on_load_exprs <- list() on_load <- function(expr) { on_load_exprs[[length(on_load_exprs) + 1]] <<- substitute(expr) } + +on_load({ + IS_SHINY_LOCAL_PKG <- exists(".__DEVTOOLS__") +}) diff --git a/R/otel-attr-srcref.R b/R/otel-attr-srcref.R new file mode 100644 index 000000000..d62c0fde8 --- /dev/null +++ b/R/otel-attr-srcref.R @@ -0,0 +1,24 @@ + + +# Very similar to srcrefFromShinyCall(), +# however, this works when the function does not have a srcref attr set +otel_srcref_attributes <- function(srcref) { + if (is.function(srcref)) { + srcref <- getSrcRefs(srcref)[[1]][[1]] + } + + if (is.null(srcref)) { + return(NULL) + } + + stopifnot(inherits(srcref, "srcref")) + + # Semantic conventions for code: https://opentelemetry.io/docs/specs/semconv/registry/attributes/code/ + # + # Inspiration from https://github.com/r-lib/testthat/pull/2087/files#diff-92de3306849d93d6f7e76c5aaa1b0c037e2d716f72848f8a1c70536e0c8a1564R123-R124 + dropNulls(list( + "code.filepath" = attr(srcref, "srcfile")$filename, + "code.lineno" = srcref[1], + "code.column" = srcref[2] + )) +} diff --git a/R/otel-bind.R b/R/otel-bind.R new file mode 100644 index 000000000..e3b71fe79 --- /dev/null +++ b/R/otel-bind.R @@ -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" = )`, 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." +# )) +# } diff --git a/R/otel-label.R b/R/otel-label.R new file mode 100644 index 000000000..f3426d4e3 --- /dev/null +++ b/R/otel-label.R @@ -0,0 +1,193 @@ +# observe mymod: +# observe +# 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 `` + # (Similar with `eventReactive()` and `observeEvent()`) + if (is_default_label(label) && grepl("(", label, fixed = TRUE)) { + label <- "" + # label <- sprintf(" - %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) +} diff --git a/R/otel-reactive-update.R b/R/otel-reactive-update.R new file mode 100644 index 000000000..98f97afbf --- /dev/null +++ b/R/otel-reactive-update.R @@ -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)}) +} diff --git a/R/otel-session.R b/R/otel-session.R new file mode 100644 index 000000000..82b5794d3 --- /dev/null +++ b/R/otel-session.R @@ -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 + ) +} diff --git a/R/otel-with.R b/R/otel-with.R new file mode 100644 index 000000000..5feeb92e8 --- /dev/null +++ b/R/otel-with.R @@ -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) +} diff --git a/R/otel.R b/R/otel.R new file mode 100644 index 000000000..d6fc5a435 --- /dev/null +++ b/R/otel.R @@ -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 + } +}) diff --git a/R/react.R b/R/react.R index bdc0f4a93..c3a3ff13e 100644 --- a/R/react.R +++ b/R/react.R @@ -16,6 +16,49 @@ processId <- local({ } }) +ctx_otel_info_obj <- function( + isRecordingOtel = FALSE, + otelLabel = "", + 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) + }) }) }) }) diff --git a/R/reactive-domains.R b/R/reactive-domains.R index 2c8d9720a..6f0fb813c 100644 --- a/R/reactive-domains.R +++ b/R/reactive-domains.R @@ -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) } diff --git a/R/reactives.R b/R/reactives.R index a5f7772b6..4a3ea114a 100644 --- a/R/reactives.R +++ b/R/reactives.R @@ -79,19 +79,26 @@ ReactiveVal <- R6Class( dependents = NULL ), public = list( + .isRecordingOtel = FALSE, # Needs to be set by Shiny + .otelLabel = NULL, # Needs to be set by Shiny + .otelAttrs = NULL, # Needs to be set by Shiny + initialize = function(value, label = NULL) { reactId <- nextGlobalReactId() private$reactId <- reactId private$value <- value private$label <- label private$dependents <- Dependents$new(reactId = private$reactId) - rLog$define(private$reactId, value, private$label, type = "reactiveVal", getDefaultReactiveDomain()) + + domain <- getDefaultReactiveDomain() + rLog$define(private$reactId, value, private$label, type = "reactiveVal", domain) + .otelLabel <<- otel_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 <- "" + try(silent = TRUE, { + reactiveFileReader_call_srcref <- attr(sys.call(-1), "srcref", exact = TRUE) + fnName <- "reactiveFileReader" + label <- rassignSrcrefToLabel( + reactiveFileReader_call_srcref, + defaultLabel = "", + fnName = fnName + ) + }) + + if (label == "") { + # 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 = "", + 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 = "", + 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 = "", + 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 } diff --git a/R/runapp.R b/R/runapp.R index d302bc117..4bcf49910 100644 --- a/R/runapp.R +++ b/R/runapp.R @@ -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) diff --git a/R/server.R b/R/server.R index 0a8e54cae..845a547e8 100644 --- a/R/server.R +++ b/R/server.R @@ -274,15 +274,20 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) { args <- argsForServerFunc(serverFunc, shinysession) withReactiveDomain(shinysession, { - do.call( - # No corresponding ..stacktraceoff; the server func is pure - # user code - wrapFunctionLabel(appvars$server, "server", - ..stacktraceon = TRUE - ), - args - ) + 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 = { diff --git a/R/shiny-options.R b/R/shiny-options.R index befb4b6c2..63c77c109 100644 --- a/R/shiny-options.R +++ b/R/shiny-options.R @@ -70,7 +70,7 @@ getShinyOption <- function(name, default = NULL) { #' #' You can customize the file patterns Shiny will monitor by setting the #' shiny.autoreload.pattern option. For example, to monitor only `ui.R`: -#' `options(shiny.autoreload.pattern = glob2rx("ui.R"))`. +#' `options(shiny.autoreload.pattern = glob2rx("ui.R"))`. #' #' As mentioned above, Shiny no longer polls watched files for changes. #' Instead, using \pkg{watcher}, Shiny is notified of file changes as they @@ -160,6 +160,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)`.} #' } #' #' diff --git a/R/shiny-package.R b/R/shiny-package.R index 2ee47b7af..c2cab6ddf 100644 --- a/R/shiny-package.R +++ b/R/shiny-package.R @@ -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 +} diff --git a/R/shiny.R b/R/shiny.R index c5e1eadc1..b63442744 100644 --- a/R/shiny.R +++ b/R/shiny.R @@ -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.")) +} diff --git a/R/shinywrappers.R b/R/shinywrappers.R index 3649fe6cd..5672cf3a3 100644 --- a/R/shinywrappers.R +++ b/R/shinywrappers.R @@ -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()) { diff --git a/R/utils-lang.R b/R/utils-lang.R index db272ebe4..60db1e4c7 100644 --- a/R/utils-lang.R +++ b/R/utils-lang.R @@ -208,8 +208,10 @@ exprToLabel <- function(expr, function_name, label = NULL) { if (is.null(label)) { label <- rexprSrcrefToLabel( srcref[[1]], - simpleExprToFunction(expr, function_name) + simpleExprToFunction(expr, function_name), + function_name ) + label <- as_default_label(label) } if (length(srcref) >= 2) attr(label, "srcref") <- srcref[[2]] attr(label, "srcfile") <- srcFileOfRef(srcref[[1]]) @@ -229,10 +231,12 @@ funcToLabelBody <- function(func) { funcToLabel <- function(func, functionLabel, label = NULL) { if (!is.null(label)) return(label) - sprintf( - '%s(%s)', - functionLabel, - funcToLabelBody(func) + as_default_label( + sprintf( + '%s(%s)', + functionLabel, + funcToLabelBody(func) + ) ) } quoToLabelBody <- function(q) { @@ -241,9 +245,19 @@ quoToLabelBody <- function(q) { quoToLabel <- function(q, functionLabel, label = NULL) { if (!is.null(label)) return(label) - sprintf( - '%s(%s)', - functionLabel, - quoToLabelBody(q) + as_default_label( + sprintf( + '%s(%s)', + functionLabel, + quoToLabelBody(q) + ) ) } + +as_default_label <- function(x) { + class(x) <- c("default_label", class(x)) + x +} +is_default_label <- function(x) { + inherits(x, "default_label") +} diff --git a/R/utils.R b/R/utils.R index f4abaf273..dda509edf 100644 --- a/R/utils.R +++ b/R/utils.R @@ -797,8 +797,8 @@ cachedFuncWithFile <- function(dir, file, func, case.sensitive = FALSE) { last_autoreload <- 0 function(...) { - fname <- if (case.sensitive) { - file.path(dir, file) + fname <- if (case.sensitive) { + file.path(dir, file) } else { file.path.ci(dir, file) } diff --git a/inst/www/shared/busy-indicators/busy-indicators.css b/inst/www/shared/busy-indicators/busy-indicators.css index 77c41b9c2..181cf689c 100644 --- a/inst/www/shared/busy-indicators/busy-indicators.css +++ b/inst/www/shared/busy-indicators/busy-indicators.css @@ -1,2 +1,2 @@ -/*! shiny 1.11.1.9000 | (c) 2012-2025 Posit Software, PBC. | License: GPL-3 | file LICENSE */ +/*! shiny 1.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} diff --git a/inst/www/shared/shiny-autoreload.js b/inst/www/shared/shiny-autoreload.js index a1c0b2639..85e1c0a33 100644 --- a/inst/www/shared/shiny-autoreload.js +++ b/inst/www/shared/shiny-autoreload.js @@ -1,3 +1,3 @@ -/*! shiny 1.11.1.9000 | (c) 2012-2025 Posit Software, PBC. | License: GPL-3 | file LICENSE */ +/*! shiny 1.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 diff --git a/inst/www/shared/shiny-showcase.css b/inst/www/shared/shiny-showcase.css index 0f80d0544..26cc54389 100644 --- a/inst/www/shared/shiny-showcase.css +++ b/inst/www/shared/shiny-showcase.css @@ -1,2 +1,2 @@ -/*! shiny 1.11.1.9000 | (c) 2012-2025 Posit Software, PBC. | License: GPL-3 | file LICENSE */ +/*! shiny 1.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} diff --git a/inst/www/shared/shiny-showcase.js b/inst/www/shared/shiny-showcase.js index 83a70f8f0..bd23a7973 100644 --- a/inst/www/shared/shiny-showcase.js +++ b/inst/www/shared/shiny-showcase.js @@ -1,3 +1,3 @@ -/*! shiny 1.11.1.9000 | (c) 2012-2025 Posit Software, PBC. | License: GPL-3 | file LICENSE */ +/*! 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 show below':' 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 diff --git a/inst/www/shared/shiny-testmode.js b/inst/www/shared/shiny-testmode.js index 5ab48f1cc..4d417c60d 100644 --- a/inst/www/shared/shiny-testmode.js +++ b/inst/www/shared/shiny-testmode.js @@ -1,3 +1,3 @@ -/*! shiny 1.11.1.9000 | (c) 2012-2025 Posit Software, PBC. | License: GPL-3 | file LICENSE */ +/*! shiny 1.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 diff --git a/inst/www/shared/shiny.js b/inst/www/shared/shiny.js index a3472738a..c85207b98 100644 --- a/inst/www/shared/shiny.js +++ b/inst/www/shared/shiny.js @@ -1,4 +1,4 @@ -/*! shiny 1.11.1.9000 | (c) 2012-2025 Posit Software, PBC. | License: GPL-3 | file LICENSE */ +/*! shiny 1.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); diff --git a/inst/www/shared/shiny.min.js b/inst/www/shared/shiny.min.js index 3261f51df..1b7e912db 100644 --- a/inst/www/shared/shiny.min.js +++ b/inst/www/shared/shiny.min.js @@ -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 Rr=Object.create;var Ni=Object.defineProperty;var Or=Object.getOwnPropertyDescriptor;var Vr=Object.getOwnPropertyNames;var zr=Object.getPrototypeOf,Nr=Object.prototype.hasOwnProperty;var Ui=n=>{throw TypeError(n)};var Ur=(n,e)=>()=>(e||n((e={exports:{}}).exports,e),e.exports);var Qr=(n,e,t,i)=>{if(e&&typeof e=="object"||typeof e=="function")for(let s of Vr(e))!Nr.call(n,s)&&s!==t&&Ni(n,s,{get:()=>e[s],enumerable:!(i=Or(e,s))||i.enumerable});return n};var M=(n,e,t)=>(t=n!=null?Rr(zr(n)):{},Qr(e||!n||!n.__esModule?Ni(t,"default",{value:n,enumerable:!0}):t,n));var Jn=(n,e,t)=>e.has(n)||Ui("Cannot "+t);var Qt=(n,e,t)=>(Jn(n,e,"read from private field"),t?t.call(n):e.get(n)),Jt=(n,e,t)=>e.has(n)?Ui("Cannot add the same private member more than once"):e instanceof WeakSet?e.add(n):e.set(n,t),Qi=(n,e,t,i)=>(Jn(n,e,"write to private field"),i?i.call(n,t):e.set(n,t),t),F=(n,e,t)=>(Jn(n,e,"access private method"),t);var S=Ur((Qo,Ji)=>{Ji.exports=window.jQuery});var Ft=M(S());var Fi=!1,ji=!1,qi=-1;function Fn(n){Fi=n}function Xi(n){ji=n}function Wi(n){qi=n}function Gi(){return Fi}function Re(){return ji}function Ki(){return qi}var W;function Yi(n){W=n}function Jr(){let n=W.indexOf("MSIE ");if(Re()&&n>0)return parseInt(W.substring(n+5,W.indexOf(".",n)),10);if(W.indexOf("Trident/")>0){let t=W.indexOf("rv:");return parseInt(W.substring(t+3,W.indexOf(".",t)),10)}return-1}function Zi(){/\bQt\//.test(W)?((0,Ft.default)(document.documentElement).addClass("qt"),Fn(!0)):Fn(!1),/\bQt/.test(W)&&/\bMacintosh/.test(W)&&(0,Ft.default)(document.documentElement).addClass("qtmac"),/\bQt\/5/.test(W)&&/Linux/.test(W)&&(0,Ft.default)(document.documentElement).addClass("qt5"),Xi(/MSIE|Trident|Edge/.test(W)),Wi(Jr())}var es=M(S());function ts(){(0,es.default)(document).on("submit","form:not([action])",function(n){n.preventDefault()})}var ns=M(S());function is(){let n=window.history.pushState;window.history.pushState=function(...e){let t=n.apply(this,e);return(0,ns.default)(document).trigger("pushstate"),t}}var H=M(S());var ft=M(S());var te=M(S());function se(n,e){return Object.prototype.hasOwnProperty.call(n,e)}function x(n,e){return Object.prototype.hasOwnProperty.call(n,e)&&n[e]!==void 0}function j(n,e){return n===void 0?e:n}function nt(n){return n==null?[]:Array.isArray(n)?n:[n]}var jn;function ss(n){jn=n}function be(){if(typeof jn>"u")throw"Shiny has not finish initialization yet. Please wait for the 'shiny-initialized' event.";return jn}function me(n,e,t){be().setInputValue(n,e,t)}function Oe(){return be().shinyapp}function rs(n){be().user=n}function os(n){be().forgetLastInputValue(n)}async function Ve(n){await be().bindAll(n)}function G(n,e=!1){be().unbindAll(n,e)}function dt(n){be().initializeInputs(n)}async function as(n,e){await Oe().bindOutput(n,e)}function ls(n,e){return Oe().unbindOutput(n,e)}function us(){return be().oncustommessage}var ds;function cs(){return ds}function ps(n){ds=n}function ms(){return be().createSocket}var ee=class{constructor(e,t,i){this.target=e,this.func=t,this.delayMs=i,this.timerId=null,this.args=null}normalCall(...e){this.$clearTimer(),this.args=e,this.timerId=setTimeout(()=>{this.timerId!==null&&(this.$clearTimer(),this.$invoke())},this.delayMs)}immediateCall(...e){this.$clearTimer(),this.args=e,this.$invoke()}isPending(){return this.timerId!==null}$clearTimer(){this.timerId!==null&&(clearTimeout(this.timerId),this.timerId=null)}$invoke(){this.args&&this.args.length>0?this.func.apply(this.target,this.args):this.func.apply(this.target),this.args=null}};function $e(n,e){let t=null;return function i(...s){t!==null&&(clearTimeout(t),t=null),t=setTimeout(()=>{t!==null&&(t=null,e.apply(i,s))},n)}}var ct=class{constructor(e,t){this.target=e,this.func=t}normalCall(...e){this.func.apply(this.target,e)}immediateCall(...e){this.func.apply(this.target,e)}};var Ce=class{constructor(e,t,i){this.target=e,this.func=t,this.delayMs=i,this.timerId=null,this.args=null}normalCall(...e){this.args=e,this.timerId===null&&this.$invoke()}immediateCall(...e){this.$clearTimer(),this.args=e,this.$invoke()}isPending(){return this.args!==null}$clearTimer(){this.timerId!==null&&(clearTimeout(this.timerId),this.timerId=null)}$invoke(){this.args!==null&&(this.func.apply(this.target,this.args),this.args=null,this.timerId=setTimeout(()=>{this.timerId!==null&&(this.$clearTimer(),this.isPending()&&this.$invoke())},this.delayMs))}};var qn=class{setImageSend(e,t){let i=new ee(null,t,0);return this.regular=function(){i.normalCall()},e.lastChanceCallback.push(function(){i.isPending()&&i.immediateCall()}),this.transitioned=$e(200,this.regular),i}},ue=new qn;var ve=M(S()),Fr=/([\s\S]*?)/,jr=/]*)?>([\s\S]*?)<\/head>/,jt={};function Xn(n,e,t){let i=Wr(n);switch(Xr(i.head),qr(i.singletons),t.toLowerCase()){case"replace":(0,ve.default)(e).html(i.html);break;case"beforebegin":(0,ve.default)(e).before(i.html);break;case"afterbegin":(0,ve.default)(e).prepend(i.html);break;case"beforeend":(0,ve.default)(e).append(i.html);break;case"afterend":(0,ve.default)(e).after(i.html);break;default:throw new Error("Unknown where position: "+t)}return i}function qr(n){ve.default.extend(jt,n)}function fs(n){if(typeof n=="string")jt[n]=!0;else if(n instanceof Array)for(let e=0;e0){let e=(0,ve.default)("
"+n+"
").get(0),t=(0,ve.default)("head");for(;e.hasChildNodes();)t.append(e.firstChild)}}function Wr(n){let e={},t,i=function(a,r,l,u){return jt[l]||e[l]?"":(e[l]=!0,u)};for(;t=n.replace(Fr,i),n.length!==t.length;)n=t;let s=[],o=function(a,r){return s.push(r),""};for(;t=n.replace(jr,o),n.length!==t.length;)n=t;return{html:n,head:s.join(` `),singletons:e}}async function re(n,e,t="replace"){t==="replace"&&G(n);let i="",s=[];e===null?i="":typeof e=="string"?i=e:typeof e=="object"&&(i=e.html,s=e.deps||[]),await mt(i,n,s,t);let o=n;if(t==="replace")dt(n),await Ve(n);else{let a=(0,te.default)(n).parent();if(a.length>0&&(o=a,t==="beforeBegin"||t==="afterEnd")){let r=a.parent();r.length>0&&(o=r)}dt(o),await Ve(o)}}function we(n,e,t="replace"){t==="replace"&&G(n);let i="",s=[];e===null?i="":typeof e=="string"?i=e:typeof e=="object"&&(i=e.html,s=e.deps||[]),Wn(i,n,s,t);let o=n;if(t==="replace")return dt(n),Ve(n);{let a=(0,te.default)(n).parent();if(a.length>0&&(o=a,t==="beforeBegin"||t==="afterEnd")){let r=a.parent();r.length>0&&(o=r)}return dt(o),Ve(o)}}async function mt(n,e,t,i="replace"){return await ze(t),Xn(n,e,i)}function Wn(n,e,t,i="replace"){return Gn(t),Xn(n,e,i)}async function ze(n){if(n)for(let e of n)await Yr(e)}function Gn(n){if(n)for(let e of n)Zr(e)}var pt={};function qt(n,e){pt[n]=e}function hs(n){if(!n.restyle)return!1;let e=Object.keys(pt),t=e.indexOf(n.name);return t===-1?!1:pt[e[t]]===n.version}function gs(n){let e=(0,te.default)("head").first(),t=function(o,a){let r=new XMLHttpRequest;r.open("GET",o),r.onload=function(){let l="shiny_restyle_"+o.split("?restyle")[0].replace(/\W/g,"_"),u=e.find("style#"+l),d=(0,te.default)("