Enhancements for c88462.

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

Author: hornik

src/library/tools/R/RdHelpers.R

@@ -180,18 +180,41 @@ function(x)
         return(x)
     }
     bib <- R_bibentries()
-    ## <FIXME>
+    cited <- Rd_expr_bibcite_keys_cited()    
     ## Would be nice to have a common reader for possibly multi-line
     ## comma separated values ...
-    keys <- strsplit(x, ",[[:space:]]*")[[1L]]
-    if(any(keys == "*")) {
-        keys <- c(keys, Rd_expr_bibcite_keys_cited())
-        Rd_expr_bibcite_keys_cited(NULL)
+    given <- strsplit(x, ",[[:space:]]*")[[1L]]
+    if(any(given == "*"))
+        given <- c(given[given != "*"], cited)
+    Rd_expr_bibcite_keys_cited(setdiff(cited, given))
+    y <- sort(unique(bib[.bibentry_get_key(bib) %in% given]))
+    ## Merge bibinfo data.
+    keys <- .bibentry_get_key(y)
+    store <- Rd_expr_bibinfo_data_store()
+    for(k in intersect(keys, names(store))) {
+        entry <- store[[k]]
+        for(f in names(entry))
+            y[k, f] <- entry[[f]]
     }
-    y <- sort(unique(bib[bib$key %in% keys]))
-    paste(sprintf("\\if{html}{\u2060\\out{<span id=\"reference+%s\">}}%s\\if{html}{\\out{</span>}}",
-                  string2id(unlist(y$key, use.names = FALSE)),
-                  toRd(y)),
+    Rd_expr_bibinfo_data_store(store[setdiff(names(store), keys)])
+    ## Typically the bibinfo data would give headers or footers, but
+    ## these only get shown when printing bibenties in citation style,
+    ## so we have to add them ourselves.
+    headers <- y[, "header"]
+    headers <- unlist(ifelse(vapply(headers, is.null, NA), "", headers),
+                      use.names = FALSE)
+    if(any(ind <- nzchar(headers)))
+        headers[ind] <- paste(headers[ind], "\\cr")
+    footers <- y[, "footer"]
+    footers <- unlist(ifelse(vapply(footers, is.null, NA), "", footers),
+                      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",
+                  headers,
+                  string2id(.bibentry_get_key(y)),
+                  toRd(y),
+                  footers),
           collapse = "\n\n")
 }
 
@@ -210,33 +233,106 @@ function(x, textual = FALSE)
 {
     x <- trimws(x)
     bib <- R_bibentries()
-    keys <- strsplit(x, ",[[:space:]]*")[[1L]]
-    ## Allow b<k>a to specify before b and after a.
-    ## Could also use
-    ##   regmatches(keys, regexec("(.*<)?(.*)(>.*)?", keys))
-    before <- after <- rep_len("", length(keys))
-    if(any(ind <- grepl("<", keys))) {
-        before[ind] <- sub("<.*", "", keys[ind])
-        keys[ind] <- sub(".*<", "", keys[ind])
+    given <- strsplit(x, ",[[:space:]]*")[[1L]]
+    parts <- strsplit(given, "|", fixed = TRUE)
+    parts <- parts[lengths(parts) %in% c(1L, 3L)]
+    ## Could complain about the others ...?
+    keys <- after <- before <- rep_len("", length(parts))
+    if(any(ind <- (lengths(parts) == 1L))) {
+        keys[ind] <- unlist(parts[ind], use.names = FALSE)
     }
-    if(any(ind <- grepl(">", keys))) {
-        after[ind] <- sub(".*>", "", keys[ind])
-        keys[ind] <- sub(">.*", "", keys[ind])
+    if(any(ind <- (lengths(parts) == 3L))) {
+        keys[ind] <- vapply(parts, `[`, "", 2L)
+        after[ind] <- vapply(parts, `[`, "", 3L)
+        before[ind] <- vapply(parts, `[`, "", 1L)
     }
-    ind <- keys %in% unlist(bib$key)
+    ind <- keys %in% .bibentry_get_key(bib)
     if(!all(ind)) {
-        ## <FIXME>
-        ## Should warn about keys not in the bibentries
-        before <- before[ind]
-        after <- after[ind]
+        ## Could complain about keys not in the bibentries ...?
         keys <- keys[ind]
+        after <- after[ind]
+        before <- before[ind]
+    }
+    n <- length(keys)
+    if(n == 0L)
+        return("")
+    y <- character(n)
+    prev <- Rd_expr_bibcite_keys_cited()
+    if(textual) {
+        for(i in seq_len(n)) {
+            key <- keys[i]
+            y[i] <- utils::citeNatbib(key, bib[key], after = after[i],
+                                      previous = prev, textual = TRUE)
+            prev <- c(prev, key)
+        }
+        if(any(ind <- nzchar(before)))
+            before[ind] <- paste0(before[ind], " ")
+        y <- paste0(before,
+                    sprintf("\\if{html}{\\out{<a href=\"#reference+%s\">}}",
+                            string2id(keys)),
+                    y,
+                    rep_len("\\if{html}{\\out{</a>}}", n),
+                    collapse = "; ")
+    } else {
+        bibp <- c("", "", ";", "a", "",  ",")
+        for(i in seq_len(n)) {
+            key <- keys[i]
+            y[i] <- utils::citeNatbib(key, bib[key],
+                                      previous = prev, textual = FALSE,
+                                      bibpunct = bibp)
+            prev <- c(prev, key)
+        }
+        if(any(ind <- nzchar(before)))
+            before[ind] <- paste0(before[ind], " ")
+        if(any(ind <- nzchar(after)))
+            after[ind] <- paste0(", ", after[ind])
+        y <- paste0("(",
+                    paste0(before,
+                           sprintf("\\if{html}{\\out{<a href=\"#reference+%s\">}}",
+                                   string2id(keys)),
+                           y,
+                           rep_len("\\if{html}{\\out{</a>}}", n),
+                           after,
+                           collapse = ";"),
+                    ")")
     }
     Rd_expr_bibcite_keys_cited(keys, TRUE)
-    ## <FIXME>
-    ## This really needs a vectorized version of cite() ...
-    before <- sprintf("\\if{html}{\\out{<a href=\"#reference+%s\">}}%s",
-                      string2id(keys), before)
-    after <- sprintf("%s\\if{html}{\\out{</a>}}", after)
-    utils::cite(keys, bib, textual, before, after)
+    y
+}
+
+Rd_expr_bibinfo_data_store <- local({
+    .store <- NULL
+    function(new, add = FALSE) {
+        if(!missing(new)) {
+            if(add) {
+                key <- new[[1L]]
+                val <- `names<-`(list(new[[3L]]), new[[2L]])
+                .store[[key]] <<- c(.store[[key]], val)
+            } else
+                .store <<- new
+        }
+        else
+            .store
+    }
+})
+
+Rd_expr_bibinfo <-
+function(key, field, value)
+{
+    Rd_expr_bibinfo_data_store(list(trimws(key),
+                                    trimws(field),
+                                    gsub("\n\n", "\n", trimws(value))),
+                               add = TRUE)
+}
+
+## utils:::.bibentry_get_key
+.bibentry_get_key <-
+function (x) 
+{
+    if(!length(x)) 
+        return(character())
+    keys <- lapply(unclass(x), attr, "key")
+    keys[!lengths(keys)] <- ""
+    unlist(keys, use.names = FALSE)
 }