fix: add stack trace fences to hide internal render pipeline frames

NEWS.md

@@ -8,6 +8,8 @@
 
 * Fixed an issue with `actionLink()` that extended the link underline to whitespace around the text. (#4348)
 
+* Stack traces from render functions (e.g., `renderPlot()`, `renderDataTable()`) now hide internal Shiny rendering pipeline frames, making error messages cleaner and more focused on user code. (#4358)
+
 # shiny 1.12.1
 
 ## New features

R/conditions.R

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

R/otel-attr-srcref.R

@@ -16,7 +16,9 @@ otel_srcref_attributes <- function(srcref, fn_name = NULL) {
   # Semantic conventions for code: https://opentelemetry.io/docs/specs/semconv/registry/attributes/code/
   #
   # Inspiration from https://github.com/r-lib/testthat/pull/2087/files#diff-92de3306849d93d6f7e76c5aaa1b0c037e2d716f72848f8a1c70536e0c8a1564R123-R124
-  filename <- attr(srcref, "srcfile")$filename
+  srcfile <- attr(srcref, "srcfile")
+  # Prefer the original filename (as user typed it) over the normalized path
+  filename <- getSrcfileFilename(srcfile)
   dropNulls(list(
     "code.function.name" = fn_name,
     # Location attrs

R/reactives.R

@@ -304,20 +304,23 @@ rassignSrcrefToLabel <- function(
   if (is.null(srcfile))
     return(defaultLabel)
 
-  if (is.null(srcfile$lines))
+  src <- getSrcfileLines(srcfile, srcref)
+  lines <- src$lines
+  line_num <- src$line_num
+
+  if (is.null(lines))
     return(defaultLabel)
 
-  lines <- srcfile$lines
   # When pasting at the Console, srcfile$lines is not split
   if (length(lines) == 1) {
     lines <- strsplit(lines, "\n")[[1]]
   }
 
-  if (length(lines) < srcref[1]) {
+  if (length(lines) < line_num) {
     return(defaultLabel)
   }
 
-  firstLine <- substring(lines[srcref[1]], srcref[2] - 1)
+  firstLine <- substring(lines[line_num], srcref[2] - 1)
 
   m <- regexec(
     # Require the first assignment within the line
@@ -1160,20 +1163,23 @@ rexprSrcrefToLabel <- function(srcref, defaultLabel, fnName) {
   if (is.null(srcfile))
     return(defaultLabel)
 
-  if (is.null(srcfile$lines))
+  src <- getSrcfileLines(srcfile, srcref)
+  lines <- src$lines
+  line_num <- src$line_num
+
+  if (is.null(lines))
     return(defaultLabel)
 
-  lines <- srcfile$lines
   # When pasting at the Console, srcfile$lines is not split
   if (length(lines) == 1) {
     lines <- strsplit(lines, "\n")[[1]]
   }
 
-  if (length(lines) < srcref[1]) {
+  if (length(lines) < line_num) {
     return(defaultLabel)
   }
 
-  firstLine <- substring(lines[srcref[1]], 1, srcref[2] - 1)
+  firstLine <- substring(lines[line_num], 1, srcref[2] - 1)
 
   # Require the assignment to be parsed from the start
   m <- regexec(paste0("^(.*)(<<-|<-|=)\\s*", fnName, "\\s*\\($"), firstLine)

R/shinywrappers.R

@@ -130,8 +130,10 @@ markRenderFunction <- function(
       # stop warning from happening again for the same object
       hasExecuted$set(TRUE)
     }
-    if (is.null(formals(renderFunc))) renderFunc()
-    else renderFunc(...)
+    ..stacktraceoff..(
+      if (is.null(formals(renderFunc))) renderFunc()
+      else renderFunc(...)
+    )
   }
 
   otelAttrs <-
@@ -275,7 +277,7 @@ createRenderFunction <- function(
 ) {
   renderFunc <- function(shinysession, name, ...) {
     hybrid_chain(
-      func(),
+      ..stacktraceon..(func()),
       function(value) {
         transform(value, shinysession, name, ...)
       }
@@ -628,7 +630,7 @@ renderPrint <- function(expr, env = parent.frame(), quoted = FALSE,
     domain <- createRenderPrintPromiseDomain(width)
     hybrid_chain(
       {
-        with_promise_domain(domain, func())
+        with_promise_domain(domain, ..stacktraceon..(func()))
       },
       function(value) {
         res <- withVisible(value)
@@ -963,7 +965,7 @@ legacyRenderDataTable <- function(expr, options = NULL, searchDelay = 500,
     options <- checkDT9(options)
     res <- checkAsIs(options)
     hybrid_chain(
-      func(),
+      ..stacktraceon..(func()),
       function(data) {
         if (length(dim(data)) != 2) return() # expects a rectangular data object
         if (is.data.frame(data)) data <- as.data.frame(data)

R/utils.R

@@ -1394,8 +1394,7 @@ maybeAnnotateSourceForArk <- function(file, lines) {
 
 # similarly, try to source() a file with UTF-8
 sourceUTF8 <- function(file, envir = globalenv()) {
-  file <- normalizePath(file, mustWork = TRUE, winslash = "/")
-
+  file_norm <- normalizePath(file, mustWork = TRUE, winslash = "/")
   lines <- readUTF8(file)
   enc <- if (any(Encoding(lines) == 'UTF-8')) 'UTF-8' else 'unknown'
 
@@ -1406,7 +1405,7 @@ sourceUTF8 <- function(file, envir = globalenv()) {
   # with a `#line` directive to map source references back to the original file
   lines <- c(
     "..stacktraceon..({",
-    sprintf('#line 1 "%s"', file),
+    sprintf('#line 1 "%s"', file_norm),
     lines,
     "})"
   )