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

feat(otel): Enhanced OpenTelemetry support (#4300)

Browse Source
This commit is contained in:
Barret Schloerke
2025-10-28 14:01:50 -04:00
committed by GitHub
parent 592e825a0f
commit b56c275364
34 changed files with 3144 additions and 444 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
.github/workflows/R-CMD-check.yaml vendored
View File

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

8
DESCRIPTION
View File

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

1
NAMESPACE
View File

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

5
NEWS.md
View File

@@ -38,7 +38,10 @@
* Fixed an issue where `updateSelectizeInput(options = list(plugins="remove_button"))` could lead to multiple remove buttons. (#4275)
* The default label for `reactiveValues()`, `reactivePoll()`, `reactiveFileReader()`, `debounce()`, and `throttle()` will now attempt to retrieve the assigned name if the srcref is available. If a value can not easily be produced, a default label will be used instead. (#4269)
* The default label for items described below will now attempt to retrieve the assigned name if the srcref is available. If a value can not easily be produced, a default label will be used instead. This should improve the OpenTelemetry span labels and the reactlog experience. (#4269, #4300)
* `reactiveValues()`, `reactivePoll()`, `reactiveFileReader()`, `debounce()`, `throttle()`, `observe()`
* Combinations of `bindEvent()` and `reactive()` / `observe()`
* Combination of `bindCache()` and `reactive()`
## Changes

38
R/bind-cache.R
View File

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

38
R/bind-event.R
View File

@@ -196,10 +196,20 @@ bindEvent.reactiveExpr <- function(x, ..., ignoreNULL = TRUE, ignoreInit = FALSE
valueFunc <- reactive_get_value_func(x)
valueFunc <- wrapFunctionLabel(valueFunc, "eventReactiveValueFunc", ..stacktraceon = TRUE)
label <- label %||%
sprintf('bindEvent(%s, %s)', attr(x, "observable", exact = TRUE)$.label, quos_to_label(qs))
call_srcref <- get_call_srcref(-1)
if (is.null(label)) {
label <- rassignSrcrefToLabel(
call_srcref,
defaultLabel = as_default_label(sprintf(
'bindEvent(%s, %s)',
attr(x, "observable", exact = TRUE)$.label,
quos_to_label(qs)
))
)
}
x_classes <- class(x)
x_otel_attrs <- attr(x, "observable", exact = TRUE)$.otelAttrs
# Don't hold on to the reference for x, so that it can be GC'd
rm(x)
@@ -228,6 +238,13 @@ bindEvent.reactiveExpr <- function(x, ..., ignoreNULL = TRUE, ignoreInit = FALSE
class(res) <- c("reactive.event", x_classes)
local({
impl <- attr(res, "observable", exact = TRUE)
impl$.otelAttrs <- x_otel_attrs
impl$.otelAttrs <- append_otel_srcref_attrs(impl$.otelAttrs, call_srcref)
})
if (has_otel_bind("reactivity")) {
res <- bind_otel_reactive_expr(res)
}
@@ -260,6 +277,7 @@ bindEvent.shiny.render.function <- function(x, ..., ignoreNULL = TRUE, ignoreIni
)
}
# Passes over the otelAttrs from valueFunc to renderFunc
renderFunc <- addAttributes(renderFunc, renderFunctionAttributes(valueFunc))
class(renderFunc) <- c("shiny.render.function.event", class(valueFunc))
renderFunc
@@ -280,7 +298,17 @@ bindEvent.Observer <- function(x, ..., ignoreNULL = TRUE, ignoreInit = FALSE,
# Note that because the observer will already have been logged by this point,
# this updated label won't show up in the reactlog.
x$.label <- label %||% sprintf('bindEvent(%s, %s)', x$.label, quos_to_label(qs))
if (is.null(label)) {
call_srcref <- get_call_srcref(-1)
x$.label <- rassignSrcrefToLabel(
call_srcref,
defaultLabel = as_default_label(
sprintf('bindEvent(%s, %s)', x$.label, quos_to_label(qs))
)
)
} else {
x$.label <- label
}
initialized <- FALSE
@@ -313,9 +341,13 @@ bindEvent.Observer <- function(x, ..., ignoreNULL = TRUE, ignoreInit = FALSE,
)
class(x) <- c("Observer.event", class(x))
call_srcref <- get_call_srcref(-1)
x$.otelAttrs <- append_otel_srcref_attrs(x$.otelAttrs, call_srcref)
if (has_otel_bind("reactivity")) {
x <- bind_otel_observe(x)
}
invisible(x)
}

22
R/extended-task.R
View File

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

54
R/mock-session.R
View File

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

39
R/otel-attr-srcref.R
View File

@@ -22,3 +22,42 @@ otel_srcref_attributes <- function(srcref) {
"code.column" = srcref[2]
))
}
#' Get the srcref for the call at the specified stack level
#'
#' If you need to go farther back in the `sys.call()` stack, supply a larger
#' negative number to `which_offset`. The default of 0 gets the immediate
#' caller. `-1` would get the caller's caller, and so on.
#' @param which_offset The stack level to get the call from. Defaults to -1 (the
#' immediate caller).
#' @return An srcref object, or NULL if none is found.
#' @noRd
get_call_srcref <- function(which_offset = 0) {
# Go back one call to account for this function itself
call <- sys.call(which_offset - 1)
srcref <- attr(call, "srcref", exact = TRUE)
srcref
}
append_otel_attrs <- function(attrs, new_attrs) {
if (is.null(new_attrs)) {
return(attrs)
}
attrs[names(new_attrs)] <- new_attrs
attrs
}
append_otel_srcref_attrs <- function(attrs, call_srcref) {
if (is.null(call_srcref)) {
return(attrs)
}
srcref_attrs <- otel_srcref_attributes(call_srcref)
attrs <- append_otel_attrs(attrs, srcref_attrs)
attrs
}

82
R/otel-bind.R
View File

@@ -34,6 +34,70 @@
# * Connect `user.id` to be their user name: https://opentelemetry.io/docs/specs/semconv/registry/attributes/user/
# * Tests with otel recording
# ------------------------------------------
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)
}
# 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)
}
# ------------------------------------------
# # Approach
@@ -185,21 +249,31 @@ bind_otel_observe <- function(x) {
bind_otel_shiny_render_function <- function(x) {
valueFunc <- x
valueFunc <- force(x)
span_label <- NULL
ospan_attrs <- attr(x, "otelAttrs")
ospan_attrs <- NULL
renderFunc <- function(...) {
# Dynamically determine the span label given the current reactive domain
if (is.null(span_label)) {
domain <- getDefaultReactiveDomain()
span_label <<-
ospan_label_render_function(x, domain = getDefaultReactiveDomain())
ospan_label_render_function(x, domain = domain)
ospan_attrs <<- c(
attr(x, "otelAttrs"),
otel_session_id_attrs(domain)
)
}
with_shiny_ospan_async(
span_label,
{
valueFunc(...)
promises::hybrid_then(
valueFunc(...),
on_failure = set_ospan_error_status_and_throw,
# Must save the error object
tee = FALSE
)
},
attributes = ospan_attrs
)

56
R/otel-error.R Normal file
View File

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

24
R/otel-label.R
View File

@@ -43,10 +43,8 @@ ospan_label_render_function <- function(x, ..., domain) {
event_class = "shiny.render.function.event"
)
ospan_label <- otel_label_upgrade(
getCurrentOutputInfo(session = domain)$name,
domain = domain
)
label <- getCurrentOutputInfo(session = domain)$name %||% "<unknown>"
ospan_label <- otel_label_upgrade(label, domain = domain)
sprintf("%s %s", fn_name, ospan_label)
}
@@ -107,14 +105,28 @@ otel_label_extended_task_set_reactive_val <- function(label, name, ..., domain)
otel_label_debounce <- function(label, ..., domain) {
sprintf(
"reactive debounce %s",
"debounce %s",
otel_label_upgrade(label, domain = domain)
)
}
otel_label_throttle <- function(label, ..., domain) {
sprintf(
"reactive throttle %s",
"throttle %s",
otel_label_upgrade(label, domain = domain)
)
}
# ---- Reactive Poll / File Reader -----------------------------------------------
otel_label_reactive_poll <- function(label, ..., domain) {
sprintf(
"reactivePoll %s",
otel_label_upgrade(label, domain = domain)
)
}
otel_label_reactive_file_reader <- function(label, ..., domain) {
sprintf(
"reactiveFileReader %s",
otel_label_upgrade(label, domain = domain)
)
}

31
R/otel-reactive-update.R
View File

@@ -96,3 +96,34 @@ with_reactive_update_active_ospan <- function(expr, ..., domain) {
# we only need to wrap the expr in the span context
otel::with_active_span(reactive_update_ospan, {force(expr)})
}
#' Run expr within `reactive_update` ospan if not already active
#'
#' If the reactive update ospan is not already active, run the expression
#' within the reactive update ospan context. This ensures that nested calls
#' to reactive expressions do not attempt to re-enter the same span.
#' @param expr The expression to executed within the span
#' @param ... Ignored
#' @param domain The reactive domain to associate with the span
#' @noRd
maybe_with_reactive_update_active_ospan <- function(expr, ..., domain) {
if (!reactive_update_ospan_is_active(domain)) {
set_reactive_ospan_is_active(domain)
promises::hybrid_then(
{
with_reactive_update_active_ospan(domain = domain, expr)
},
on_success = function(value) {
clear_reactive_ospan_is_active(domain)
},
on_failure = function(e) {
clear_reactive_ospan_is_active(domain)
},
tee = TRUE
)
} else {
expr
}
}

30
R/otel-session.R
View File

@@ -18,11 +18,6 @@ use_session_start_ospan_async <- function(expr, ..., domain) {
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",
@@ -51,6 +46,7 @@ with_session_end_ospan_async <- function(expr, ..., domain) {
# -- Helpers -------------------------------
# Occurs when the websocket connection is established
otel_session_attrs <- function(domain) {
attrs <- list(
PATH_INFO =
@@ -60,16 +56,28 @@ otel_session_attrs <- function(domain) {
),
HTTP_HOST = domain[["request"]][["HTTP_HOST"]] %||% "",
HTTP_ORIGIN = domain[["request"]][["HTTP_ORIGIN"]] %||% "",
QUERY_STRING = domain[["request"]][["QUERY_STRING"]] %||% "",
SERVER_PORT = domain[["request"]][["SERVER_PORT"]] %||% ""
## Currently, Shiny does not expose QUERY_STRING when connecting the websocket
# so we do not provide it here.
# QUERY_STRING = domain[["request"]][["QUERY_STRING"]] %||% "",
SERVER_PORT = domain[["request"]][["SERVER_PORT"]] %||% NA_integer_
)
try({
attrs[["SERVER_PORT"]] <- as.integer(attrs[["SERVER_PORT"]])
})
# Safely convert SERVER_PORT to integer
# If conversion fails, leave as-is (string or empty)
# This avoids warnings/errors if SERVER_PORT is not a valid integer
server_port <- suppressWarnings(as.integer(attrs$SERVER_PORT))
if (!is.na(server_port)) {
attrs$SERVER_PORT <- server_port
}
attrs
}
otel_session_id_attrs <- function(domain) {
token <- domain$token
if (is.null(token)) {
return(list())
}
list(
# Convention for client-side with session.start and session.end events
# https://opentelemetry.io/docs/specs/semconv/general/session/
@@ -77,6 +85,6 @@ otel_session_id_attrs <- function(domain) {
# 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
session.id = token
)
}

33
R/otel.R → R/otel-shiny.R
View File

@@ -44,19 +44,34 @@ otel_log <- function(
otel_is_tracing_enabled <- function(tracer = get_tracer()) {
otel::is_tracing_enabled(tracer)
}
otel_get_logger <- function() {
otel::get_logger()
}
otel_get_tracer <- function() {
otel::get_tracer()
}
get_ospan_logger <- local({
logger <- NULL
# For internal testing purposes only
reset_logger <- function() {
logger <<- NULL
}
function() {
if (!is.null(logger)) {
return(logger)
}
this_logger <- otel_get_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())
return(this_logger)
}
logger <<- otel::get_logger()
logger <<- this_logger
logger
}
})
@@ -67,16 +82,26 @@ get_ospan_logger <- local({
# Using local scope avoids an environment object lookup on each call.
get_tracer <- local({
tracer <- NULL
# For internal testing purposes only
reset_tracer <- function() {
tracer <<- NULL
}
function() {
if (!is.null(tracer)) {
return(tracer)
}
this_tracer <- otel_get_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())
return(this_tracer)
}
tracer <<- otel::get_tracer()
tracer <<- this_tracer
tracer
}
})

77
R/otel-with.R
View File

@@ -1,77 +0,0 @@
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)
}

17
R/react.R
View File

@@ -19,7 +19,8 @@ processId <- local({
ctx_otel_info_obj <- function(
isRecordingOtel = FALSE,
otelLabel = "<unknown>",
otelAttrs = NULL) {
otelAttrs = list()
) {
structure(
list(
isRecordingOtel = isRecordingOtel,
@@ -42,11 +43,21 @@ with_context_ospan_async <- function(otel_info, expr, domain) {
# 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, {
maybe_with_reactive_update_active_ospan(domain = domain, {
if (isRecordingOtel) {
with_shiny_ospan_async(
otelLabel,
expr,
{
# Works with both sync and async expressions
# Needed for both observer and reactive contexts
promises::hybrid_then(
expr,
on_failure = set_ospan_error_status_and_throw,
# Must upgrade the error object
tee = FALSE
)
},
# expr,
attributes = otelAttrs
)
} else {

2
R/reactive-domains.R
View File

@@ -45,6 +45,8 @@ createMockDomain <- function() {
callbacks <- Callbacks$new()
ended <- FALSE
domain <- new.env(parent = emptyenv())
domain$ns <- function(id) id
domain$token <- "mock-domain"
domain$onEnded <- function(callback) {
return(callbacks$register(callback))
}

180
R/reactives.R
View File

@@ -221,12 +221,11 @@ ReactiveVal <- R6Class(
#'
#' @export
reactiveVal <- function(value = NULL, label = NULL) {
call_srcref <- attr(sys.call(), "srcref", exact = TRUE)
call_srcref <- get_call_srcref()
if (missing(label)) {
label <- rassignSrcrefToLabel(
call_srcref,
defaultLabel = paste0("reactiveVal", createUniqueId(4)),
fnName = "reactiveVal"
defaultLabel = paste0("reactiveVal", createUniqueId(4))
)
}
@@ -295,7 +294,7 @@ format.reactiveVal <- function(x, ...) {
rassignSrcrefToLabel <- function(
srcref,
defaultLabel,
fnName
fnName = "([a-zA-Z0-9_.]+)"
) {
if (is.null(srcref))
@@ -321,7 +320,8 @@ rassignSrcrefToLabel <- function(
firstLine <- substring(lines[srcref[1]], srcref[2] - 1)
m <- regexec(
paste0("\\s*([^[:space:]]+)\\s*(<-|=)\\s*", fnName, "\\b"),
# Require the first assignment within the line
paste0("^\\s*([^[:space:]]+)\\s*(<<-|<-|=)\\s*", fnName, "\\b"),
firstLine
)
if (m[[1]][1] == -1) {
@@ -634,13 +634,12 @@ reactiveValues <- function(...) {
# Use .subset2() instead of [[, to avoid method dispatch
impl <- .subset2(values, 'impl')
call_srcref <- attr(sys.call(), "srcref", exact = TRUE)
call_srcref <- get_call_srcref()
if (!is.null(call_srcref)) {
impl$.label <- rassignSrcrefToLabel(
call_srcref,
# Pass through the random default label created in ReactiveValues$new()
defaultLabel = impl$.label,
fnName = "reactiveValues"
defaultLabel = impl$.label
)
impl$.otelAttrs <- otel_srcref_attributes(call_srcref)
@@ -1018,6 +1017,15 @@ Observable <- R6Class(
},
error = function(cond) {
if (.isRecordingOtel) {
# `cond` is too early in the stack to be updated by `ctx`'s
# `with_context_ospan_async()` where it calls
# `set_ospan_error_status_and_throw()` on eval error.
# So we mark it as seen here.
# When the error is re-thrown later, it won't be a _new_ error
cond <- set_ospan_error_as_seen(cond)
}
# If an error occurs, we want to propagate the error, but we also
# want to save a copy of it, so future callers of this reactive will
# get the same error (i.e. the error is cached).
@@ -1116,7 +1124,7 @@ reactive <- function(
o <- Observable$new(func, label, domain, ..stacktraceon = ..stacktraceon)
call_srcref <- attr(sys.call(), "srcref", exact = TRUE)
call_srcref <- get_call_srcref()
if (!is.null(call_srcref)) {
o$.otelAttrs <- otel_srcref_attributes(call_srcref)
}
@@ -1163,7 +1171,8 @@ rexprSrcrefToLabel <- function(srcref, defaultLabel, fnName) {
firstLine <- substring(lines[srcref[1]], 1, srcref[2] - 1)
m <- regexec(paste0("(.*)(<-|=)\\s*", fnName, "\\s*\\($"), firstLine)
# Require the assignment to be parsed from the start
m <- regexec(paste0("^(.*)(<<-|<-|=)\\s*", fnName, "\\s*\\($"), firstLine)
if (m[[1]][1] == -1) {
return(defaultLabel)
}
@@ -1555,7 +1564,14 @@ observe <- function(
check_dots_empty()
func <- installExprFunction(x, "func", env, quoted)
label <- funcToLabel(func, "observe", label)
call_srcref <- get_call_srcref()
if (is.null(label)) {
label <- rassignSrcrefToLabel(
call_srcref,
defaultLabel = funcToLabel(func, "observe", label)
)
}
o <- Observer$new(
func,
@@ -1566,7 +1582,6 @@ 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)
}
@@ -1962,30 +1977,32 @@ coerceToFunc <- function(x) {
#' }
#' @export
reactivePoll <- function(intervalMillis, session, checkFunc, valueFunc) {
reactive_poll_impl(
fnName = "reactivePoll",
intervalMillis = intervalMillis,
session = session,
checkFunc = checkFunc,
valueFunc = valueFunc
)
}
reactive_poll_impl <- function(
fnName,
intervalMillis,
session,
checkFunc,
valueFunc
) {
intervalMillis <- coerceToFunc(intervalMillis)
label <- "<anonymous>"
try(silent = TRUE, {
reactiveFileReader_call_srcref <- attr(sys.call(-1), "srcref", exact = TRUE)
fnName <- "reactiveFileReader"
label <- rassignSrcrefToLabel(
reactiveFileReader_call_srcref,
defaultLabel = "<anonymous>",
fnName = fnName
)
})
fnName <- match.arg(fnName, c("reactivePoll", "reactiveFileReader"), several.ok = FALSE)
if (label == "<anonymous>") {
# If reactiveFileReader couldn't figure out a label,
# try reactivePoll instead.
call_srcref <- attr(sys.call(), "srcref", exact = TRUE)
fnName <- "reactivePoll"
label <- rassignSrcrefToLabel(
call_srcref,
defaultLabel = "<anonymous>",
fnName = fnName
)
}
call_srcref <- get_call_srcref(-1)
label <- rassignSrcrefToLabel(
call_srcref,
defaultLabel = "<anonymous>",
fnName = fnName
)
re_finalized <- FALSE
env <- environment()
@@ -2011,7 +2028,6 @@ reactivePoll <- function(intervalMillis, session, checkFunc, valueFunc) {
}, label = sprintf("%s %s cleanup", fnName, label))
})
re <- reactive(label = sprintf("%s %s", fnName, label), {
# Take a dependency on the cookie, so that when it changes, this
# reactive expression is invalidated.
@@ -2028,6 +2044,16 @@ reactivePoll <- function(intervalMillis, session, checkFunc, valueFunc) {
# reference to `re` and thus prevent it from getting GC'd.
on.exit(rm(re))
local({
impl <- attr(re, "observable", exact = TRUE)
impl$.otelLabel <-
if (fnName == "reactivePoll")
otel_label_reactive_poll(label, domain = impl$.domain)
else if (fnName == "reactiveFileReader")
otel_label_reactive_file_reader(label, domain = impl$.domain)
impl$.otelAttrs <- append_otel_srcref_attrs(impl$.otelAttrs, call_srcref)
})
return(re)
}
@@ -2091,14 +2117,16 @@ reactiveFileReader <- function(intervalMillis, session, filePath, readFunc, ...)
filePath <- coerceToFunc(filePath)
extraArgs <- list2(...)
reactivePoll(
intervalMillis, session,
function() {
reactive_poll_impl(
fnName = "reactiveFileReader",
intervalMillis = intervalMillis,
session = session,
checkFunc = function() {
path <- filePath()
info <- file.info(path)
return(paste(path, info$mtime, info$size))
},
function() {
valueFunc = function() {
do.call(readFunc, c(filePath(), extraArgs))
}
)
@@ -2459,7 +2487,14 @@ observeEvent <- function(eventExpr, handlerExpr,
eventQ <- exprToQuo(eventExpr, event.env, event.quoted)
handlerQ <- exprToQuo(handlerExpr, handler.env, handler.quoted)
label <- quoToLabel(eventQ, "observeEvent", label)
call_srcref <- get_call_srcref()
if (is.null(label)) {
label <- rassignSrcrefToLabel(
call_srcref,
defaultLabel = quoToLabel(eventQ, "observeEvent", label)
)
}
with_no_otel_bind({
handler <- inject(observe(
@@ -2471,16 +2506,23 @@ observeEvent <- function(eventExpr, handlerExpr,
autoDestroy = TRUE,
..stacktraceon = TRUE
))
o <- inject(bindEvent(
ignoreNULL = ignoreNULL,
ignoreInit = ignoreInit,
once = once,
label = label,
!!eventQ,
x = handler
))
})
o <- inject(bindEvent(
ignoreNULL = ignoreNULL,
ignoreInit = ignoreInit,
once = once,
label = label,
!!eventQ,
x = handler
))
if (!is.null(call_srcref)) {
o$.otelAttrs <- otel_srcref_attributes(call_srcref)
}
if (has_otel_bind("reactivity")) {
o <- bind_otel_observe(o)
}
invisible(o)
}
@@ -2503,26 +2545,36 @@ eventReactive <- function(eventExpr, valueExpr,
# 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)
call_srcref <- get_call_srcref()
if (is.null(label)) {
label <- rassignSrcrefToLabel(
call_srcref,
defaultLabel = exprToLabel(userEventExpr, "eventReactive", label),
fnName = "eventReactive"
defaultLabel = exprToLabel(userEventExpr, "eventReactive", label)
)
}
with_no_otel_bind({
value_r <- inject(reactive(!!valueQ, domain = domain, label = label))
r <- inject(bindEvent(
ignoreNULL = ignoreNULL,
ignoreInit = ignoreInit,
label = label,
!!eventQ,
x = value_r
))
})
invisible(inject(bindEvent(
ignoreNULL = ignoreNULL,
ignoreInit = ignoreInit,
label = label,
!!eventQ,
x = value_r
)))
if (!is.null(call_srcref)) {
impl <- attr(r, "observable", exact = TRUE)
impl$.otelAttrs <- otel_srcref_attributes(call_srcref)
}
if (has_otel_bind("reactivity")) {
r <- bind_otel_reactive_expr(r)
}
return(r)
}
isNullEvent <- function(value) {
@@ -2643,11 +2695,10 @@ debounce <- function(r, millis, priority = 100, domain = getDefaultReactiveDomai
force(r)
force(millis)
call_srcref <- attr(sys.call(), "srcref", exact = TRUE)
call_srcref <- get_call_srcref()
label <- rassignSrcrefToLabel(
call_srcref,
defaultLabel = "<anonymous>",
fnName = "debounce"
defaultLabel = "<anonymous>"
)
if (!is.function(millis)) {
@@ -2716,13 +2767,14 @@ debounce <- function(r, millis, priority = 100, domain = getDefaultReactiveDomai
# value of r(), but only invalidates/updates when `trigger` is touched.
er <- eventReactive(
{trigger()}, {r()},
label = sprintf("debounce %s", label), ignoreNULL = FALSE, domain = domain
label = sprintf("debounce %s result", label), ignoreNULL = FALSE, domain = domain
)
# Update the otel label
local({
er_impl <- attr(er, "observable", exact = TRUE)
er_impl$.otelLabel <- otel_label_debounce(label, domain = domain)
er_impl$.otelAttrs <- append_otel_srcref_attrs(er_impl$.otelAttrs, call_srcref)
})
with_no_otel_bind({
@@ -2747,11 +2799,10 @@ throttle <- function(r, millis, priority = 100, domain = getDefaultReactiveDomai
force(r)
force(millis)
call_srcref <- attr(sys.call(), "srcref", exact = TRUE)
call_srcref <- get_call_srcref()
label <- rassignSrcrefToLabel(
call_srcref,
defaultLabel = "<anonymous>",
fnName = "throttle"
defaultLabel = "<anonymous>"
)
if (!is.function(millis)) {
@@ -2822,6 +2873,7 @@ throttle <- function(r, millis, priority = 100, domain = getDefaultReactiveDomai
local({
er_impl <- attr(er, "observable", exact = TRUE)
er_impl$.otelLabel <- otel_label_throttle(label, domain = domain)
er_impl$.otelAttrs <- append_otel_srcref_attrs(er_impl$.otelAttrs, call_srcref)
})
er

1
R/shiny-package.R
View File

@@ -8,6 +8,7 @@
#' @importFrom promises %...>%
#' @importFrom promises
#' promise promise_resolve promise_reject is.promising
#' then
#' as.promise
#' @importFrom rlang
#' quo enquo enquo0 as_function get_expr get_env new_function enquos

29
R/shiny.R
View File

@@ -1056,20 +1056,18 @@ 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
}
))
)
# For fatal errors, always log.
# For non-fatal errors, only log if we haven't seen this error before.
if (close || !has_seen_ospan_error(e)) {
otel_log(
if (close) "Fatal error" else "Unhandled error",
severity = if (close) "fatal" else "error",
attributes = otel::as_attributes(list(
session.id = self$token,
error = get_otel_error_obj(e)
))
)
}
private$unhandledErrorCallbacks$invoke(e, onError = printError)
.globals$onUnhandledErrorCallbacks$invoke(e, onError = printError)
@@ -1173,8 +1171,7 @@ ShinySession <- R6Class(
hybrid_chain(
{
private$withCurrentOutput(name, {
# 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({
maybe_with_reactive_update_active_ospan({
shinyCallingHandlers(func())
}, domain = self)
})

6
tests/testthat/_snaps/reactivity.md Normal file
View File

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

223
tests/testthat/helper-barret.R → tests/testthat/helper-otel-interactive-app.R
View File

@@ -1,180 +1,6 @@
# Personal debugging function -------------------------------
# system("air format ./R/bind-otel.R")
# Rscript -e "devtools::load_all(); devtools::load_all(\"~/rstudio/ellmer/ellmer.nosync\"); dev_barret()"
# devtools::load_all(); dev_otel_kitchen()
# # TODO: Remove this function when done debugging
# dev_barret <- function() {
# ## Ospan pkgs
# # pak::pak("cran::mirai", upgrade = TRUE)
# # pak::pak("r-lib/httr2#729")
# # pak::pak("tidyverse/ellmer#526")
# ## Prettier tool calls
# # pak::pak("rstudio/shinychat/pkg-r")
# withr::with_options(
# list(
# OTEL_TRACES_EXPORTER = Sys.getenv("LOGFIRE_OTEL_TRACES_EXPORTER"),
# OTEL_EXPORTER_OTLP_ENDPOINT = Sys.getenv(
# "LOGFIRE_OTEL_EXPORTER_OTLP_ENDPOINT"
# ),
# OTEL_EXPORTER_OTLP_HEADERS = Sys.getenv(
# "LOGFIRE_OTEL_EXPORTER_OTLP_HEADERS"
# ),
# OTEL_LOGS_EXPORTER = Sys.getenv("LOGFIRE_OTEL_LOGS_EXPORTER"),
# OTEL_LOG_LEVEL = Sys.getenv("LOGFIRE_OTEL_LOG_LEVEL"),
# OTEL_METRICS_EXPORTER = Sys.getenv("LOGFIRE_OTEL_METRICS_EXPORTER")
# ),
# {
# mirai::daemons(1)
# bind_val <- "none"
# # bind_val <- "all"
# # Enhanced from: https://posit-dev.github.io/shinychat/r/articles/tool-ui.html#alternative-html-display
# get_weather_forecast <- ellmer::tool(
# function(lat, lon, location_name) {
# mirai::mirai(
# {
# otel::log_info(
# "Getting weather forecast",
# logger = otel::get_logger("weather-app")
# )
# forecast_data <- weathR::point_tomorrow(lat, lon, short = FALSE)
# forecast_table <- gt::as_raw_html(gt::gt(forecast_data))
# list(data = forecast_data, table = forecast_table)
# },
# lat = lat,
# lon = lon
# ) |>
# promises::then(function(forecast_info) {
# ellmer::ContentToolResult(
# forecast_info$data,
# extra = list(
# display = list(
# html = forecast_info$table,
# title = paste("Weather Forecast for", location_name)
# )
# )
# )
# })
# },
# name = "get_weather_forecast",
# description = "Get the weather forecast for a location.",
# arguments = list(
# lat = ellmer::type_number("Latitude"),
# lon = ellmer::type_number("Longitude"),
# location_name = ellmer::type_string(
# "Name of the location for display to the user"
# )
# ),
# annotations = ellmer::tool_annotations(
# title = "Weather Forecast",
# icon = bsicons::bs_icon("cloud-sun")
# )
# )
# client <- ellmer::chat_anthropic("Be terse.")
# client$register_tool(get_weather_forecast)
# ui <- bslib::page_fillable(
# shinychat::chat_mod_ui("chat", height = "100%"),
# actionButton(
# "close_btn",
# label = "",
# class = "btn-close",
# style = "position: fixed; top: 6px; right: 6px;"
# )
# )
# server <- function(input, output, session) {
# with_no_otel_bind({
# chat_server <- shinychat::chat_mod_server("chat", client, session)
# })
# with_no_otel_bind({
# observeEvent(input$close_btn, {
# stopApp()
# })
# })
# # with_no_otel_bind({
# # output$boom <- renderUI({
# # stop("Boom!")
# # })
# # })
# with_no_otel_bind({
# counter <- reactiveVal(1)
# observeEvent(chat_server$last_turn(), {
# counter(counter() + 1)
# })
# observeEvent(counter(), label = "barret_is_lazy", {
# if (counter() == 1) {
# later::later(
# function() {
# chat_server$update_user_input(
# value = "What is the weather in Atlanta, GA?",
# submit = TRUE
# )
# },
# delay = 1
# )
# } else {
# later::later(
# function() {
# later::later(
# function() {
# message("Stopping app")
# stopApp()
# },
# delay = 0.5
# )
# message("Stopping session")
# session$close()
# },
# delay = 3
# )
# }
# })
# })
# }
# app <- shinyApp(ui, server)
# runApp(app, port = 8080, launch.browser = TRUE)
# }
# )
# }
# -------------------------------------------------------------------
#
#
#
#
#
#
#
#
#
#
#
#
#
#
#
#
#
#
#
#
#
#
#
#
#
#
#
# - Kitchen sink app ---------------------------------
dev_barret_kitchen <- function() {
dev_otel_kitchen <- function() {
library(mirai)
mirai::daemons(2)
@@ -182,21 +8,13 @@ dev_barret_kitchen <- function() {
# * https://github.com/r-lib/otel/commit/a2ef493ae4b97701e4e178ac527f313580539080
# * https://github.com/r-lib/otel/commit/09c0eb6c80d5b907976de8fbaf89798cb11f8e6e#diff-169b8f234d0b208affb106fce375f86fefe2f16dba4ad66495a1dc06c8a4cd7b
# TODO: Maybe the name is the folder name, similar to shinyapps.io naming
# Maybe set from a function call somewhere?
# otel_tracer <- otel::get_tracer("my-app")
otel_logger <- otel::get_logger("my-app-logger")
# options("shiny.otel.tracer" = otel_tracer)
# withr::with_environment(globalenv(), {
otel_tracer_name <- "my-app"
# })
log_and_msg <- function(..., .envir = parent.frame()) {
msg <- paste(...)
message(" -- ", msg)
# otel::log_info(msg, tracer = session$userData[["_otel_tracer"]])
# TODO: Remove the logger param once function is removed from Shiny package
otel_log(msg, logger = otel_logger)
}
@@ -207,8 +25,9 @@ dev_barret_kitchen <- function() {
sliderInput("mymod-x", "x", 1, 10, 5),
sliderInput("mymod-y", "y", 1, 10, 5),
div("x * y: "),
verbatimTextOutput("mymod-txt"),
# bslib::input_task_button("recalculate", "Recalculate"),
verbatimTextOutput("mymod-txt1"),
verbatimTextOutput("mymod-txt2"),
verbatimTextOutput("mymod-txt3"),
verbatimTextOutput("task_result")
),
server = function(input, output, session) {
@@ -217,8 +36,6 @@ dev_barret_kitchen <- function() {
b <- reactiveVal(1)
observe(b(42))
# shiny::bindOtel(TRUE)
shutdown <- function() {
later::later(
function() {
@@ -232,6 +49,16 @@ dev_barret_kitchen <- function() {
)
}
later::later(
function() {
if (!session$closed) {
log_and_msg("Invoking shutdown after 5s")
shutdown()
}
},
delay = 5
)
xMod <- function(id) {
moduleServer(id, function(input, output, session) {
xVal <- reactiveVal(NULL)
@@ -256,7 +83,7 @@ dev_barret_kitchen <- function() {
log_and_msg(sprintf("Y Val: %s", y_val))
# Sys.sleep(0.5)
y_val
}) |> bindCache(input$y)
}) |> bindCache(input$y) |> bindEvent(input$y)
y <- throttle(y_raw, 100)
calc <- reactive(label = "barret_calc", {
@@ -268,10 +95,19 @@ dev_barret_kitchen <- function() {
log_and_msg("x: ", x())
})
output$txt <- renderText({
output$txt1 <- renderText({
calc()
}) |>
bindCache(x(), y())
output$txt2 <- renderText({
calc()
}) |>
bindEvent(list(x(), y()))
output$txt3 <- renderText({
calc()
}) |>
bindCache(x(), y()) |>
bindEvent(list(x(), y()))
rand_task <- ExtendedTask$new(function() {
mirai::mirai(
@@ -283,11 +119,6 @@ dev_barret_kitchen <- function() {
)
})
# # Make button state reflect task.
# # If using R >=4.1, you can do this instead:
# # rand_task <- ExtendedTask$new(...) |> bind_task_button("recalculate")
# bslib::bind_task_button(rand_task, "recalculate")
observeEvent(input$x, {
# Invoke the extended in an observer
rand_task$invoke()

22
tests/testthat/test-bind-cache.R
View File

@@ -943,21 +943,25 @@ test_that("bindCache reactive visibility - async", {
})
})
flushReact()
for (i in 1:3) later::run_now()
flush_and_run_later <- function(k) {
flushReact()
for (i in 1:k) later::run_now()
}
flush_and_run_later(4)
expect_identical(res, list(value = 0, visible = FALSE))
k(1)
flushReact()
for (i in 1:3) later::run_now()
flush_and_run_later(4)
expect_identical(res, list(value = 1, visible = TRUE))
# Now fetch from cache
k(0)
flushReact()
for (i in 1:3) later::run_now()
flush_and_run_later(4)
expect_identical(res, list(value = 0, visible = FALSE))
k(1)
flushReact()
for (i in 1:3) later::run_now()
flush_and_run_later(4)
expect_identical(res, list(value = 1, visible = TRUE))
})
@@ -1136,6 +1140,8 @@ test_that("Custom render functions that call installExprFunction", {
test_that("cacheWriteHook and cacheReadHook for render functions", {
testthat::skip_if(get_tracer()$is_enabled(), "Skipping stack trace tests when OpenTelemetry is already enabled")
write_hook_n <- 0
read_hook_n <- 0

649
tests/testthat/test-otel-attr-srcref.R Normal file
View File

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

142
tests/testthat/test-otel-bind.R Normal file
View File

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

243
tests/testthat/test-otel-error.R Normal file
View File

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

288
tests/testthat/test-otel-label.R Normal file
View File

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

256
tests/testthat/test-otel-mock.R Normal file
View File

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

317
tests/testthat/test-otel-reactive-update.R Normal file
View File

@@ -0,0 +1,317 @@
# Tests for otel-reactive-update.R functions
# Helper function to create a mock ospan
create_mock_ospan <- function(name, attributes = NULL, ended = FALSE) {
structure(
list(name = name, attributes = attributes, ended = ended),
class = "mock_ospan"
)
}
# Mock is_ospan function
is_ospan <- function(x) {
inherits(x, "mock_ospan") && !isTRUE(x$ended)
}
test_that("has_reactive_ospan_cleanup works correctly", {
domain <- MockShinySession$new()
# Initially should be FALSE
expect_false(has_reactive_ospan_cleanup(domain))
# After setting, should be TRUE
domain$userData[["_otel_has_reactive_cleanup"]] <- TRUE
expect_true(has_reactive_ospan_cleanup(domain))
# With FALSE value, should be FALSE
domain$userData[["_otel_has_reactive_cleanup"]] <- FALSE
expect_false(has_reactive_ospan_cleanup(domain))
})
test_that("set_reactive_ospan_cleanup sets flag correctly", {
domain <- MockShinySession$new()
expect_false(has_reactive_ospan_cleanup(domain))
set_reactive_ospan_cleanup(domain)
expect_true(has_reactive_ospan_cleanup(domain))
})
test_that("reactive_update_ospan_is_active works correctly", {
domain <- MockShinySession$new()
# Initially should be FALSE
expect_false(reactive_update_ospan_is_active(domain))
# After setting, should be TRUE
domain$userData[["_otel_reactive_update_is_active"]] <- TRUE
expect_true(reactive_update_ospan_is_active(domain))
# With FALSE value, should be FALSE
domain$userData[["_otel_reactive_update_is_active"]] <- FALSE
expect_false(reactive_update_ospan_is_active(domain))
})
test_that("set_reactive_ospan_is_active sets flag correctly", {
domain <- MockShinySession$new()
expect_false(reactive_update_ospan_is_active(domain))
set_reactive_ospan_is_active(domain)
expect_true(reactive_update_ospan_is_active(domain))
})
test_that("clear_reactive_ospan_is_active clears flag correctly", {
domain <- MockShinySession$new()
# Set the flag first
set_reactive_ospan_is_active(domain)
expect_true(reactive_update_ospan_is_active(domain))
# Clear it
clear_reactive_ospan_is_active(domain)
expect_false(reactive_update_ospan_is_active(domain))
})
test_that("create_reactive_update_ospan returns early when otel not enabled", {
domain <- MockShinySession$new()
# Mock has_otel_bind to return FALSE
withr::local_options(list(shiny.otel.bind = "none"))
# Should return early without creating span
result <- create_reactive_update_ospan(domain = domain)
expect_null(result)
expect_null(domain$userData[["_otel_reactive_update_ospan"]])
})
test_that("create_reactive_update_ospan sets up session cleanup on first call", {
callback_added <- FALSE
TestMockShinySession <- R6::R6Class(
"TestMockShinySession",
inherit = MockShinySession,
portable = FALSE,
lock_objects = FALSE,
public = list(
# Mock onSessionEnded to track if callback is added
onSessionEnded = function(callback) {
callback_added <<- TRUE
expect_true(is.function(callback))
}
)
)
domain <- TestMockShinySession$new()
# Mock dependencies
withr::local_options(list(shiny.otel.bind = "reactive_update"))
with_mocked_bindings(
has_otel_bind = function(level) level == "reactive_update",
create_shiny_ospan = function(name, ..., attributes = NULL) create_mock_ospan(name, attributes = attributes),
otel_session_id_attrs = function(domain) list(session_id = "mock-session-id"),
{
create_reactive_update_ospan(domain = domain)
expect_true(callback_added)
expect_true(has_reactive_ospan_cleanup(domain))
expect_equal(domain$userData[["_otel_reactive_update_ospan"]], create_mock_ospan("reactive_update", attributes = list(session_id = "mock-session-id")))
}
)
})
test_that("create_reactive_update_ospan errors when span already exists", {
domain <- MockShinySession$new()
domain$token <- "mock-session-token"
# Set up existing span
existing_ospan <- create_mock_ospan("reactive_update", attributes = list(session.id = "mock-session-token"))
domain$userData[["_otel_reactive_update_ospan"]] <- existing_ospan
# Mock dependencies
with_mocked_bindings(
has_otel_bind = function(level) level == "reactive_update",
is_ospan = function(x) inherits(x, "mock_ospan"),
{
expect_error(
create_reactive_update_ospan(domain = domain),
"Reactive update span already exists"
)
}
)
})
test_that("create_reactive_update_ospan doesn't setup cleanup twice", {
TestMockShinySession <- R6::R6Class(
"TestMockShinySession",
inherit = MockShinySession,
portable = FALSE,
lock_objects = FALSE,
public = list(
# Mock onSessionEnded to track how many times callback is added
callback_count = 0,
onSessionEnded = function(callback) {
self$callback_count <- self$callback_count + 1
expect_true(is.function(callback))
}
)
)
domain <- TestMockShinySession$new()
# Set cleanup flag manually
set_reactive_ospan_cleanup(domain)
# Mock dependencies
mock_ospan <- create_mock_ospan("reactive_update")
with_mocked_bindings(
has_otel_bind = function(level) level == "reactive_update",
create_shiny_ospan = function(...) mock_ospan,
{
create_reactive_update_ospan(domain = domain)
# Should not have called onSessionEnded since cleanup was already set
expect_equal(domain$callback_count, 0)
}
)
})
test_that("end_reactive_update_ospan ends span when it exists", {
domain <- MockShinySession$new()
mock_ospan <- create_mock_ospan("reactive_update")
domain$userData[["_otel_reactive_update_ospan"]] <- mock_ospan
span_ended <- FALSE
with_mocked_bindings(
end_span = function(span) {
span_ended <<- TRUE
expect_equal(span, mock_ospan)
},
.package = "otel",
{
with_mocked_bindings(
is_ospan = function(x) inherits(x, "mock_ospan") && !isTRUE(x$ended),
{
end_reactive_update_ospan(domain = domain)
expect_true(span_ended)
expect_null(domain$userData[["_otel_reactive_update_ospan"]])
}
)
}
)
})
test_that("end_reactive_update_ospan handles missing span gracefully", {
domain <- MockShinySession$new()
# No span exists
expect_null(domain$userData[["_otel_reactive_update_ospan"]])
with_mocked_bindings(
is_ospan = function(x) FALSE,
{
# Should not error
expect_no_error(end_reactive_update_ospan(domain = domain))
}
)
})
test_that("with_reactive_update_active_ospan executes expr without span", {
domain <- MockShinySession$new()
# No span exists
test_value <- "initial"
with_mocked_bindings(
is_ospan = function(x) FALSE,
{
result <- with_reactive_update_active_ospan({
test_value <- "modified"
"result_value"
}, domain = domain)
expect_equal(result, "result_value")
expect_equal(test_value, "modified")
}
)
})
test_that("with_reactive_update_active_ospan executes expr with active span", {
domain <- MockShinySession$new()
mock_ospan <- create_mock_ospan("reactive_update")
domain$userData[["_otel_reactive_update_ospan"]] <- mock_ospan
span_was_active <- FALSE
test_value <- "initial"
local_mocked_bindings(
with_active_span = function(span, expr) {
span_was_active <<- TRUE
expect_equal(span, mock_ospan)
force(expr)
},
.package = "otel"
)
local_mocked_bindings(
is_ospan = function(x) inherits(x, "mock_ospan") && !isTRUE(x$ended)
)
result <- with_reactive_update_active_ospan({
test_value <- "modified"
"result_value"
}, domain = domain)
expect_true(span_was_active)
expect_equal(result, "result_value")
expect_equal(test_value, "modified")
})
test_that("session cleanup callback works correctly", {
TestMockShinySession <- R6::R6Class(
"TestMockShinySession",
inherit = MockShinySession,
portable = FALSE,
lock_objects = FALSE,
public = list(
# Mock onSessionEnded to capture the callback
onSessionEnded = function(callback) {
self$cleanup_callback <<- callback
},
cleanup_callback = NULL
)
)
domain <- TestMockShinySession$new()
# Mock dependencies and create span with cleanup
mock_ospan <- create_mock_ospan("reactive_update")
with_mocked_bindings(
has_otel_bind = function(level) level == "reactive_update",
create_shiny_ospan = function(...) mock_ospan,
otel_session_id_attrs = function(domain) list(session_id = "test"),
{
create_reactive_update_ospan(domain = domain)
}
)
# Verify cleanup callback was registered
expect_true(is.function(domain$cleanup_callback))
# Set up span and test cleanup
domain$userData[["_otel_reactive_update_ospan"]] <- mock_ospan
set_reactive_ospan_cleanup(domain)
span_ended <- FALSE
with_mocked_bindings(
has_reactive_ospan_cleanup = function(d) identical(d, domain),
end_reactive_update_ospan = function(domain = NULL) {
span_ended <<- TRUE
},
{
# Execute the cleanup callback
domain$cleanup_callback()
expect_true(span_ended)
}
)
})

288
tests/testthat/test-otel-session.R Normal file
View File

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

376
tests/testthat/test-otel-shiny.R Normal file
View File

@@ -0,0 +1,376 @@
# Tests for otel-shiny.R functions
# Helper function to create a mock otel span
create_mock_otel_span <- function() {
structure(
list(name = "test_span"),
class = "otel_span"
)
}
# Helper function to create a mock tracer
create_mock_tracer <- function() {
structure(
list(name = "mock_tracer", is_enabled = function() TRUE),
class = "otel_tracer"
)
}
# Helper function to create a mock logger
create_mock_logger <- function() {
structure(
list(name = "mock_logger"),
class = "otel_logger"
)
}
test_that("otel_tracer_name constant is correct", {
expect_equal(otel_tracer_name, "co.posit.r-package.shiny")
})
test_that("with_shiny_ospan_async calls with_ospan_async with correct parameters", {
mock_tracer <- create_mock_tracer()
with_ospan_async_called <- FALSE
test_value <- "initial"
with_mocked_bindings(
get_tracer = function() mock_tracer,
with_ospan_async = function(name, expr, ..., attributes = NULL, tracer = NULL) {
with_ospan_async_called <<- TRUE
expect_equal(name, "test_span")
expect_equal(tracer, mock_tracer)
expect_equal(attributes, list(key = "value"))
force(expr)
},
{
result <- with_shiny_ospan_async(
"test_span",
{
test_value <- "modified"
"result_value"
},
attributes = list(key = "value")
)
expect_true(with_ospan_async_called)
expect_equal(result, "result_value")
expect_equal(test_value, "modified")
}
)
})
test_that("create_shiny_ospan calls otel::start_span with correct parameters", {
mock_tracer <- create_mock_tracer()
mock_span <- create_mock_otel_span()
start_span_called <- FALSE
local_mocked_bindings(
start_span = function(name, ..., tracer = NULL) {
start_span_called <<- TRUE
expect_equal(name, "test_span")
expect_equal(tracer, mock_tracer)
mock_span
},
.package = "otel"
)
with_mocked_bindings(
get_tracer = function() mock_tracer,
{
result <- create_shiny_ospan("test_span", extra_param = "value")
expect_true(start_span_called)
expect_equal(result, mock_span)
}
)
})
test_that("is_ospan correctly identifies otel spans", {
# Test with otel_span object
otel_span <- create_mock_otel_span()
expect_true(is_ospan(otel_span))
# Test with non-otel objects
expect_false(is_ospan("string"))
expect_false(is_ospan(123))
expect_false(is_ospan(list()))
expect_false(is_ospan(NULL))
# Test with object that has different class
other_obj <- structure(list(), class = "other_class")
expect_false(is_ospan(other_obj))
})
test_that("testthat__is_testing detects testing environment", {
# Test when TESTTHAT env var is set to "true"
withr::local_envvar(list(TESTTHAT = "true"))
expect_true(testthat__is_testing())
# Test when TESTTHAT env var is not set
withr::local_envvar(list(TESTTHAT = NA))
expect_false(testthat__is_testing())
# Test when TESTTHAT env var is set to other values
withr::local_envvar(list(TESTTHAT = "false"))
expect_false(testthat__is_testing())
withr::local_envvar(list(TESTTHAT = ""))
expect_false(testthat__is_testing())
})
test_that("otel_log calls otel::log with correct parameters", {
mock_logger <- create_mock_logger()
log_called <- FALSE
local_mocked_bindings(
log = function(msg, ..., severity = NULL, logger = NULL) {
log_called <<- TRUE
expect_equal(msg, "test message")
expect_equal(severity, "warn")
expect_equal(logger, mock_logger)
},
.package = "otel"
)
with_mocked_bindings(
get_ospan_logger = function() mock_logger,
{
otel_log("test message", severity = "warn")
expect_true(log_called)
}
)
})
test_that("otel_log uses default severity and logger", {
mock_logger <- create_mock_logger()
log_called <- FALSE
local_mocked_bindings(
log = function(msg, ..., severity = NULL, logger = NULL) {
log_called <<- TRUE
expect_equal(msg, "default test")
expect_equal(severity, "info") # Default severity
expect_equal(logger, mock_logger) # Default logger
},
.package = "otel"
)
with_mocked_bindings(
get_ospan_logger = function() mock_logger,
{
otel_log("default test")
expect_true(log_called)
}
)
})
test_that("otel_is_tracing_enabled calls otel::is_tracing_enabled", {
mock_tracer <- create_mock_tracer()
is_tracing_called <- FALSE
local_mocked_bindings(
is_tracing_enabled = function(tracer) {
is_tracing_called <<- TRUE
expect_equal(tracer, mock_tracer)
TRUE
},
.package = "otel"
)
with_mocked_bindings(
get_tracer = function() mock_tracer,
{
result <- otel_is_tracing_enabled()
expect_true(is_tracing_called)
expect_true(result)
}
)
})
test_that("otel_is_tracing_enabled accepts custom tracer", {
custom_tracer <- create_mock_tracer()
is_tracing_called <- FALSE
local_mocked_bindings(
is_tracing_enabled = function(tracer) {
is_tracing_called <<- TRUE
expect_equal(tracer, custom_tracer)
FALSE
},
.package = "otel"
)
result <- otel_is_tracing_enabled(custom_tracer)
expect_true(is_tracing_called)
expect_false(result)
})
test_that("get_ospan_logger caches logger in non-test environment", {
mock_logger <- create_mock_logger()
get_logger_call_count <- 0
fn_env <- environment(get_ospan_logger)
# Reset cached logger now and when test ends
fn_env$reset_logger()
withr::defer({ fn_env$reset_logger() })
local_mocked_bindings(
otel_get_logger = function() {
get_logger_call_count <<- get_logger_call_count + 1
mock_logger
}
)
with_mocked_bindings(
testthat__is_testing = function() TRUE,
{
# First call
logger1 <- get_ospan_logger()
expect_equal(logger1, mock_logger)
expect_equal(get_logger_call_count, 1)
# Second call should call otel::get_logger again (no caching in tests)
logger2 <- get_ospan_logger()
expect_equal(logger2, mock_logger)
expect_equal(get_logger_call_count, 2) # Incremented
}
)
with_mocked_bindings(
testthat__is_testing = function() FALSE,
{
# First call should call otel::get_logger
logger1 <- get_ospan_logger()
expect_equal(logger1, mock_logger)
expect_equal(get_logger_call_count, 3)
# Second call should use cached logger
logger2 <- get_ospan_logger()
expect_equal(logger2, mock_logger)
expect_equal(get_logger_call_count, 3) # Still 3, not incremented
}
)
})
test_that("get_tracer caches tracer in non-test environment", {
mock_tracer <- create_mock_tracer()
get_tracer_call_count <- 0
fn_env <- environment(get_tracer)
# Reset cached tracer now and when test ends
fn_env$reset_tracer()
withr::defer({ fn_env$reset_tracer() })
local_mocked_bindings(
otel_get_tracer = function() {
get_tracer_call_count <<- get_tracer_call_count + 1
mock_tracer
}
)
with_mocked_bindings(
testthat__is_testing = function() TRUE,
{
# First call
tracer1 <- get_tracer()
expect_equal(tracer1, mock_tracer)
expect_equal(get_tracer_call_count, 1)
# Second call should call otel::get_tracer again (no caching in tests)
tracer2 <- get_tracer()
expect_equal(tracer2, mock_tracer)
expect_equal(get_tracer_call_count, 2) # Incremented
}
)
with_mocked_bindings(
testthat__is_testing = function() FALSE,
{
# First call should call otel::get_tracer
tracer1 <- get_tracer()
expect_equal(tracer1, mock_tracer)
expect_equal(get_tracer_call_count, 3)
# Second call should use cached tracer
tracer2 <- get_tracer()
expect_equal(tracer2, mock_tracer)
expect_equal(get_tracer_call_count, 3) # Still 3, not incremented
}
)
})
test_that("integration test - with_shiny_ospan_async uses cached tracer", {
mock_tracer <- create_mock_tracer()
get_tracer_call_count <- 0
with_ospan_async_called <- FALSE
fn_env <- environment(get_tracer)
# Reset cached tracer now and when test ends
fn_env$reset_tracer()
withr::defer({ fn_env$reset_tracer() })
local_mocked_bindings(
otel_get_tracer = function() {
get_tracer_call_count <<- get_tracer_call_count + 1
mock_tracer
}
)
with_mocked_bindings(
testthat__is_testing = function() FALSE,
with_ospan_async = function(name, expr, ..., attributes = NULL, tracer = NULL) {
with_ospan_async_called <<- TRUE
expect_equal(tracer, mock_tracer)
force(expr)
},
{
# First call to with_shiny_ospan_async
with_shiny_ospan_async("span1", { "result1" })
expect_equal(get_tracer_call_count, 1)
expect_true(with_ospan_async_called)
with_ospan_async_called <- FALSE
# Second call should use cached tracer
with_shiny_ospan_async("span2", { "result2" })
expect_equal(get_tracer_call_count, 1) # Still 1, tracer was cached
expect_true(with_ospan_async_called)
}
)
})
test_that("integration test - create_shiny_ospan with custom parameters", {
mock_tracer <- create_mock_tracer()
mock_span <- create_mock_otel_span()
start_span_params <- list()
local_mocked_bindings(
start_span = function(name, ..., tracer = NULL) {
start_span_params <<- list(
name = name,
tracer = tracer,
extra_args = list(...)
)
mock_span
},
.package = "otel"
)
with_mocked_bindings(
get_tracer = function() mock_tracer,
{
result <- create_shiny_ospan(
"custom_span",
attributes = list(key = "value"),
parent = "parent_span"
)
expect_equal(result, mock_span)
expect_equal(start_span_params$name, "custom_span")
expect_equal(start_span_params$tracer, mock_tracer)
expect_equal(start_span_params$extra_args$attributes, list(key = "value"))
expect_equal(start_span_params$extra_args$parent, "parent_span")
}
)
})

3
tests/testthat/test-reactivity.r
View File

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

6
tests/testthat/test-stacks.R
View File

@@ -118,6 +118,12 @@ dumpTests <- function(df) {
}
test_that("integration tests", {
if (get_tracer()$is_enabled()) {
announce_snapshot_file(name = "stacks.md")
skip("Skipping stack trace tests when OpenTelemetry is already enabled")
}
# The expected call stack can be changed by other packages (namely, promises).
# If promises changes its internals, it can break this test on CRAN. Because
# CRAN package releases are generally not synchronized (that is, promises and