#' @keywords internal
#' @noRd
AddCite <- function(index, use.hyper = TRUE){
new.ind <- logical(length(index))
if (use.hyper)
new.ind <- !new.ind
names(new.ind) <- index
# .cites$indices <- unique(c(.cites$indices, index))
tmp <- c(.cites$indices, new.ind)
.cites$indices <- tmp[!duplicated(names(tmp))]
}
#' Cite a BibEntry object in text and print all citations
#'
#' The \code{Cite} functions allow for citing a \code{BibEntry} object in text. The
#' \code{PrintBibliography} function allows for printing the bibliography of all
#' the cited entries. The \code{NoCite} function adds references to the bibliography
#' without including a citation. These functions are most useful when used in,
#' e.g., a RMarkdown or RHTML document.
#'
#' @param bib a \code{BibEntry} or \code{bibentry} object
#' @param ... passed to \code{\link{SearchBib}} for indexing into bib. A character
#' vector of keys, for example.
#' @param textual logical; if TRUE, a \dQuote{textual} citation is produced, i.e.
#' what is produced by \\citet in \code{natbib} and \\textcite in \code{BibLaTeX};
#' otherwise, a parenthetical citation as \\citep and \\autocite.
#' @param before string; optional text to display before the citation.
#' @param after string; optional text to display after the citation.
#' @param .opts list; See the relevant section in \code{\link{BibOptions}} for a
#' description of all valid options for these functions.
#' @details See the package vignettes and execute the examples below.
#' @return For the cite functions: a character string containing the citation
#' @rdname Cite
#' @export
#' @aliases PrintBibliography
#' @examples
#' if (requireNamespace("bibtex")) {
#' file <- system.file("Bib", "biblatexExamples.bib", package = "RefManageR")
#' BibOptions(check.entries = FALSE)
#' bib <- ReadBib(file)
#' Citet(bib, 12)
#' NoCite(bib, title = "Alkanethiolate")
#' PrintBibliography(bib, .opts = list(style = "latex",
#' bib.style = "authoryear"))
#' }
#' \dontrun{
#' if (requireNamespace("bibtex")){
#' Citep(bib, c("loh", "geer"), .opts = list(cite.style = "numeric"),
#' before = "see e.g., ")
#' Citet(bib, "loh", .opts = list(cite.style = "numeric", super = TRUE))
#' AutoCite(bib, eprinttype = "arxiv", .opts = list(cite.style = "authoryear"))
#' AutoCite(bib, eprinttype = "arxiv", .opts = list(cite.style = "pandoc"))
#' Citep(bib, author = "kant")
#' ## shorthand field in both entries gets used for numeric and alphabetic labels
#' TextCite(bib, author = "kant", .opts = list(cite.style = "alphabetic"))
#' TextCite(bib, author = "kant", .opts = list(cite.style = "numeric"))
#' TextCite(bib, author = "kant", .opts = list(cite.style = "alphabetic",
#' style = "html"))
#' punct <- unlist(BibOptions("bibpunct"))
#' punct[3:4] <- c("(", ")")
#' TextCite(bib, 33, .opts = list(bibpunct = punct, cite.style = "alphabetic"))
#'
#' BibOptions(restore.defaults = TRUE)
#' }
#' }
#' \dontrun{
#' library(knitr)
#' ## See also TestNumeric.Rmd and TestAlphabetic.Rmd for more examples
#' old.dir <- setwd(tdir <- tempdir())
#' doc <- system.file("Rmd", "TestRmd.Rmd", package = "RefManageR")
#' file.show(doc)
#' tmpfile <- tempfile(fileext = ".html", tmpdir = tdir)
#' knit2html(doc, tmpfile)
#' browseURL(tmpfile)
#'
#' doc <- system.file("Rhtml", "TestAuthorYear.Rhtml", package = "RefManageR")
#' file.show(doc)
#' tmpfile <- tempfile(fileext = ".html", tmpdir = tdir)
#' knit2html(doc, tmpfile)
#' browseURL(tmpfile)
#' setwd(old.dir)
#' unlink(tdir)
#' }
Cite <- function(bib, ..., textual = FALSE, before = NULL, after = NULL,
.opts = list()){
if (length(.opts)){
old.opts <- BibOptions(.opts)
on.exit(BibOptions(old.opts))
}
if (identical(class(bib), "bibentry"))
bib <- as.BibEntry(bib)
with(BibOptions(), {
style <- .BibEntry_match_format_style(style)
papers <- suppressMessages(do.call(`[.BibEntry`, list(x = bib, ...)))
keys <- unlist(papers$key)
if (!length(papers))
return("")
if (cite.style == "pandoc"){
MakePandocCitation(papers, keys, textual, bibpunct, before, after)
}else{
numeric <- "numeric" %in% cite.style
alphabetic <- "alphabetic" %in% cite.style
if (cite.style != .cites$sty)
ClearLabs(cite.style)
n <- length(papers)
cited <- names(.cites$indices)
first <- !(keys %in% cited)
if (cite.style != "numeric"){
if (any(!names(bib) %in% names(.cites$labs))){
## some entries in bib have note been seen before
## note we use bib here instead of papers (the subset) in case
## a possible "duplicate" in bib is cited in the future. want
## to disambiguate. By duplicate, I mean we want to
## distinguish Smith 2008a and Smith 2008b
bibstyle <- switch(cite.style, authortitle = "authoryear",
cite.style)
bib <- sort(bib, sorting = "none", .bibstyle = bibstyle,
return.labs = TRUE)
newinds <- bib$.index
if (is.null(names(newinds))) # key/name missing if bib has length 1 #60
names(newinds) <- names(bib)
.labs <- newinds[keys]
.cites$labs <- c(.cites$labs, newinds)
}else{
## all entries in bib seen before, get label from .cites env.
.labs <- .cites$labs[keys]
}
}else{
first.ind <- if (!length(.cites$labs)) # cite.style has changed,
seq_along(papers) # labs have been reset
else which(first | !keys %in% names(.cites$labs))
if (length(first.ind)){
shorthands <- unlist(papers$shorthand)
max.ind <- suppressWarnings(sum(!is.na(as.numeric(.cites$labs))))
newinds <- seq.int(max.ind+1L, length.out = length(first.ind))
names(newinds) <- keys[first.ind]
if (length(shorthands))
newinds[names(shorthands)] <- shorthands
.cites$labs <- c(.cites$labs, newinds)
}
.labs <- .cites$labs[keys]
}
AddCite(keys, !identical(hyperlink, FALSE))
year <- match(keys, names(.cites$indices))
if (alphabetic || numeric){
year <- structure(.labs, names = NULL)
}else{
year <- structure(unlist(lapply(papers$dateobj,
MakeAuthorYear()$DateFormatter)),
names = NULL)
if (any(.labs %in% letters)) # make sure labels are authoryear labels
year <- paste0(year, .labs)
}
if (textual || (!numeric && !alphabetic)){
auth <- character(n)
authorLists <- lapply(papers, authorList)
lastAuthors <- NULL
for (i in seq_len(n)) {
authors <- authorLists[[i]]
if (length(authors) > max.names && !(first[i] &&
longnamesfirst)){
authors <- authors[seq_len(max.names)]
authors[length(authors)] <- paste0(authors[length(authors)],
" et al.")
}else{
if (length(authors) > 1L)
authors[length(authors)] <- paste("and",
authors[length(authors)])
}
if (length(authors) > 2L)
auth[i] <- paste(authors, collapse = ", ")
else auth[i] <- paste(authors, collapse = " ")
}
# attempt to combine Smith 2008, Smith 2010 into Smith 2008, 2010.
# suppressauth <- which(!nzchar(auth))
# if (length(suppressauth)) {
# for (i in suppressauth) year[i - 1L] <- paste0(year[i -
# 1L], bibpunct[6L], " ", year[i])
# auth <- auth[-suppressauth]
# year <- year[-suppressauth]
# }
}
make.hyper <- !identical(hyperlink, FALSE)
if (textual) {
if (numeric || alphabetic){
result <- paste0(bibpunct[3L], before, year, after, bibpunct[4L])
}else{
result <- paste0(bibpunct[1L], before, year, after, bibpunct[2L])
}
if (super && numeric && (!style %in% c("markdown", "html") ||
!make.hyper))
result <- paste0(auth, "^{", result, "}")
else if (!super || !numeric) result <- paste0(auth, " ", result)
}else if (numeric || alphabetic) {
result <- year
}else {
result <- paste0(auth, bibpunct[6L], " ", year)
}
result <- if (make.hyper)
MakeCiteHyperlink(result, papers, hyperlink, keys,
auth, style, first, numeric,
alphabetic, super, textual,
bibpunct, before, after)
else
AddCitationPunct(result, bibpunct, before, after,
textual, numeric, alphabetic, super)
result
} # end else for if cite.style == "pandoc"
}) # end with for BibOptions
}
#' Convert one element of person object (i.e. a single person)
#' to character for printing citation
#' @noRd
shortName <- function(person){
if (length(person$family))
paste(cleanupLatex(person$family), collapse = " ")
else paste(cleanupLatex(person$given), collapse = " ")
}
#' Convert person object with multiple persons to character
#' @noRd
authorList <- function(paper){
names <- vapply(paper$author, shortName, "")
if (!length(names))
names <- vapply(paper$editor, shortName, "")
if (!length(names))
names <- paper$label
if (!length(names))
names <- vapply(paper$translator, shortName, "")
names
}
#' Print citation in pandoc format
#' @noRd
MakePandocCitation <- function(papers, keys, textual, bibpunct, before, after){
result <- paste0(paste0("@", names(papers)),
collapse = paste0(bibpunct[5L], " "))
result <- paste0(before, result, after)
if (textual)
result <- paste0(bibpunct[3L], result,
bibpunct[4L])
AddCite(keys, FALSE)
result
}
#' Add hyperlink, punctuation, before and after text to citation
#' @noRd
MakeCiteHyperlink <- function(result, papers, hyperlink, keys, auth,
style, first, numeric, alphabetic, super,
textual, bibpunct, before, after){
url <- switch(hyperlink, to.bib = paste0("#bib-",
gsub("[^_a-zA-Z0-9-]", "",
keys,
useBytes = FALSE)),
to.doc = vapply(papers, GetURL, "",
flds = c("url", "eprint", "doi"),
to.bib = TRUE),
hyperlink)
if (style == "html"){
new.links <- if (any(first))
paste(paste("<a id='cite-", gsub("[^_a-zA-Z0-9-]",
"", keys[first],
useBytes = FALSE),
"'></a>", sep = ""), collapse = "")
else ""
result <- if (numeric && super && textual)
paste0(auth, "<sup><a href='", url, "'>", result,
"</a></sup>")
else paste0("<a href='", url, "'>", result, "</a>")
}else if(style == "markdown"){
new.links <- if(any(first))
paste(paste("<a name=cite-",
gsub("[^_a-zA-Z0-9-]", "",
keys[first], useBytes = FALSE),
"></a>", sep = ""), collapse = "")
else ""
result <- if (numeric && super && textual)
paste0(auth, "^[", result, "](", url, ")")
else paste0("[", result, "](", url, ")")
}
result <- AddCitationPunct(result, bibpunct, before, after, textual,
numeric, alphabetic, super)
if (style %in% c("html", "markdown"))
result <- paste0(new.links, result)
result
}
#' Add punctions and before and after text to a citation
#' @noRd
AddCitationPunct <- function(result, bibpunct, before, after, textual,
numeric, alphabetic, super){
result <- paste(result, collapse = paste0(bibpunct[5L], " "))
if (!textual && (numeric || alphabetic)) {
result <- paste0(bibpunct[3L], before, result, after,
bibpunct[4L])
if (super && numeric)
result <- paste0("^{", result, "}")
}else if (!textual){
result <- paste0(bibpunct[1L], before, result, after,
bibpunct[2L])
}
result
}
#' @return PrintBibliography: The formatted list of references.
#' @export
#' @aliases TextCite AutoCite Citep Citet
#' @param start Integer; specifying the index of the first citation to
#' print. Useful for printing long bibliographies on multiple
#' pages/slides.
#' @param end Integer; specifying the index of the last citation to
#' print. Useful for printing long bibliographies on multiple
#' pages/slides.
#' @details If \code{bib.style = "alphabetic"} or \code{bib.style =
#' "numeric"}, then sorting needs to be done at the start of the
#' document prior to using a cite function as sorting is not done
#' by the \code{PrintBibliography} function for those styles (specifying
#' \code{sorting} in \code{.opts} is ignored in this case). If no
#' sorting is done, the references are listed in the order they
#' were cited in for those two styles.
#'
#' If the \code{...} argument to NoCite is identical to \dQuote{*}, then all
#' references in \code{bib} are added to the bibliography without citations.
#' @seealso \code{\link{print.BibEntry}}, \code{\link{BibOptions}},
#' \code{\link[utils]{citeNatbib}}, the package vignettes
#' bib <-
#' @rdname Cite
PrintBibliography <- function(bib, .opts = list(), start = 1, end = length(bib)){
bib <- sort(bib, decreasing = FALSE)
if (!length(bib))
return(bib)
if (identical(class(bib), "bibentry"))
bib <- as.BibEntry(bib)
keys <- unlist(bib$key)
ind <- keys %in% names(.cites$indices)
if (!any(ind)){
message("You haven't cited any references in this bibliography yet.")
return()
}
bibstyle <- if (length(.opts$bib.style))
.opts$bib.style
else .BibOptions$bib.style
citestyle <- if (length(.opts$cite.style))
.opts$cite.style
else .BibOptions$cite.style
style <- if (length(.opts$style))
.opts$style
else .BibOptions$style
bib <- bib[[ind]]
## if bibstyle and citation style match, use citation labels, otherwise
## recompute them
if (bibstyle == citestyle){
if (bibstyle == "numeric"){
if (length(bib) == length(.cites$labs)){
bib <- bib[[names(.cites$labs)]]
.opts$sorting <- "none"
# labs <- .cites$labs
# bib.labs <- labs[order(match(keys, names(labs)))]
# bib <- bib[names(bib.labs)] # sort
bib$.index <- structure(.cites$labs, names = NULL)
}
}else bib$.index <- .cites$labs[keys[ind]]
}
if (length(.opts)){
old.opts <- BibOptions(.opts)
on.exit(BibOptions(old.opts))
}
if (style == "yaml"){
cat("\n---\nnocite:",
sQuote(paste0(paste0("@", names(.cites$indices)), collapse = ", ")))
cat("\n... \n\n")
}
bib <- bib[start:end]
print(bib)
}
#' @export
#' @rdname Cite
Citep <- function(bib, ..., before = NULL, after = NULL,
.opts = list()){
## kall <- match.call()
## kall[[1L]] <- as.name("Cite")
## kall$textual <- FALSE
## eval(kall)
Cite(bib, ..., textual = FALSE, before = before, after = after, .opts=.opts)
}
#' @export
#' @rdname Cite
AutoCite <- function(bib, ..., before = NULL, after = NULL,
.opts = list()){
## kall <- match.call()
## kall[[1L]] <- as.name("Cite")
## kall$textual <- FALSE
## eval(kall)
Cite(bib, ..., textual = FALSE, before = before, after = after, .opts = .opts)
}
#' @export
#' @rdname Cite
Citet <- function(bib, ..., before = NULL, after = NULL,
.opts = list()){
## kall <- match.call()
## kall[[1L]] <- as.name("Cite")
## kall$textual <- TRUE
## eval(kall)
Cite(bib, ..., textual = TRUE, before = before, after = after, .opts = .opts)
}
#' @export
#' @rdname Cite
TextCite <- function(bib, ..., before = NULL, after = NULL,
.opts = list()){
## kall <- match.call()
## kall[[1L]] <- as.name("Cite")
## kall$textual <- TRUE
## eval(kall)
Cite(bib, ..., textual = TRUE, before = before, after = after, .opts = .opts)
}
#' @keywords internal
#' @noRd
ClearLabs <- function(sty){
.cites$labs <- character(0)
.cites$sty <- sty
}
#' @rdname Cite
#' @aliases NoCite
#' @export
#' @keywords print methods
#' @return NoCite: no return value; invoked for its side-effect.
NoCite <- function(bib, ..., .opts = list()){
if (length(.opts)){
old.opts <- BibOptions(.opts)
on.exit(BibOptions(old.opts))
}
if (identical(c(...), "*")){
papers <- bib
}else{
papers <- suppressMessages(do.call(`[.BibEntry`, list(x = bib, ...)))
}
if (!length(papers))
return()
keys <- unlist(papers$key)
if (.BibOptions$cite.style != "numeric"){
if (!all(names(bib) %in% names(.cites$labs))){
## some entries in bib have note been seen before
## note we use bib here instead of papers (the subset) in case
## a possible "duplicate" in bib is cited in the future. we want
## to disambiguate; by duplicate, I mean we want to distinguish
## Smith 2008a and Smith 2008b
bibstyle <- switch(.BibOptions$cite.style, authortitle = "authoryear",
.BibOptions$cite.style)
bib <- sort(bib, sorting = "none", .bibstyle = bibstyle,
return.labs = TRUE)
.cites$labs <- c(.cites$labs, bib$.index)
}
}else{
cited <- names(.cites$indices)
first <- !(keys %in% cited)
first.ind <- which(first)
if (length(first.ind)){
shorthands <- unlist(papers$shorthand)
max.ind <- suppressWarnings(sum(!is.na(as.numeric(.cites$labs))))
newinds <- seq.int(max.ind+1L, length.out = length(first.ind))
names(newinds) <- keys[first]
if (length(shorthands))
newinds[names(shorthands)] <- shorthands
.cites$labs <- c(.cites$labs, newinds)
}
.labs <- .cites$labs[keys]
}
AddCite(keys, !identical(.BibOptions$hyperlink, FALSE))
invisible(NULL)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.