Nothing
## Do not edit this file manually.
## It has been automatically generated from *.org sources.
# TODO: krapka!
.patch_latex <- function(txt){ # print(bibentry,"latex") inserts \bsl macros.
gsub("\\bsl{}", "", txt, fixed=TRUE)
}
## maybe add to package `gbutils'?
##
## if `wd' is a subdirectory of `string' return the path upto and including `string',
## otherwise return NULL.
## If not NULL, it is guaranteed that basename(wd) == string
## NOTE: currently doesn't expand `./', etc..
in_subdirectory <- function(string, wd = getwd()){
if(grepl(string, wd)){
packpat <- paste0(string, "$")
while(!grepl(packpat, wd)){
wd <- dirname(wd)
if(!grepl(string, wd))
return(NULL)
}
if(basename(wd) == string)
wd
else
## the found directory has `string' as a suffix, eg. xxxRdpack, not Rdpack
NULL
}else
NULL
}
get_bibentries <- function(..., package = NULL, bibfile = "REFERENCES.bib",
url_only = FALSE, stop_on_error = TRUE){
if(is.null(package)){
fn <- file.path(..., bibfile)
## check for existence of fn (and length(fn) == 1)? (but see below)
}else{
## first check for development mode in "devtools"
## if the current directory is under `package', first look for the file there
devdir <- in_subdirectory(package)
if(is.null(devdir))
fn <- ""
else{
## if in development dir of `package', get it from there
fn <- file.path(devdir, "inst", ..., bibfile)
if(length(fn) > 1){
warning("More than one file found, using the first one only.")
fn <- fn[1]
}
if(!file.exists(fn))
fn <- ""
}
if(fn == "")
## if the above didn't succeed, try system.file(). In principle, this should work
## also in development mode under devtools, at least for REFERENCES.bib,
## but currently devtools' system.file() doesn't handle it.
fn <- system.file(..., bibfile, package = package)
if(fn == "")
## if the above didn't succeed try system.file() with subdir "inst".
## This is really for the case when system.file() is the one from devtools,
## see the note above. TODO: check if this is the case?
fn <- system.file("inst", ..., bibfile, package = package)
## 2020-09-27 removing this functionality since package 'bibtex' ca no longer be
## relied upon and was dropped from the dependencies.
##
## if(length(fn) == 1 && fn == "")
## ## if system.file() didn't find the bib file, check if file package.bib is
## ## provided by package "bibtex" (it is for core R packages, such as "base")
## fn <- system.file("bib", sprintf("%s.bib", package), package = "bibtex")
}
if(length(fn) > 1){
warning("More than one file found, using the first one only.")
fn <- fn[1]
}else if(length(fn) == 1 && fn == ""){
msg <- paste0("Couldn't find file ", file.path(..., bibfile),
if(!is.null(package)) paste0(" in package `", package, "'"))
if(stop_on_error)
stop(msg)
else{
warning(msg)
## return an empty bibentryRd object
res <- bibentry()
class(res) <- c("bibentryRd", class(res))
return(res)
}
}
## 2018-10-03
## use package's encoding if specified.
## TODO: maybe this function should have argument 'encoding'
## TODO: in principle the Rd file may have its own encoding,
## but my current understanding is that parse_Rd() first converts it to UTF-8.
## BUT what is the encoding of the strings in the object returned by read.bib?
encoding <- if(!is.null(package) && !is.null(utils::packageDescription(package)$Encoding))
utils::packageDescription(package)$Encoding
else
"UTF-8"
## 2020-09-22 switching to 'rbibutils
## res <- read.bib(file = fn, encoding = encoding)
## current: res <- readBib(file = fn, encoding = encoding)
## test:
res <- if(packageVersion("rbibutils") > '2.2.4')
## issue #7 in rbibutils
readBib(file = fn, encoding = encoding, direct = TRUE, texChars = "Rdpack")
else if(packageVersion("rbibutils") >= '2.1.2')
readBib(file = fn, encoding = encoding, direct = TRUE)
else
readBib(file = fn, encoding = encoding)
# 2018-03-10 commenting out
# since bibtex v. >= 0.4.0 has been required for a long time in DESCRIPTION
#
# ## 2016-07-26 Now do this only for versions of bibtex < '0.4.0'.
# ## From bibtex '0.4.0' read.bib() sets the names.
# if(packageVersion("bibtex") < '0.4.0'){
# names(res) <- sapply(1:length(res), function(x) bibentry_key(res[[x]][[1]]))
# }
## 2020-10-02 commenting out since taken care (hopefully) by readBib
##
# for(nam in names(res)){
# ## unconditionaly recode %'s in filed URL
# if(!is.null(res[nam]$url)) {
# res[nam]$url <- gsub("([^\\])%", "\\1\\\\%", res[nam]$url)
# }
#
# if(url_only){ # process also other fields
# ## TODO: currently all unescaped %'s in all fields are recoded;
# ## Maybe do it more selectively, e.g. only for %'s inside \url{},
# ## or matching something like http(s)://
# fields <- names(unclass(res[nam])[[1]])
#
# unclassed <- unclass(res[nam])
# flag <- FALSE
# for(field in fields){
# wrk <- unclass(res[nam])[[1]][[field]]
# if(is.character(wrk) && any(grepl("([^\\])%", wrk))){
# flag <- TRUE
# unclassed[[1]][[field]] <- gsub("([^\\])%", "\\1\\\\%", wrk)
# }
# }
# if(flag){
# class(unclassed) <- class(res[nam])
# res[nam] <- unclassed
# }
# }
# }
## new 2020-10-02 - allow \% in url's and doi's in the bib file
for(nam in names(res)){ # print(res[nam], style = "R")
## unconditionaly recode %'s in filed URL
if(!is.null(res[nam]$doi)) {
res[nam]$doi <- gsub("([^\\\\])[\\\\]%", "\\1%", res[nam]$doi)
}
if(!is.null(res[nam]$url)) {
res[nam]$url <- gsub("([^\\\\])[\\\\]%", "\\1%", res[nam]$url)
}
# if(url_only){ # process also other fields
# ## TODO: currently all unescaped %'s in all fields are recoded;
# ## Maybe do it more selectively, e.g. only for %'s inside \url{},
# ## or matching something like http(s)://
# fields <- names(unclass(res[nam])[[1]])
#
# unclassed <- unclass(res[nam])
# flag <- FALSE
# for(field in fields){
# wrk <- unclass(res[nam])[[1]][[field]]
# if(is.character(wrk) && any(grepl("([^\\])%", wrk))){
# flag <- TRUE
# unclassed[[1]][[field]] <- gsub("([^\\])%", "\\1\\\\%", wrk)
# }
# }
# if(flag){
# class(unclassed) <- class(res[nam])
# res[nam] <- unclassed
# }
# }
}
## 2018-03-03 new:
class(res) <- c("bibentryRd", class(res))
res
}
print.bibentryRd <- function (x, style = "text", ...){
class(x) <- class(x)[-1]
## TODO: It would be better to modify the entries and then call
## print(), rather than vice versa as now.
res <- capture.output(print(x, style = style, ...))
res <- switch(tolower(style),
r = gsub("\\\\\\\\%", "%", res),
citation = ,
bibtex = gsub("\\\\%", "%", res),
res
)
cat(res, sep = "\n")
}
rebib <- function(infile, outfile, ...){ # 2013-03-29
rdo <- permissive_parse_Rd(infile) ## 2017-11-25 TODO: argument for RdMacros!
if(missing(outfile))
outfile <- basename(infile)
else if(identical(outfile, "")) # 2013-10-23 else clause is new
outfile <- infile
rdo <- inspect_Rdbib(rdo, ...)
Rdo2Rdf(rdo, file=outfile, srcfile=infile)
rdo
}
inspect_Rdbib <- function(rdo, force = FALSE, ...){ # 2013-03-29
# 2013-12-08 was: pos <- Rdo_locate_predefined_section(rdo, "\\references")
pos <- Rdo_which_tag_eq(rdo, "\\references")
if(length(pos) > 1)
stop(paste("Found", length(pos), "sections `references'.\n",
"There should be only one."
))
else if(length(pos) == 0) # no section "references".
return(rdo)
bibs <- get_bibentries(...)
fkey <- function(x){
m <- gregexpr("[ ]+", x)
rm <- regmatches(x, m, invert = TRUE)[[1]]
if(length(rm) >= 2 && rm[2] != "bibentry:")
rm[2] # e.g. bibentry:all
else if(length(rm) < 3) # % bibentry: xxx_key_xxx
"" # NA_character_
else
rm[3]
}
fbib <- function(x) grepl("[ ]+bibentry:", x)
posbibs <- Rdo_locate(rdo[[pos]], f = fbib, pos_only = fkey)
poskeys <- sapply(posbibs, function(x) x$value)
print(posbibs)
fendkey <- function(x){
m <- gregexpr("[ ]+", x)
rm <- regmatches(x, m, invert = TRUE)[[1]]
if(length(rm) >= 2 && rm[2] != "end:bibentry:")
rm[2] # e.g. end:bibentry:all
else if(length(rm) < 3) # % end:bibentry: xxx_key_xxx
"" # NA_character_
else
rm[3]
}
fendbib <- function(x) grepl("end:bibentry:", x)
posendbibs <- Rdo_locate(rdo[[pos]], f = fendbib, pos_only = fendkey)
posendkeys <- sapply(posendbibs, function(x) x$value)
toomit <- which(poskeys %in% posendkeys) # note: en@bibkeys:all is different! todo:
if(length(toomit) > 0 && !force){
poskeys <- poskeys[-toomit]
posbibs <- posbibs[-toomit]
}
if(length(poskeys)==0)
"nothing to do."
else if(any(poskeys == "bibentry:all")){
poskey <- posbibs[[ which(poskeys == "bibentry:all") ]]$pos
## 2021-04-29 TODO: the following line(s) needs to be replaced with
## .toRd_styled(bibs[poskeys[i], ???)
## For testing use REFERENCES.bib in rbibutils
## (the doi's are currently rendered horribly)
## DONE! was:
# bibstxt <- capture.output(print(bibs, "latex"))
#
# bibstxt <- .patch_latex(bibstxt) # TODO: krapka!
## TODO: the bibstyles used beloww should probably be arguments
bibs <- sort(bibs, .bibstyle = "JSSRd")
bibstxt <- .toRd_styled(bibs, "Rdpack")
# bibstxt <- paste0(bibstxt, collapse = "\\cr\\cr ")
bibstxt <- paste0(bibstxt, collapse = "\n\n ")
bibstxt <- paste(c("", bibstxt), "\n", sep="")
endbibline <- Rdo_comment("% end:bibentry:all")
keyflag <- "end:bibentry:all" %in% posendkeys
if(keyflag && force){ #todo: more careful!
endposkey <- posendbibs[[ which(posendkeys == "end:bibentry:all") ]]$pos
rdo[[pos]] <- Rdo_flatremove(rdo[[pos]], poskey+1, endposkey)
}
if(!keyflag || force){
rdo[[pos]] <- Rdo_flatinsert(rdo[[pos]], list(endbibline), poskey,
before = FALSE)
rdo[[pos]] <- Rdo_flatinsert(rdo[[pos]], bibstxt, poskey,
before = FALSE)
}
}else{
for(i in length(poskeys):1){
bibkey <- posbibs[[i]]$value
poskey <- posbibs[[i]]$pos
## 2021-04-29 TODO: the following line(s) needs to be replaced with
## .toRd_styled(bibs[poskeys[i], ???)
## For testing use REFERENCES.bib in rbibutils
## (the doi's are currently rendered horribly)
## DONE! was:
# bibstxt <- capture.output(print(bibs[poskeys[i]],"latex"))
#
# bibstxt <- .patch_latex(bibstxt) # TODO: krapka!
bibstxt <- .toRd_styled(bibs[poskeys[i]], "Rdpack")
bibstxt <- list( paste( c("", bibstxt), "\n", sep="") )
endbibline <- Rdo_comment(paste("% end:bibentry: ", bibkey))
keyflag <- bibkey %in% posendkeys
if(keyflag && force){ #todo: more careful!
endposkey <- posendbibs[[ which(posendkeys == bibkey) ]]$pos
rdo[[pos]] <- Rdo_flatremove(rdo[[pos]], poskey+1, endposkey)
}
if(!keyflag || force){ # this is always TRUE here but is left for common look
# with "all". todo: needs consolidation
rdo[[pos]] <- Rdo_flatinsert(rdo[[pos]], list(endbibline), poskey,
before = FALSE)
rdo[[pos]] <- Rdo_flatinsert(rdo[[pos]], bibstxt, poskey,
before = FALSE)
}
}
}
rdo
}
Rdo_flatremove <- function(rdo, from, to){ # 2013-03-30 todo: more careful!
res <- rdo[-(from:to)]
attributes(res) <- attributes(rdo) # todo: more guarded copying of attributes?
res
}
# todo: move to another file later
Rdo_flatinsert <- function(rdo, val, pos, before = TRUE){ # 2013-03-29
depth <- length(pos)
if(depth > 1){
rdo[[pos]] <- Recall(rdo[[ pos[-depth] ]], val, pos[-depth])
# todo: dali zapazva attributite na rdo?
return(rdo)
}
n <- length(rdo)
if(!before)
pos <- pos + 1
res <- if(pos==1) c(val, rdo)
else if(pos==n+1) c(rdo, val)
else c( rdo[1:(pos-1)], val, rdo[pos:n])
attributes(res) <- attributes(rdo) # todo: more guarded copying of attributes?
res
}
## 2020-11-01: use local()
.bibs_cache <- local({
## initialise the cache
## TODO: remove refsmat, it is not needed here, maybe
refsmat <- matrix(character(0), nrow = 0, ncol = 2)
allbibs <- list()
## TODO: time stamp for auto clearing
.get_bibs0 <- function(package, ..., cached_env) {
if(is.null(package))
stop("argument 'package' must be provided")
bibs <- allbibs[[package]]
if(is.null(bibs)){
## message(" bibs is NULL")
bibs <- get_bibentries(package = package, ..., stop_on_error = FALSE)
allbibs[[package]] <<- bibs
} ## else
## message(" bibs is nonNULL")
bibs
}
.get_all_bibs <- function()
allbibs
list(.get_bibs0 = .get_bibs0, .get_all_bibs = .get_all_bibs)
})
## TODO: auto-deduce 'package'?
## 2020-09-30: changing to cache bib as \insertCite does (new arg. cached_env, etc)
insert_ref <- function(key, package = NULL, ..., cached_env = NULL) {
# 2020-09-30: replaced by a single call
# if(is.null(package))
# stop("argument 'package' must be provided")
#
# bibs <- get_bibentries(package = package, ..., stop_on_error = FALSE)
#
# TODO: this is for testing only!
# message("\nkey is ", key)
# if(is.null(cached_env))
# message(" cached_env is NULL")
# else
# message(" cached_env is nonNULL")
bibs <- .bibs_cache$.get_bibs0(package, ..., cached_env = cached_env)
if(length(bibs) == 0){
note <- paste0("\"Failed to insert reference with key = ", key,
" from package = '", package, "'.",
" Possible cause --- missing REFERENCES.bib in package '",
package, "' or '", package, "' not installed.\""
)
note <- paste0("\\Sexpr[results=rd,stage=install]{{warning(", note, ");", note, "}} ")
item <- bibentry(
bibtype = "Misc",
title = "Not avalable",
author = person("A", "Adummy"),
year = format(Sys.time(), "%Y"),
note = note,
key = key
)
.toRd_styled(item, package)
}else if(length(key) == 1){
item <- tryCatch(bibs[[key]],
warning = function(c) {
if(grepl("subscript out of bounds", c$message)){
## tell the user the offending key.
s <- paste0("possibly non-existing key '", key, "'")
c$message <- paste0(c$message, " (", s, ")")
}
warning(c)
# res <- paste0("\nWARNING: failed to insert reference '", key,
# "' from package '", package, "' - ",
# s, ".\n")
# return(res)
## setup a dummy entry
bibentry(
bibtype = "Misc",
title = "Not avalable",
author = person("A", "Adummy"),
year = format(Sys.time(), "%Y"),
note = paste0("Failed to insert reference with key = ", key,
" from package = '", package, "'.",
" Possible cause --- missing or misspelled key."
),
key = key
)
},
## 2024-08-04
## R-devel c86938 recently changed the warning to error,
## for now, copying verbatim the function for handling the warning.
error = function(c) {
if(grepl("subscript out of bounds", c$message)){
## tell the user the offending key.
s <- paste0("possibly non-existing key '", key, "'")
c$message <- paste0(c$message, " (", s, ")")
}
warning(c)
# res <- paste0("\nWARNING: failed to insert reference '", key,
# "' from package '", package, "' - ",
# s, ".\n")
# return(res)
## setup a dummy entry
bibentry(
bibtype = "Misc",
title = "Not avalable",
author = person("A", "Adummy"),
year = format(Sys.time(), "%Y"),
note = paste0("Failed to insert reference with key = ", key,
" from package = '", package, "'.",
" Possible cause --- missing or misspelled key."
),
key = key
)
}
)
# # 2018-03-01 Bug: Unexpected END_OF_INPUT error (URL parsing?) #3
# # I don't know why toRd() doesn't do this...
# #
# # escape percents that are not preceded by backslash
# # (`if' is because in case of error above, item will be simply a string)
#
# Commenting out since get_bibentries() does it.
# if(inherits(item, "bibentry") && !is.null(item$url))
# item$url <- gsub("([^\\])%", "\\1\\\\%", item$url)
# if(interactive()) browser()
# wrk <- .toRd_styled(item, package) # TODO: add styles? (doesn't seem feasible here)
# fn <- tempfile()
# cat(wrk, file = fn)
# res <- permissive_parse_Rd(fn) ## tools::parse_Rd(fn)
# tools::toRd(res)
#
# wrk <- .toRd_styled(item, package)
# Encoding(wrk) <- "bytes"
# wrk
#
.toRd_styled(item, package)
}else{
## key is documented to be of length one, nevertheless handle it too
kiki <- FALSE
items <- withCallingHandlers(bibs[[key]], warning = function(w) {kiki <<- TRUE})
## TODO: deal with URL's as above
txt <- .toRd_styled(items, package)
if(kiki){ # warning(s) in bibs[[key]]
s <- paste0("WARNING: failed to insert ",
"one or more of the following keys in REFERENCES.bib:\n",
paste(key, collapse = ", \n"), ".")
warning(s)
txt <- c(txt, s)
}
paste0(paste(txt, collapse = "\n\n"), "\n")
}
}
## 2017-11-25 new
## see utils:::print.help_files_with_topic()
viewRd <- function(infile, type = getOption("help_type"), stages = NULL){
infile <- normalizePath(infile)
if(is.null(type))
type <- "text"
else if(!is.character(type) || length(type) != 1)
stop("'type' should be 'html' or 'text'")
if(is.null(stages))
# stages <- c("install", "render")
stages <- c("build", "install", "render")
# stages <- c("build", "render")
else if(!is.character(stages) || !all(stages %in% c("build", "install", "render")))
stop('stages must be a character vector containing one or more of the strings "build", "install", and "render"')
pkgname <- basename(dirname(dirname(infile)))
outfile <- tempfile(fileext = paste0(".", type))
## 2020-05-19: added pkgdir to read also current package macros, see below
pkgdir <- dirname(dirname(infile))
## here we need to expand the Rd macros, so don't use permissive_parse_Rd()
## 2020-05-19: read also the macros from pkgdir,
## load those from Rdpack anyway, in case Rdpack is not in 'DESCRIPTION' yet
## TODO: could issue warning here but this could be intrusive here since
## the user may not need Rdpack for the current package.
e <- tools::loadPkgRdMacros(system.file(package = "Rdpack"))
e <- tools::loadPkgRdMacros(pkgdir, macros = e)
## finally load the Rd system macros (though I haven't noticed errors without this step).
e <- tools::loadRdMacros(file.path(R.home("share"), "Rd", "macros", "system.Rd"),
macros = e)
## check if mathjaxr is needed
descpath <- file.path(pkgdir, "DESCRIPTION")
need_mathjaxr <-
if(file.exists(descpath)){
## rdmac is NA if there is no RDMacros field in DESCRIPTION
rdmac <- as.character(read.dcf(descpath, fields = "RdMacros"))
grepl("mathjaxr", as.character(rdmac))
}else{
## try installed package
pkgdesc <- packageDescription(pkgname)
!is.null(pkgdesc$RdMacros) && grepl("mathjaxr",pkgdesc$RdMacros)
}
## this loads mathjax from CDN, so internet connection needed
if(need_mathjaxr){
## code borrowed from package "mathjaxr"
mjcdn <- Sys.getenv("MATHJAXR_USECDN")
on.exit(Sys.setenv(MATHJAXR_USECDN = mjcdn))
Sys.setenv(MATHJAXR_USECDN = "TRUE")
}
## Rdo <- parse_Rd(infile, macros = e)
## can't do this (the file may be deleted before the browser opens it):
## on.exit(unlink(outfile))
switch(type,
text = {
temp <- tools::Rd2txt(infile, # was: Rdo,
out = outfile, package = pkgname, stages = stages
, macros = e)
file.show(temp, delete.file = TRUE) # text file is deleted
},
html = {
temp <- tools::Rd2HTML(infile, # was: Rdo,
out = outfile, package = pkgname,
stages = stages
, macros = e)
browseURL(temp)
## html file is not deleted
},
stop("'type' should be one of 'text' or 'html'")
)
}
## temporary; not exported
vigbib <- function(package, verbose = TRUE, ..., vig = NULL){
if(!is.null(vig))
return(makeVignetteReference(package, vig, ...))
vigs <- vignette(package = package)
if(nrow(vigs$results) == 0){
if(verbose)
cat("No vignettes found in package ", package, "\n")
return(bibentry())
}
wrk <- lapply(seq_len(nrow(vigs$results)),
function(x) makeVignetteReference(package = package, vig = x,
verbose = FALSE, ...)
)
res <- do.call("c", wrk)
if(verbose)
print(res, style = "Bibtex")
invisible(res)
}
makeVignetteReference <- function(package, vig = 1, verbose = TRUE,
title, author, type = "pdf",
bibtype = "Article", key = NULL
){
publisher <- NULL # todo: turn this into an argument some day ...
if(missing(package))
stop("argument 'package' is missing with no default")
cranname <- "CRAN"
cran <- "https://CRAN.R-Project.org"
cranpack <- paste0(cran, "/package=", package)
## todo: for now only cran
if(is.null(publisher)){
publisher <- cran
publishername <- cranname
publisherpack <- cranpack
}
desc <- packageDescription(package)
vigs <- vignette(package = package)
if(is.character(vig)){
vig <- pmatch(vig, vigs$results[ , "Item"])
if(length(vig) == 1 && !is.na(vig)){
wrk <- vigs$results[vig, "Title"]
}else
stop(paste0(
"'vig' must (partially) match one of:\n",
paste0("\t", 1:nrow(vigs$results), " ", vigs$results[ , "Item"], "\n",
collapse = "\n"),
"Alternatively, 'vig' can be the index printed in front of the name above."))
}else if(1 <= vig && vig <= nrow(vigs$results)){
wrk <- vigs$results[vig, "Title"]
}else{
stop("not ready yet, should return all vigs in the package.")
}
if(missing(author))
author <- desc$Author
title <- gsub(" \\([^)]*\\)$", "", wrk) # drop ' (source, pdf)'
item <- vigs$results[vig, "Item"]
vigfile <- paste0(item, ".", type)
journal <- paste0("URL ", publisherpack, ".",
" Vignette included in R package ", package,
", version ", desc$Version
)
if(is.null(desc$Date)){ # built-in packages do not have field "year"
if(grepl("^Part of R", desc$License[1])){
## title <- paste0(title, "(", desc$License, ")")
publisherpack <- cran ## do not add package=... to https in this case
journal <- paste0("URL ", publisherpack, ".",
" Vignette included in R package ", package,
" (", desc$License, ")"
)
}
year <- R.version$year
}else
year <- substring(desc$Date, 1, 4)
# stop(paste0("argument 'vig' must be a charater string or an integer\n",
# "between 1 and the number of vignettes in the package"))
if(is.null(key))
key <- paste0("vig", package, ":", vigs$results[vig, "Item"])
res <- bibentry(
key = key,
bibtype = bibtype,
title = title,
author = author,
journal = journal,
year = year,
## note = "R package version 1.3-4",
publisher = publishername,
url = publisherpack
)
if(verbose){
print(res, style = "Bibtex")
cat("\n")
}
res
}
## 2018-03-13 new
## 2023-08-19 TODO: this function was patched and its functionality extended via patches so
## many times that it needs consolidation.
insert_citeOnly <- function(keys, package = NULL, before = NULL, after = NULL,
bibpunct = NULL, ...,
cached_env = NULL, cite_only = FALSE, dont_cite = FALSE) {
if(!is.null(cached_env)){
if(is.null(cached_env$refsmat))
cached_env$refsmat <- matrix(character(0), nrow = 0, ncol = 2)
## if(is.null(cached_env$allbibs))
## cached_env$allbibs <- list()
}
if(is.null(package))
stop("argument 'package' must be provided")
if(length(keys) > 1)
stop("`keys' must be a character string")
if(!cite_only)
cached_env$refsmat <- rbind(cached_env$refsmat, c(keys, package))
if(dont_cite)
return(character(0))
nobrackets <- grepl(";nobrackets$", keys) # new 2022-02-05; related to issue #23
if(nobrackets)
keys <- gsub(";nobrackets$", "", keys)
textual <- grepl(";textual$", keys)
if(textual)
keys <- gsub(";textual$", "", keys)
if(grepl("[^a-zA-Z.0-9]", package)){
delims <- gsub("[a-zA-Z.0-9]", "", package)
ch <- substr(delims, 1, 1)
wrk <- strsplit(package, ch, fixed = TRUE)[[1]] # note: [[1]]
package <- wrk[1]
if(length(wrk) > 1){
if(nchar(wrk[2]) > 1 || nchar(wrk[2]) == 1 && wrk[2] != " ")
before <- wrk[2]
if(length(wrk) > 2 && (nchar(wrk[3]) > 1 || nchar(wrk[3]) == 1 && wrk[3] != " "))
after <- wrk[3]
}
}
# 2020-11-05 was:
#
# if(is.null(cached_env)){
# bibs <- get_bibentries(package = package, ..., stop_on_error = FALSE)
# }else{
# bibs <- cached_env$allbibs[[package]]
# if(is.null(bibs)){
# bibs <- get_bibentries(package = package, ..., stop_on_error = FALSE)
# cached_env$allbibs[[package]] <- bibs
# }
# }
#
bibs <- .bibs_cache$.get_bibs0(package, ..., cached_env = cached_env)
# This wouldn't work since roxygen2 will change it to citation
# TODO: check
# if(substr(keys, 1, 1) == "["){ # rmarkdown syntax (actually roxygen2?)
# keys <- substr(keys, 2, nchar(keys) - 1) # drop "[" and the closing "]"
# splitkeys <- strsplit(keys, ";", fixed = TRUE)[[1]] # note: [[1]]
#
#
#
# }
refch <- "@"
refchpat <- paste0("^[", refch, "]")
if(grepl(refchpat, keys)){
ch <- substr(keys, 1, 1) # 'ch' is not used currently
keys <- substr(keys, 2, nchar(keys)) # drop refch
## TODO: check if there are still @'s at this point
refpat <- paste0("(", refch, "[^;,()[:space:]]+)") # "(@[^;,[:space:]]+)"
refpat2 <- paste0( refch, "[^;,()[:space:]]+\\)")
if(textual){
wrkkeys <- strsplit(keys, "@")[[1]] # note [[1]] !!!
## 2023-08-19 Note:
##
## The code until the assignment to 'keys' puts a ')' at the end of each key.
## presumably to designate the end of the key for gregexpr below. But these ')'
## need to be removed later.
##
## first process the last key - it is special, since there is none after it
nk <- length(wrkkeys)
wrkkeys[nk] <- if(grepl("[;,]$", wrkkeys[nk]))
sub("([;,])$", ")\\1", wrkkeys[nk])
else if(grepl("[;,]", wrkkeys[nk]))
sub("([;,][^;,]*)$", ")\\1" , wrkkeys[nk])
else
paste0(wrkkeys[nk], ")")
## the 2nd element contains the first key even if the string starts with '@'
## (if that is the case the first string is "")
if(nk > 2){
for(i in 2:(nk - 1)){
wrkkeys[i] <- if(grepl("([;,][^;,]*)$", wrkkeys[i]))
sub("([;,][^;,]*)$", ")\\1" , wrkkeys[i])
else
sub("^([^;,()[:space:]]+)", "\\1)" , wrkkeys[i])
}
}
keys <- paste0(wrkkeys, collapse = refch)
}
## find the positions of the keys (used further below to replace them with the cites
m <- gregexpr(refpat, keys)
allkeys <- regmatches(keys, m)[[1]] # note: [[1]]
allkeys <- gsub(refch, "", allkeys)
if(textual){
bibpunct0 = c("(", ")", ";", "a", "", ",")
if(!is.null(bibpunct)){
if(length(bibpunct) < length(bibpunct0))
bibpunct <- c(bibpunct, bibpunct0[-seq_len(length(bibpunct))])
ind <- which(is.na(bibpunct))
if(length(ind) > 0)
bibpunct[ind] <- bibpunct0[ind]
#cat("bibpunct is: ", bibpunct, "\n")
}else
bibpunct <- bibpunct0
}else{
## for now ignore bibpunct in this case
bibpunct <- c("", "", ";", "a", "", ",")
}
refs <- sapply(allkeys,
function(key)
safe_cite(key, bibs, textual = textual, bibpunct = bibpunct,
from.package = package)
)
if(textual){
## 2023-08-19 Note: need to drop the ')' added above. The commented out solution
## below drop the last symbol in the prepared cites instead, which is
## equivalent but only if bibpunct is missing or specifies ')' as closing for
## the likes of Boshnakov (2020). The new solution matches again with a
## pattern including the ')' at the end of the key, so that ')' gets replaced
## along with the key.
## was: refs <- sapply(refs, function(s) substr(s, 1, nchar(s) - 1))
m <- gregexpr(refpat2, keys)
}
## replace keys with citations
text <- keys
regmatches(text, m) <- list(refs)
## parentheses around the whole cite; 2022-02-05: also if !nobrackets
if(!textual && !nobrackets) # 2018-03-28 don't put parentheses in textual mode
text <- paste0("(", text, ")")
}else{
if(is.null(bibpunct)){
if(!textual && nobrackets) # 2022-02-05
bibpunct0 = c("", "", ";", "a", "", ",")
else
bibpunct0 = c("(", ")", ";", "a", "", ",")
text <- safe_cite(keys, bibs, textual = textual, before = before, after = after,
bibpunct = bibpunct0, from.package = package)
}else{
bibpunct0 = c("(", ")", ";", "a", "", ",")
if(length(bibpunct) < length(bibpunct0))
bibpunct <- c(bibpunct, bibpunct0[-seq_len(length(bibpunct))])
ind <- which(is.na(bibpunct))
if(length(ind) > 0)
bibpunct[ind] <- bibpunct0[ind]
text <- safe_cite(keys, bibs, textual = textual, before = before, after = after,
bibpunct = bibpunct, from.package = package)
}
}
## 2022-06-05: was: toRd(text)
## workaround for issue #25; effectively assumes that citation text
## doesn't contain braces that need escaping
.toRd_cite(text)
}
## modified tools:::toRd.default
.toRd_cite <- function (obj, ...) {
fsub <- function(from, to, x)
gsub(from, to, x, fixed = TRUE)
fsub("%", "\\%",
# fsub("}", "\\}",
# fsub("{", "\\{",
fsub("\\", "\\\\", as.character(obj))) # ))
}
safe_cite <- function(keys, bib, ..., from.package = NULL){
wrk.keys <- unlist(strsplit(keys, ","))
if(!all(wrk.keys %in% names(bib))){
ok <- wrk.keys %in% names(bib)
miss.keys <- wrk.keys[!ok]
warning("possibly non-existing or duplicated key(s)",
if(!is.null(from.package))
paste0(" in bib file from package '", from.package, "'"),
":\n ", paste(miss.keys, sep = ", "), "\n")
keys <- wrk.keys[ok]
}
# 2018-06-02 was: cite(keys = keys, bib = bib, ...)
cite(keys = keys, bib = bib, longnamesfirst = FALSE, ...)
}
insert_all_ref <- function(refs, style = "", empty_cited = FALSE){
if(is.environment(refs)){
refsmat <- refs$refsmat
allbibs <- .bibs_cache$.get_all_bibs() # 2020-11-05 was: refs$allbibs
if(is.null(allbibs)) ## TODO: this can be removed, since .get_all_bibs()
allbibs <- list() ## returns an initialised list()
}else{
refsmat <- refs
allbibs <- list()
}
if(is.null(refs) || is.null(refsmat) || nrow(refsmat) == 0)
## Returning the empty string is probably preferable but 'R CMD check' does not see
## that the references are empty in this case (although the help system see this and
## drops the section "references". To avoid confusing the user, print some
## informative text.
return("There are no references for Rd macro \\verb{\\insertAllCites} on this help page.")
all.keys <- list()
for(i in 1:nrow(refsmat)){
keys <- refsmat[i, 1]
nobrackets <- grepl(";nobrackets$", keys) # new 2022-02-05; related to issue #23
if(nobrackets)
keys <- gsub(";nobrackets$", "", keys)
textual <- grepl(";textual$", keys)
if(any(textual))
keys <- gsub(";textual", "", keys)
refch <- "@"
refchpat <- paste0("^[", refch, "]")
if(grepl(refchpat, keys)){
ch <- substr(keys, 1, 1)
keys <- substr(keys, 2, nchar(keys)) # drop refch
refpat <- paste0("(", refch, "[^;,[:space:]]+)") # "(@[^;,[:space:]]+)"
m <- gregexpr(refpat, keys)
keys <- regmatches(keys, m)[[1]] # note: [[1]]
keys <- gsub("@", "", keys)
}else{
keys <- unlist(strsplit(keys, ","))
}
package <- refsmat[i, 2]
if(is.null(all.keys[[package]]))
all.keys[[package]] <- keys
else
all.keys[[package]] <- c(all.keys[[package]], keys)
}
bibs <- NULL
for(package in names(all.keys)){
cur <- unique(all.keys[[package]])
be <- allbibs[[package]]
if(is.null(be))
be <- get_bibentries(package = package, stop_on_error = FALSE)
if(length(be) == 0){
be <- bibentry(
bibtype = "Misc",
title = "Not avalable",
author = person("A", "Adummy"),
year = format(Sys.time(), "%Y"),
note = paste0("Failed to insert reference with keys = \n ",
paste0(cur, collapse = " "), "\n",
"from package = '", package, "'.",
" Possible cause --- missing REFERENCES.bib in package '",
package, "' or '", package, "' not installed."
),
key = paste0(cur, collapse = ":")
)
}else if(all(cur != "*")){
be <- tryCatch(
be[cur],
warning = function(c) {
if(grepl("subscript out of bounds", c$message)){
## tell the user the offending keys.
c$message <- paste0(c$message, " (",
paste(cur, collapse = " "),
"' from package '", package, "'", ")"
)
}
warning(c)
## setup a dummy entry
dummy <- bibentry(
bibtype = "Misc",
title = paste0("Some keys from package ", package,
" are not avalable"),
author = person("A", "Adummy"),
year = format(Sys.time(), "%Y"),
note = paste0("Failed to insert reference with keys:\n ",
paste0(cur, collapse = ", "), "\n",
"from package = '", package, "'.",
" Possible cause - missing REFERENCES.bib in package '",
package, "' or '", package, "' not installed."
),
key = paste0(cur, collapse = ":")
)
c(be[cur], dummy)
})
}
if(is.null(bibs))
bibs <- be
else
bibs <- c(bibs, be) # TODO: duplicate keys in different packages?
}
bibs <- sort(bibs, .bibstyle = "JSSRd") # 2021-04-24 was: sort(bibs)
pkgs <- names(all.keys)
# \Sexpr[stage=build,results=hide]{requireNamespace("cvar")}
# 2016-06-02 was:
# if(length(pkgs) > 0){
# pkg <- pkgs[1] ## TODO: for now should do
# if(!isNamespaceLoaded(pkg) && !requireNamespace(pkg) )
# sty <- NULL
# else{
# sty <- Rdpack_bibstyles(pkg)
# }
# }else
# sty <- NULL
#
# if(!is.null(sty))
# res <- sapply(bibs, function(x) tools::toRd(x, style = "JSSLongNames"))
# else {
# if(style == "")
# res <- sapply(bibs, function(x) tools::toRd(x))
# else{
# res <- sapply(bibs, function(x) tools::toRd(x, style = "JSSLongNames"))
# }
# }
pkg <- if(length(pkgs) > 0) ## TODO: for now should do
pkgs[1]
else character(0)
res <- .toRd_styled(bibs, pkg)
# 2018-10-01 use \par since pkgdown ignores the empty lines
# TODO: needs further thought
# was:
# (for now restoring the old one, to check if pkgdown would consider this as a bug)
if(empty_cited)
refs$refsmat <- matrix(character(0), nrow = 0, ncol = 2)
# paste0(res, collapse = "\n\n")
paste0(res, collapse = "\\cr\\cr ")
}
## deparseLatexToRd <- function(x, dropBraces = FALSE)
## {
## result <- character()
## lastTag <- "TEXT"
## for (i in seq_along(x)) {
## a <- x[[i]]
## tag <- attr(a, "latex_tag")
## if (is.null(tag)) tag <- "NULL"
## switch(tag,
## VERB = ,
## TEXT = ,
## COMMENT = result <- c(result, a),
## MACRO = {
## ## see issue #26
## ## regex in r-devel/R/src/library/tools/R/RdConv2.R:
## ## pat <- "([^\\]|^)\\\\[#$&_^~]"
## ## here we add grouping for substitution
## pat <- "([^\\]|^)(\\\\)([#$&_^~])" # with more grouping
## if(grepl(pat, a)){
## a <- gsub(pat, "\\1\\3", a)
## }
## result <- c(result, a)
## },
## BLOCK = result <- c(result, if (dropBraces && lastTag == "TEXT") Recall(a) else c("{", Recall(a), "}")),
## ENVIRONMENT = result <- c(result,
## "\\begin{", a[[1L]], "}",
## Recall(a[[2L]]),
## "\\end{", a[[1L]], "}"),
## ## MATH = result <- c(result, "$", Recall(a), "$"),
## MATH = result <- c(result, "\\eqn{", Recall(a), "}"),
## NULL = stop("Internal error, no tag", domain = NA)
## )
## lastTag <- tag
## }
## paste(result, collapse="")
## }
`%notin%` <-
function(x, y)
is.na(match(x, y))
## tools::deparseLatex() is by Sebastian Meyer and Duncan Murdoc. Below is a
## version suitable for Rdpack.
##
## This converts a latex object into a single element character vector
deparseLatexToRd <- function(x, dropBraces = FALSE)
{
specials <- c("\\", "#", "$", "%", "&", "~", "_", "^", "{", "}")
result <- character()
lastTag <- "TEXT"
expectArg <- FALSE
for (i in seq_along(x)) {
a <- x[[i]]
tag <- attr(a, "latex_tag")
if (is.null(tag)) tag <- "NULL"
result <- c(result,
switch(tag,
VERB = ,
COMMENT = a,
TEXT = c(if (lastTag == "MACRO" && expectArg && grepl("^[[:alpha:]]", a))
## restore space that the parser has eaten ('\item text')
" ",
a),
MACRO = {
## see issue #26
## regex in r-devel/R/src/library/tools/R/RdConv2.R:
## pat <- "([^\\]|^)\\\\[#$&_^~]"
## here we add grouping for substitution
pat <- "([^\\]|^)(\\\\)([#$&_^~])" # with more grouping
if(grepl(pat, a)){
a <- gsub(pat, "\\1\\3", a)
}
c(if (lastTag == "MACRO" && expectArg && grepl("^[[:alpha:]]", a))
## restore space that the parser has eaten ('\item text')
" ",
a)
},
BLOCK = if (dropBraces && !expectArg)
Recall(a)
else
c("{", Recall(a), "}"),
ENVIRONMENT = c(
"\\begin{", a[[1L]], "}",
Recall(a[[2L]]),
"\\end{", a[[1L]], "}"),
## enclose maths in \eqn{...}, not $ ... $; # \( and \) parse as MACRO
MATH = c("\\eqn{", Recall(a), "}"),
NULL = stop("Internal error, no tag", domain = NA)
))
lastTag <- tag
expectArg <-
if (tag == "MACRO")
a %notin% paste0("\\", c(specials, "(", ")"))
else
expectArg &&
tag %in% c("BLOCK", "COMMENT") # \cmd{}{}, \cmd%
## currently ignoring \cmd {}, \cmd[]{}, \cmd*{}
}
paste(result, collapse="")
}
Rdpack_bibstyles <- local({
styles <- list()
function(package, authors){
if((n <- nargs()) > 1){
styles[[package]] <<- authors
}else if(n == 1)
styles[[package]]
else
styles
}
})
.toRd_styled <- function(bibs, package, style = ""){
sty <- if(length(package) == 0)
NULL
else if(!isNamespaceLoaded(package) && !requireNamespace(package) )
NULL
else
Rdpack_bibstyles(package)
# if(!is.null(sty))
# res <- sapply(bibs, function(x) tools::toRd(x, style = "JSSLongNames"))
# else { # check style
# if(style == ""){
# if(!("JSSRd" %in% tools::getBibstyle(all = TRUE)))
# ## bibstyle_JSSRd()
# set_Rdpack_bibstyle("JSSRd")
# res <- sapply(bibs, function(x) tools::toRd(x, style = "JSSRd"))
# }else{
# res <- sapply(bibs, function(x) tools::toRd(x, style = "JSSLongNames"))
# }
# }
sty <- if(is.null(sty) && style == ""){
if(!("JSSRd" %in% tools::getBibstyle(all = TRUE)))
set_Rdpack_bibstyle("JSSRd")
"JSSRd"
}else
"JSSLongNames"
## 2022-03-20 This removes a url for a doi when there is also a doi field with the same
## doi. However, the url's of doi's ending in -X (dash followed by X or digit) lose
## the dash in the url and the below function will not remove them (see for example
## the rendered 'pcts-package.Rd').
##
## This explains the mistery that sometimes the doi gets duplicated by an url.
##
## 2022-03-20 TODO:
## given that 'R CMD check' is not happy, just remove a URL if it has
## "https?://doi.org/"? (i.e., don't check that the doi is the same?
## DONE: 2022-03-21 was: grepl(paste0("https?://doi.org/", x$doi), x$url)
f <- function(x){
if(!is.null(x$doi) && !is.null(x$url) && grepl("https?://doi.org/", x$url))
x$url <- NULL
## (2021-10-13) TODO: regarding issue #7 in rbibutils
## to fix temporarilly, add here processing of author and editor fields
## to change \'i to \'\i, if any, see
## https://github.com/GeoBosh/rbibutils/issues/7#issuecomment-939852743
##
## But 'author' fields are of class "person", so the following will not work:
##
## if(!is.null(x$author) && grepl("\\\\'i", x$author))
## x$author <- gsub("\\\\'i", "\\\\'\\\\i", x$author),
##
## Processing the person field in each reference is not appealing.
## Maybe rbibutils should get texChars = "Rdpack" option and do whatever specific
## for Rdpack is needed.
tools::toRd(x, style = sty)
}
## TODO: check if these 'sapply()' preserves encodings, if set.
res <- sapply(bibs, f)
## 2018-10-08
## TODO: this is risky but read.bib, bibentry, toRd and similar seem to work
## internally with UTF-8
##
## if(!all(Encoding(res) == "UTF-8")){
## # warning(paste("encoding is: ", paste0(Encoding(res), collapse = ", "), "\n"))
## Encoding(res) <- "UTF-8"
## }
res
}
set_Rdpack_bibstyle <- local({
## from /tools/R/bibstyle.R makeJSS()
collapse <- function(strings)
paste(strings, collapse="\n")
emph <- function(s)
if (length(s)) paste0("\\emph{", collapse(s), "}")
authorList <- function (paper) {
names <- sapply(paper$author, shortName)
if (length(names) > 1L)
result <- paste(names, collapse = ", ")
else result <- names
result
}
editorList <- function (paper) {
names <- sapply(paper$editor, shortName)
if (length(names) > 1L)
result <- paste(paste(names, collapse = ", "), "(eds.)")
else if (length(names))
result <- paste(names, "(ed.)")
else result <- NULL
result
}
shortName <- function (person) {
if (length(person$family)) {
result <- cleanupLatex(person$family)
if (length(person$given))
paste(result, paste(substr(sapply(person$given, cleanupLatex),
1, 1), collapse = ""))
else result
}
else paste(cleanupLatex(person$given), collapse = " ")
}
## Clean up LaTeX accents and braces
## this is a copy of unexported tools:::cleanupLatex by Duncan Murdoch.
cleanupLatex <- function(x) {
if (!length(x))
return(x)
latex <- tryCatch(tools::parseLatex(x), error = function(e)e)
if (inherits(latex, "error")) {
x
} else {
deparseLatexToRd(latexToUtf8(latex), dropBraces=TRUE)
}
}
## modified from tools::makeJSS()
## TODO: report on R-devel?.
bookVolume <- function(book) {
result <- ""
if (length(book$volume)){
result <- paste("volume", collapse(book$volume))
if (length(book$number))
result <- paste0(result, "(", collapse(book$number), ")")
if (length(book$series))
result <- paste(result, "of", emph(collapse(book$series)))
}else if (length(book$number)){
## todo: in JSS style and others the title end with '.' and
## 'number' is 'Number', but don't want to fiddle with this now.
result <- paste(result, "number", collapse(book$number))
if (length(book$series))
result <- paste(result, "in", collapse(book$series))
}else if (length(book$series))
result <- paste(result, collapse(book$series))
if (nzchar(result)) result
}
## new 2021-04-23
sortKeys <- function (bib) {
result <- character(length(bib))
for (i in seq_along(bib)) {
authors <- authorList(bib[[i]])
if (!length(authors))
authors <- editorList(bib[[i]])
if (!length(authors))
authors <- ""
year <- collapse(bib[[i]]$year)
authyear <- if(authors != "" )
paste0(authors, ", ", year)
else
year
result[i] <- authyear
}
result
}
function(bibstyle = "JSSRd"){
switch(bibstyle,
"JSSRd" =
tools::bibstyle("JSSRd", .init = TRUE, .default = FALSE,
cleanupLatex = cleanupLatex,
bookVolume = bookVolume,
sortKeys = sortKeys
),
"JSSLongNames" =
tools::bibstyle("JSSLongNames", .init = TRUE, .default = FALSE,
cleanupLatex = cleanupLatex,
bookVolume = bookVolume,
sortKeys = sortKeys,
shortName = function(person) {
paste(paste(cleanupLatex(person$given), collapse=" "),
cleanupLatex(person$family), sep = " ")
}
),
## default
stop("Unknown bibstyle ", bibstyle)
)
}
})
.onLoad <- function(lib, pkg){
## define the styles but not set any of them as default
set_Rdpack_bibstyle("JSSRd")
set_Rdpack_bibstyle("JSSLongNames")
## set "LongNames" style for this package (Rdpack)
Rdpack_bibstyles(package = pkg, authors = "LongNames")
invisible(NULL)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.