diff --git a/DESCRIPTION b/DESCRIPTION index b607a24c0..b8d0219c0 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -91,7 +91,7 @@ Imports: lifecycle (>= 0.2.0), mime (>= 0.3), otel, - promises (>= 1.3.3.9006), + promises (>= 1.4.0), R6 (>= 2.0), rlang (>= 0.4.10), sourcetools, @@ -120,8 +120,6 @@ Suggests: testthat (>= 3.2.1), watcher, yaml -Remotes: - rstudio/promises Config/Needs/check: shinytest2 Config/testthat/edition: 3 Encoding: UTF-8 @@ -190,8 +188,7 @@ Collate: 'otel-label.R' 'otel-reactive-update.R' 'otel-session.R' - 'otel-with.R' - 'otel.R' + 'otel-shiny.R' 'priorityqueue.R' 'progress.R' 'react.R' diff --git a/NAMESPACE b/NAMESPACE index 93304b631..3023677fa 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -392,6 +392,7 @@ importFrom(promises,local_ospan_promise_domain) importFrom(promises,promise) importFrom(promises,promise_reject) importFrom(promises,promise_resolve) +importFrom(promises,then) importFrom(promises,with_ospan_async) importFrom(promises,with_ospan_promise_domain) importFrom(rlang,"%||%") diff --git a/NEWS.md b/NEWS.md index 18916a653..b62f8f3ed 100644 --- a/NEWS.md +++ b/NEWS.md @@ -38,7 +38,10 @@ * Fixed an issue where `updateSelectizeInput(options = list(plugins="remove_button"))` could lead to multiple remove buttons. (#4275) -* The default label for `reactiveValues()`, `reactivePoll()`, `reactiveFileReader()`, `debounce()`, and `throttle()` will now attempt to retrieve the assigned name if the srcref is available. If a value can not easily be produced, a default label will be used instead. (#4269) +* The default label for items described below will now attempt to retrieve the assigned name if the srcref is available. If a value can not easily be produced, a default label will be used instead. This should improve the OpenTelemetry span labels and the reactlog experience. (#4269, #4300) + * `reactiveValues()`, `reactivePoll()`, `reactiveFileReader()`, `debounce()`, `throttle()`, `observe()` + * Combinations of `bindEvent()` and `reactive()` / `observe()` + * Combination of `bindCache()` and `reactive()` ## Changes diff --git a/R/bind-cache.R b/R/bind-cache.R index 80a8da35d..19ea65fa7 100644 --- a/R/bind-cache.R +++ b/R/bind-cache.R @@ -478,7 +478,12 @@ bindCache.default <- function(x, ...) { bindCache.reactiveExpr <- function(x, ..., cache = "app") { check_dots_unnamed() - label <- exprToLabel(substitute(x), "cachedReactive") + call_srcref <- attr(sys.call(-1), "srcref", exact = TRUE) + label <- rassignSrcrefToLabel( + call_srcref, + defaultLabel = exprToLabel(substitute(x), "cachedReactive") + ) + domain <- reactive_get_domain(x) # Convert the ... to a function that returns their evaluated values. @@ -490,6 +495,9 @@ bindCache.reactiveExpr <- function(x, ..., cache = "app") { cacheHint <- rlang::hash(extractCacheHint(x)) valueFunc <- wrapFunctionLabel(valueFunc, "cachedReactiveValueFunc", ..stacktraceon = TRUE) + x_classes <- class(x) + x_otel_attrs <- attr(x, "observable", exact = TRUE)$.otelAttrs + # Don't hold on to the reference for x, so that it can be GC'd rm(x) # Hacky workaround for issue with `%>%` preventing GC: @@ -498,16 +506,27 @@ bindCache.reactiveExpr <- function(x, ..., cache = "app") { rm(list = ".", envir = .GenericCallEnv, inherits = FALSE) } - - res <- reactive(label = label, domain = domain, { - cache <- resolve_cache_object(cache, domain) - hybrid_chain( - keyFunc(), - generateCacheFun(valueFunc, cache, cacheHint, cacheReadHook = identity, cacheWriteHook = identity) - ) + with_no_otel_bind({ + res <- reactive(label = label, domain = domain, { + cache <- resolve_cache_object(cache, domain) + hybrid_chain( + keyFunc(), + generateCacheFun(valueFunc, cache, cacheHint, cacheReadHook = identity, cacheWriteHook = identity) + ) + }) }) class(res) <- c("reactive.cache", class(res)) + + impl <- attr(res, "observable", exact = TRUE) + impl$.otelAttrs <- x_otel_attrs + if (!is.null(call_srcref)) { + otelAttrs <- otel_srcref_attributes(call_srcref) + impl$.otelAttrs[names(otelAttrs)] <- otelAttrs + } + if (has_otel_bind("reactivity")) { + res <- bind_otel_reactive_expr(res) + } res } @@ -534,6 +553,7 @@ bindCache.shiny.render.function <- function(x, ..., cache = "app") { ) } + # Passes over the otelAttrs from valueFunc to renderFunc renderFunc <- addAttributes(renderFunc, renderFunctionAttributes(valueFunc)) class(renderFunc) <- c("shiny.render.function.cache", class(valueFunc)) renderFunc @@ -585,7 +605,7 @@ bindCache.shiny.renderPlot <- function(x, ..., observe({ doResizeCheck() - }) + }, label = "plot-resize") # TODO: Make sure this observer gets GC'd if output$foo is replaced. # Currently, if you reassign output$foo, the observer persists until the # session ends. This is generally bad programming practice and should be diff --git a/R/bind-event.R b/R/bind-event.R index 43f0aeaf7..7c98df8db 100644 --- a/R/bind-event.R +++ b/R/bind-event.R @@ -196,10 +196,20 @@ bindEvent.reactiveExpr <- function(x, ..., ignoreNULL = TRUE, ignoreInit = FALSE valueFunc <- reactive_get_value_func(x) valueFunc <- wrapFunctionLabel(valueFunc, "eventReactiveValueFunc", ..stacktraceon = TRUE) - label <- label %||% - sprintf('bindEvent(%s, %s)', attr(x, "observable", exact = TRUE)$.label, quos_to_label(qs)) + call_srcref <- attr(sys.call(-1), "srcref", exact = TRUE) + if (is.null(label)) { + label <- rassignSrcrefToLabel( + call_srcref, + defaultLabel = as_default_label(sprintf( + 'bindEvent(%s, %s)', + attr(x, "observable", exact = TRUE)$.label, + quos_to_label(qs) + )) + ) + } x_classes <- class(x) + x_otel_attrs <- attr(x, "observable", exact = TRUE)$.otelAttrs # Don't hold on to the reference for x, so that it can be GC'd rm(x) @@ -228,6 +238,14 @@ bindEvent.reactiveExpr <- function(x, ..., ignoreNULL = TRUE, ignoreInit = FALSE class(res) <- c("reactive.event", x_classes) + impl <- attr(res, "observable", exact = TRUE) + impl$.otelAttrs <- x_otel_attrs + if (!is.null(call_srcref)) { + otelAttrs <- otel_srcref_attributes(call_srcref) + # Overwrite any existing attributes with these new ones + # (such as code.filepath, code.lineno, code.column) + impl$.otelAttrs[names(otelAttrs)] <- otelAttrs + } if (has_otel_bind("reactivity")) { res <- bind_otel_reactive_expr(res) } @@ -260,6 +278,7 @@ bindEvent.shiny.render.function <- function(x, ..., ignoreNULL = TRUE, ignoreIni ) } + # Passes over the otelAttrs from valueFunc to renderFunc renderFunc <- addAttributes(renderFunc, renderFunctionAttributes(valueFunc)) class(renderFunc) <- c("shiny.render.function.event", class(valueFunc)) renderFunc @@ -280,7 +299,17 @@ bindEvent.Observer <- function(x, ..., ignoreNULL = TRUE, ignoreInit = FALSE, # Note that because the observer will already have been logged by this point, # this updated label won't show up in the reactlog. - x$.label <- label %||% sprintf('bindEvent(%s, %s)', x$.label, quos_to_label(qs)) + if (is.null(label)) { + call_srcref <- attr(sys.call(-1), "srcref", exact = TRUE) + x$.label <- rassignSrcrefToLabel( + call_srcref, + defaultLabel = as_default_label( + sprintf('bindEvent(%s, %s)', x$.label, quos_to_label(qs)) + ) + ) + } else { + x$.label <- label + } initialized <- FALSE @@ -313,9 +342,17 @@ bindEvent.Observer <- function(x, ..., ignoreNULL = TRUE, ignoreInit = FALSE, ) class(x) <- c("Observer.event", class(x)) + call_srcref <- attr(sys.call(-1), "srcref", exact = TRUE) + if (!is.null(call_srcref)) { + otelAttrs <- otel_srcref_attributes(call_srcref) + # Overwrite any existing attributes with these new ones + # (such as code.filepath, code.lineno, code.column) + x$.otelAttrs[names(otelAttrs)] <- otelAttrs + } if (has_otel_bind("reactivity")) { x <- bind_otel_observe(x) } + invisible(x) } diff --git a/R/extended-task.R b/R/extended-task.R index 7ead173dd..df845ef55 100644 --- a/R/extended-task.R +++ b/R/extended-task.R @@ -119,9 +119,9 @@ ExtendedTask <- R6Class("ExtendedTask", portable = TRUE, cloneable = FALSE, # Do not show these private reactive values in otel spans with_no_otel_bind({ - private$rv_status <- reactiveVal("initial") - private$rv_value <- reactiveVal(NULL) - private$rv_error <- reactiveVal(NULL) + private$rv_status <- reactiveVal("initial", label = "ExtendedTask$private$status") + private$rv_value <- reactiveVal(NULL, label = "ExtendedTask$private$value") + private$rv_error <- reactiveVal(NULL, label = "ExtendedTask$private$error") }) private$invocation_queue <- fastmap::fastqueue() @@ -134,12 +134,16 @@ ExtendedTask <- R6Class("ExtendedTask", portable = TRUE, cloneable = FALSE, call_srcref <- attr(sys.call(-1), "srcref", exact = TRUE) label <- rassignSrcrefToLabel( call_srcref, - defaultLabel = "", - fnName = "ExtendedTask\\$new" + defaultLabel = "" ) 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, diff --git a/R/mock-session.R b/R/mock-session.R index a888f0eea..53f9dcc0c 100644 --- a/R/mock-session.R +++ b/R/mock-session.R @@ -436,34 +436,36 @@ MockShinySession <- R6Class( if (!is.function(func)) stop(paste("Unexpected", class(func), "output for", name)) - obs <- observe({ - # We could just stash the promise, but we get an "unhandled promise error". This bypasses - prom <- NULL - tryCatch({ - v <- private$withCurrentOutput(name, func(self, name)) - if (!promises::is.promise(v)){ - # Make our sync value into a promise - prom <- promises::promise(function(resolve, reject){ resolve(v) }) - } else { - prom <- v - } - }, error=function(e){ - # Error running value() - prom <<- promises::promise(function(resolve, reject){ reject(e) }) - }) - - private$outs[[name]]$promise <- hybrid_chain( - prom, - function(v){ - list(val = v, err = NULL) - }, catch=function(e){ - if ( - !inherits(e, c("shiny.custom.error", "shiny.output.cancel", "shiny.output.progress", "shiny.silent.error")) - ) { - self$unhandledError(e, close = FALSE) + with_no_otel_bind({ + obs <- observe({ + # We could just stash the promise, but we get an "unhandled promise error". This bypasses + prom <- NULL + tryCatch({ + v <- private$withCurrentOutput(name, func(self, name)) + if (!promises::is.promise(v)){ + # Make our sync value into a promise + prom <- promises::promise(function(resolve, reject){ resolve(v) }) + } else { + prom <- v } - list(val = NULL, err = e) + }, error=function(e){ + # Error running value() + prom <<- promises::promise(function(resolve, reject){ reject(e) }) }) + + private$outs[[name]]$promise <- hybrid_chain( + prom, + function(v){ + list(val = v, err = NULL) + }, catch=function(e){ + if ( + !inherits(e, c("shiny.custom.error", "shiny.output.cancel", "shiny.output.progress", "shiny.silent.error")) + ) { + self$unhandledError(e, close = FALSE) + } + list(val = NULL, err = e) + }) + }) }) private$outs[[name]] <- list(obs = obs, func = func, promise = NULL) }, diff --git a/R/otel-bind.R b/R/otel-bind.R index e3b71fe79..e186e45c8 100644 --- a/R/otel-bind.R +++ b/R/otel-bind.R @@ -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,15 +249,20 @@ 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( diff --git a/R/otel-label.R b/R/otel-label.R index f3426d4e3..6dfb1fee1 100644 --- a/R/otel-label.R +++ b/R/otel-label.R @@ -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 %||% "" + ospan_label <- otel_label_upgrade(label, domain = domain) sprintf("%s %s", fn_name, ospan_label) } diff --git a/R/otel-session.R b/R/otel-session.R index 82b5794d3..8953ede23 100644 --- a/R/otel-session.R +++ b/R/otel-session.R @@ -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 ) } diff --git a/R/otel.R b/R/otel-shiny.R similarity index 78% rename from R/otel.R rename to R/otel-shiny.R index d6fc5a435..b66eb5f23 100644 --- a/R/otel.R +++ b/R/otel-shiny.R @@ -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 } }) diff --git a/R/otel-with.R b/R/otel-with.R deleted file mode 100644 index 5feeb92e8..000000000 --- a/R/otel-with.R +++ /dev/null @@ -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) -} diff --git a/R/react.R b/R/react.R index c3a3ff13e..9b8160cfe 100644 --- a/R/react.R +++ b/R/react.R @@ -19,7 +19,8 @@ processId <- local({ ctx_otel_info_obj <- function( isRecordingOtel = FALSE, otelLabel = "", - otelAttrs = NULL) { + otelAttrs = list() +) { structure( list( isRecordingOtel = isRecordingOtel, diff --git a/R/reactive-domains.R b/R/reactive-domains.R index 6f0fb813c..6c96354d4 100644 --- a/R/reactive-domains.R +++ b/R/reactive-domains.R @@ -45,6 +45,8 @@ createMockDomain <- function() { callbacks <- Callbacks$new() ended <- FALSE domain <- new.env(parent = emptyenv()) + domain$ns <- function(id) id + domain$token <- "mock-domain" domain$onEnded <- function(callback) { return(callbacks$register(callback)) } diff --git a/R/reactives.R b/R/reactives.R index 4a3ea114a..6e0bfc46f 100644 --- a/R/reactives.R +++ b/R/reactives.R @@ -225,8 +225,7 @@ reactiveVal <- function(value = NULL, label = NULL) { 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)) @@ -639,8 +638,7 @@ reactiveValues <- function(...) { 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) @@ -1555,7 +1553,14 @@ observe <- function( check_dots_empty() func <- installExprFunction(x, "func", env, quoted) - label <- funcToLabel(func, "observe", label) + + call_srcref <- attr(sys.call(), "srcref", exact = TRUE) + if (is.null(label)) { + label <- rassignSrcrefToLabel( + call_srcref, + defaultLabel = funcToLabel(func, "observe", label) + ) + } o <- Observer$new( func, @@ -2459,7 +2464,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 <- attr(sys.call(), "srcref", exact = TRUE) + if (is.null(label)) { + label <- rassignSrcrefToLabel( + call_srcref, + defaultLabel = quoToLabel(eventQ, "observeEvent", label) + ) + } with_no_otel_bind({ handler <- inject(observe( @@ -2471,16 +2483,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) } @@ -2507,22 +2526,32 @@ eventReactive <- function(eventExpr, valueExpr, 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) { @@ -2646,8 +2675,7 @@ debounce <- function(r, millis, priority = 100, domain = getDefaultReactiveDomai call_srcref <- attr(sys.call(), "srcref", exact = TRUE) label <- rassignSrcrefToLabel( call_srcref, - defaultLabel = "", - fnName = "debounce" + defaultLabel = "" ) if (!is.function(millis)) { @@ -2723,6 +2751,9 @@ debounce <- function(r, millis, priority = 100, domain = getDefaultReactiveDomai local({ er_impl <- attr(er, "observable", exact = TRUE) er_impl$.otelLabel <- otel_label_debounce(label, domain = domain) + if (!is.null(call_srcref)) { + er_impl$.otelAttrs <- otel_srcref_attributes(call_srcref) + } }) with_no_otel_bind({ @@ -2750,8 +2781,7 @@ throttle <- function(r, millis, priority = 100, domain = getDefaultReactiveDomai call_srcref <- attr(sys.call(), "srcref", exact = TRUE) label <- rassignSrcrefToLabel( call_srcref, - defaultLabel = "", - fnName = "throttle" + defaultLabel = "" ) if (!is.function(millis)) { @@ -2822,6 +2852,9 @@ 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) + if (!is.null(call_srcref)) { + er_impl$.otelAttrs <- otel_srcref_attributes(call_srcref) + } }) er diff --git a/R/shiny-package.R b/R/shiny-package.R index c2cab6ddf..65a74ea0f 100644 --- a/R/shiny-package.R +++ b/R/shiny-package.R @@ -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 diff --git a/tests/testthat/_snaps/reactivity.md b/tests/testthat/_snaps/reactivity.md new file mode 100644 index 000000000..37dd53655 --- /dev/null +++ b/tests/testthat/_snaps/reactivity.md @@ -0,0 +1,6 @@ +# reactiveValues() has useful print method + + + Values: x, y, z + Readonly: FALSE + diff --git a/tests/testthat/helper-barret.R b/tests/testthat/helper-barret.R index 7b492e9de..683b1cd38 100644 --- a/tests/testthat/helper-barret.R +++ b/tests/testthat/helper-barret.R @@ -207,7 +207,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"), + verbatimTextOutput("mymod-txt1"), + verbatimTextOutput("mymod-txt2"), + verbatimTextOutput("mymod-txt3"), # bslib::input_task_button("recalculate", "Recalculate"), verbatimTextOutput("task_result") ), @@ -256,7 +258,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 +270,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( diff --git a/tests/testthat/test-bind-cache.R b/tests/testthat/test-bind-cache.R index 0ff036d35..bad35ef12 100644 --- a/tests/testthat/test-bind-cache.R +++ b/tests/testthat/test-bind-cache.R @@ -1136,6 +1136,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 diff --git a/tests/testthat/test-otel-attr-srcref.R b/tests/testthat/test-otel-attr-srcref.R new file mode 100644 index 000000000..843a479fc --- /dev/null +++ b/tests/testthat/test-otel-attr-srcref.R @@ -0,0 +1,617 @@ +# 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") + + 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 + ) +} + + + +# 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 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"]]) + }) +}) diff --git a/tests/testthat/test-otel-bind.R b/tests/testthat/test-otel-bind.R new file mode 100644 index 000000000..7d343998a --- /dev/null +++ b/tests/testthat/test-otel-bind.R @@ -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") +}) diff --git a/tests/testthat/test-otel-label.R b/tests/testthat/test-otel-label.R new file mode 100644 index 000000000..3f9c4cf54 --- /dev/null +++ b/tests/testthat/test-otel-label.R @@ -0,0 +1,260 @@ +# 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 ") + 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 " + ) +}) + +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 ") +}) + +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 ") + + 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" + ) +}) + +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 + result <- otel_label_upgrade(as_default_label("observe({})"), domain = NULL) + expect_equal(result, "") + + result <- otel_label_upgrade(as_default_label("eventReactive(input$btn, {})"), domain = NULL) + expect_equal(result, "") + + # 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") +}) diff --git a/tests/testthat/test-otel-mock.R b/tests/testthat/test-otel-mock.R new file mode 100644 index 000000000..a7a995361 --- /dev/null +++ b/tests/testthat/test-otel-mock.R @@ -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:") + 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:") + + # 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:") + 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))) + }) +} diff --git a/tests/testthat/test-otel-reactive-update.R b/tests/testthat/test-otel-reactive-update.R new file mode 100644 index 000000000..c6952d78a --- /dev/null +++ b/tests/testthat/test-otel-reactive-update.R @@ -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) + } + ) +}) diff --git a/tests/testthat/test-otel-session.R b/tests/testthat/test-otel-session.R new file mode 100644 index 000000000..a183297d2 --- /dev/null +++ b/tests/testthat/test-otel-session.R @@ -0,0 +1,288 @@ +# Tests for otel-session.R functions + +# Helper function to create a mock domain with request info +create_mock_session_domain <- function( + token = "test-session-123", + request = list(), + session_ended_callbacks = list() +) { + TestMockShinySession <- R6::R6Class( + "TestMockShinySession", + inherit = MockShinySession, + portable = FALSE, + lock_objects = FALSE, + public = list( + # Mock onSessionEnded to capture the callback + onSessionEnded = function(callback) { + expect_true(is.function(callback)) + self$cleanup_callbacks <- c(self$cleanup_callbacks, list(callback)) + }, + cleanup_callbacks = NULL, + request_val = NULL + ), + active = list( + request = function(value) { + if (!missing(value)) { + self$request_val <- value + } else { + self$request_val + } + } + + ) + ) + + domain <- TestMockShinySession$new() + + domain$request <- request + domain$token <- token + + domain +} + +test_that("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) + } + ) +}) diff --git a/tests/testthat/test-otel-shiny.R b/tests/testthat/test-otel-shiny.R new file mode 100644 index 000000000..c6f10bd4e --- /dev/null +++ b/tests/testthat/test-otel-shiny.R @@ -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") + } + ) +}) diff --git a/tests/testthat/test-reactivity.r b/tests/testthat/test-reactivity.r index e77ad0130..a65287096 100644 --- a/tests/testthat/test-reactivity.r +++ b/tests/testthat/test-reactivity.r @@ -144,7 +144,7 @@ test_that("reactiveValues keys are sorted", { }) test_that("reactiveValues() has useful print method", { - verify_output(test_path("print-reactiveValues.txt"), { + expect_snapshot_output({ x <- reactiveValues(x = 1, y = 2, z = 3) x }) @@ -1656,4 +1656,3 @@ test_that("Contexts can be masked off via promise domains", { later::run_now(all=FALSE) } }) - diff --git a/tests/testthat/test-stacks.R b/tests/testthat/test-stacks.R index b34048217..d11c777ff 100644 --- a/tests/testthat/test-stacks.R +++ b/tests/testthat/test-stacks.R @@ -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