R/bib.R

In GeoBosh/Rdpack: Update and Manipulate Rd Documentation Objects

## 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
                             )
                         })

            #     # 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)
}