Make Rdfile info conveniently available for Sexpr code.

git-svn-id: https://svn.r-project.org/R/trunk@88497 00db46b3-68df-0310-9c12-caf00c1e9a41

Author: hornik

src/library/tools/R/RdConv2.R

@@ -206,6 +206,14 @@ processRdChunk <- function(code, stage, options, env, macros)
     if (is.null(opts <- attr(code, "Rd_option"))) opts <- ""
     codesrcref <- attr(code, "srcref")
     Rdfile <- attr(codesrcref, "srcfile")$filename
+    ## Provide Rdfile for easy access to Sexpr code (instead of having
+    ## to look in the call stack for the call to processRdChunk() and
+    ## get Rdfile from the correspnding frame.
+    ## We may want to provide Rdfile and other information for the whole
+    ## prepare_Rd() processing, but that recalls itself so dropping the
+    ## information on exit is not straightforward.
+    processRdChunk_data_store(list(Rdfile = Rdfile))
+    on.exit(processRdChunk_data_store(NULL))
     options <- utils:::SweaveParseOptions(opts, options, RweaveRdOptions)
     if (stage == options$stage) {
         #  The code below is very similar to RWeaveLatexRuncode, but simplified
@@ -362,6 +370,16 @@ processRdChunk <- function(code, stage, options, env, macros)
     replaceRdSrcrefs(res, codesrcref)
 }
 
+processRdChunk_data_store <- local({
+    .store <- NULL
+    function(new) {
+        if(!missing(new))
+            .store <<- new
+        else
+            .store
+    }
+})
+
 processRdIfdefs <- function(blocks, defines)
 {
     recurse <- function(block) {
@@ -470,6 +488,10 @@ prepare_Rd <-
     srcref <- attr(Rd, "srcref")
     if (is.null(Rdfile) && !is.null(srcref))
     	Rdfile <- attr(srcref, "srcfile")$filename
+    ## prepare_Rd_data_store(list(Rdfile = Rdfile))
+    ## prepare_Rd_data_store(Rdfile)
+    ## saveRDS(prepare_Rd_data_store(), file = "~/tmp/yyy2.rds")
+    ## on.exit(prepare_Rd_data_store(NULL))
     if (fragment) meta <- NULL
     else {
 	pratt <- attr(Rd, "prepared")

src/library/tools/R/RdHelpers.R

@@ -210,8 +210,11 @@ function(x)
                       use.names = FALSE)
     if(any(ind <- nzchar(footers)))
         footers[ind] <- paste("\\cr", footers[ind])
-    paste(sprintf("%s\\if{html}{\u2060\\out{<span id=\"reference+%s\">}}%s\\if{html}{\\out{</span>}}%s",
+    rdfile <- processRdChunk_data_store()$Rdfile
+    rdpath <- if(length(rdfile)) basename(rdfile) else ""
+    paste(sprintf("%s\\if{html}{\u2060\\out{<span id=\"reference+%s+%s\">}}%s\\if{html}{\\out{</span>}}%s",
                   headers,
+                  rdpath,
                   string2id(.bibentry_get_key(y)),
                   toRd(y),
                   footers),
@@ -258,6 +261,8 @@ function(x, textual = FALSE)
         return("")
     y <- character(n)
     prev <- Rd_expr_bibcite_keys_cited()
+    rdfile <- processRdChunk_data_store()$Rdfile
+    rdpath <- if(length(rdfile)) basename(rdfile) else ""
     if(textual) {
         for(i in seq_len(n)) {
             key <- keys[i]
@@ -268,7 +273,8 @@ function(x, textual = FALSE)
         if(any(ind <- nzchar(before)))
             before[ind] <- paste0(before[ind], " ")
         y <- paste0(before,
-                    sprintf("\\if{html}{\\out{<a href=\"#reference+%s\">}}",
+                    sprintf("\\if{html}{\\out{<a href=\"#reference+%s+%s\">}}",
+                            rdpath,
                             string2id(keys)),
                     y,
                     rep_len("\\if{html}{\\out{</a>}}", n),
@@ -288,7 +294,8 @@ function(x, textual = FALSE)
             after[ind] <- paste0(", ", after[ind])
         y <- paste0("(",
                     paste0(before,
-                           sprintf("\\if{html}{\\out{<a href=\"#reference+%s\">}}",
+                           sprintf("\\if{html}{\\out{<a href=\"#reference+%s+%s\">}}",
+                                   rdpath,
                                    string2id(keys)),
                            y,
                            rep_len("\\if{html}{\\out{</a>}}", n),