R/bib.R

In rbibutils: Read 'Bibtex' Files and Convert Between Bibliography Formats

## Do not edit this file manually.
## It has been automatically generated from *.org sources.

  readBib <- function(file, encoding = NULL, ..., direct = FALSE,
		      texChars = c("keep", "convert", "export", "Rdpack"),
		      macros = NULL, extra = FALSE, key, fbibentry = NULL){

      if(is.null(encoding))
	  encoding <- c("utf8", "utf8")  # would default input 'native' be better?
      else {
	  encoding <- ifelse(encoding == "UTF-8", "utf8", encoding)
	  if(length(encoding) == 1)
	      encoding <- c(encoding, "utf8")
      }

      if(is.null(macros)){
	  if(!file.exists(file))
	      stop("file '", file, "' doesn't exist")
      }else{
	  fn <- tempfile(fileext = ".bib")
					  # TODO: changing this to try to fix a strange error on Windows,
					  #       though it turns out that
					  #       bib/litprog280macros_only.bib is not there during 'R CMD check'
					  # for(s in c(macros, file))
					  #     if(!file.append(fn, s))
					  #         stop("could not copy file ", s)
	  files <- c(macros, file)
	  exist_flags <- file.exists(files)
	  if(any(!exist_flags)){
	      stop("files  ", paste(files[!exist_flags], collapse = ", "), " do not exist")
	  }
        
	  if(!file.copy(files[1], fn, overwrite = TRUE))
	      stop("could not copy file ", files[1], "\nto destination")
	  for(s in files[-1])
	      if(!file.append(fn, s))
		  stop("could not copy file ", s)
        
	  file <- fn
      }
    
      if(!direct){
	  ## to make sure that the old behaviour before adding arguments is kept.
	  ##     TODO: relax and coordinate with direct = TRUE later
	  stopifnot(length(list(...)) == 0) # no ... arguments allowed

	  bib <- tempfile(fileext = ".bib")
	  on.exit(unlink(bib))

	  ## 2024-11-12: reverting this back to the previous. Will resolve the issue in a different way.
	  ## be <- bibConvert(file, bib, "bibtex",
	  ##                                 # 2024-10-11 was: tex = "no_latex"
	  ##                  "bibentry", encoding = encoding, tex = c("no_latex", "convert_latex_escapes"))
	  be <- bibConvert(file, bib, "bibtex",
			   "bibentry", encoding = encoding, tex = "no_latex")
	  res <- be$bib
      }else{ ## direct is TRUE below
	  texChars <- match.arg(texChars)
	  switch(texChars,
		 convert = {
		     ## was: tex <- "no_latex"
		     tex <- c("convert_latex_escapes", "no_latex")
		 },
		 keep = {
		     ## this will need separate no_latex option for infile and outfile.
		     #stop(" 'texChars = keep' not implemented yet")
		     tex <- c("keep_tex_chars", "no_latex")
		 },
		 Rdpack = {
		     ## like 'keep' but patches for Rdpack, see issue #7 in rbibutils
		     tex <- c("keep_tex_chars", "no_latex", "Rdpack")
		 },
		 export = {
		     tex <- c("export_tex_chars")
		 },
		 ## default
		 tex <- NULL
		 )

	  res <- bibtexImport(file, encoding = encoding, tex = tex, extra = extra,
			      fbibentry = fbibentry)
      }

      if(!missing(key)){
	  ind <- which(grepl("dummyid", names(res)))
	  if(length(ind) > 0  &&  length(ind) != length(key)){
	      stop("length of 'key' is not equal to the number of keyless entries")
	  }else if(length(ind) > 0){
	      for(i in 1:length(ind))
		  res[ind[i]]$key <-  key[i]
	      ## TODO: it seems necessary to do also this. Investigate for a simpler approach.
	      names(res)[ind] <- key
	  }
      }
    
      res
  }

writeBib <- function(object, con = stdout(), append = FALSE){
    if(!inherits(object, "bibentry"))
        stop("'object' must inherit from class 'bibentry'.")
    
    mode <- if(append) "a" else "w+"

    if (is.character(con)) {
        con <- file(con, open = mode)
        on.exit(close(con))
    }

    lines <- toBibtex(object)
    writeLines(lines, con)
             
    invisible(object)
}

charToBib <- function(text, informat, ...) {
    fn <- tempfile()
    writeLines(text, fn)
    on.exit(unlink(fn))
    
    res <- if(missing(informat))
               readBib(fn, ...)
           else
               bibConvert(fn, informat = informat, ...)
    res
}

## This adds to and/or modifies some functions in the environment created by 
## tools::bibstyle (R Core Team [cph])
bibstyle_JSSextra <- function(style = "JSSextra", reset = FALSE, make_default = FALSE){
        ## check if 'style' is registered; if so, return it unless reset is TRUE
        JSSextra <- tools::bibstyle(style, .default = make_default)
        if(!is.null(JSSextra) && !reset)
            return(JSSextra)

        ## create a copy of JSS bibstyle
        ## 2025-10-30 however, tools::bibstyle replaces the old parent_style with the new one,
        ##            So, after this, JSSextra will be still the same environment as JSS.
        ##
        ##            A second call, tools::bibstyle("JSS", .default = FALSE) after this
        ##            (without assignment) will create a new copy of JSS - so, this is one way
        ##            to resolve the issue - but better not to use such a confusing hack.
        ## was: JSSextra <<- tools::bibstyle(parent_style, .init = TRUE, .default = FALSE)
        JSSextra <- tools::bibstyle(style, .init = TRUE, .default = make_default)

        with(JSSextra, {
            ## 2025-10-30: copied from JSSRd (Rdpack)
            ##
            ## modified from tools::makeJSS()
            ## TODO: report on R-devel?.
            ##
            ## TODO: do we need thiss modification?
            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 ends 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
            }

            ## copied from JSSRd (Rdpack)
            ##
            ## modify sortKeys from JSS style
            ##
            ## this is a copy of sortKeys from JSSRd style (see Rdpack)
            ## with the additional check for length(year)
            sortKeys <- function (bib) {
                result <- character(length(bib))
                for (i in seq_along(bib)) {
                    ## this is from the original JSS
                    authors <- authorList(bib[[i]])
                    if (!length(authors)) 
                        authors <- editorList(bib[[i]])
                    if (!length(authors)) 
                        authors <- ""
                    ## the rest is new;
                    ## append the year to resolve tied authors;
                    ## 'authors' is of length 1 here
                    ##
                    ## 2025-10-30 Note:  TODO:
                    ##    Is the intent to check nzchar(year) > 0?
                    ##    length(year) will always be 1, since collapse()
                    ##    calls paste() with collapse = "\n"
                    ##
                    ##    length(year) is not checked by the version in Rdpack;
                    ##    I must have had a reason to make this change when copying
                    ##    from there but can't find any note about it.
                    year <- collapse(bib[[i]]$year)
                    if(length(year)) {
                        authors <- if(authors != "" )
                                       paste0(authors, ", ", year)
                                   else
                                       year
                    }    
                    result[i] <- authors
                }
                result
            }
        
            fmtTitleNoPeriod <- function(title){
                if (length(title)) {
                    title <- gsub("%", "\\\\\\%", title)
                    paste0("\\dQuote{", collapse(cleanupLatex(title)), "}")
                }
            }
        
            ## make this safely reentrable - if formatMiscJSS exists, the original formatMisc
            ## has been alread been replaced.
            if(!exists("formatMiscJSS"))
                formatMiscJSS <- formatMisc

            ## TODO: more work needed here
            formatMisc <- function(paper) {
                ## if 'year' is missing, try to replace it with 'date'
                if(is.null(paper$year) && !is.null(paper$date)){
                    if(grepl("^[0-9][0-9][0-9][0-9]", paper$date))
                        paper$year <- substr(paper$date, 1, 4)
                }
                
                if(is.null(paper$truebibtype))
                    ## default copy of JSS's formatMisc
                    formatMiscJSS(paper)
                else{
                    switch(paper$truebibtype,
                           Article = {
                               if(is.null(paper$journal))
                                   paper$journal <- paper$journaltitle
                               formatArticle(paper)
                           },
                           Book = {
                               formatBook(paper)
                           },
                           # Booklet = {
                           #     formatBook(paper)
                           # },
                           InBook = {
                               formatInbook(paper)  # note: not InBook
                           },
                           InCollection = {
                               formatIncollection(paper)   # note: not InCollection
                           },
                           InProceedings = {
                               formatInProceedings(paper)
                           },
                           Manual = {
                               formatManual(paper)
                           },
                           MastersThesis = {
                               formatMastersthesis(paper)
                           },
                           Misc = {
                               formatMisc(paper)
                           },
                           PhdThesis = {
                               formatPhdthesis(paper)
                           },
                           Proceedings = {
                               formatProceedings(paper)
                           },
                           TechReport = {
                               formatTechreport(paper)
                           },
                           Unpublished = {
                               formatUnpublished(paper)
                           },
                           ## non-standard
                           periodical = { # TODO: this is to get things going
                               collapse(c(
                                   fmtPrefix(paper),
                                   paste0(fmtTitleNoPeriod(paper$title),
                                          fmtYear(paper$year)),
                                   paste0(paper$paper$editor),
                                   editorList(paper),
                                   sentence(procOrganization(paper)),
                                   paste0(paper$paper$publisher),
                                   #paste0(paper$address),        
                                   sentence(fmtISSN(paper$issn), extraInfo(paper)),
                                   paste0(paper$organization),
                                   #paste0(paper$note),
                                   #paste0(paper$acknowledgement),
                                   #paste0(paper$key),
                                   #paste0(paper$bibdate),
                                   paste0(paper$bibsource)
                               ))
                           },
                           online = { # based initially on formatMisc
                               collapse(c(fmtPrefix(paper),
                                        sentence(authorList(paper), fmtYear(paper$year), sep = " "),
                                        fmtTitle(paper$title),
                                        sentence(fmtHowpublished(paper$howpublished)),
                                        sentence(extraInfo(paper),
                                                 paste0("(visited on ", paper$urldate, ")"),
                                                 sep = " ")
                                        ))
                           },
                           ## default - TODO,
                           {
                               collapse(c(fmtPrefix(paper),
                                          sentence(authorList(paper), fmtYear(paper$year), sep = " "),
                                          fmtTitle(paper$title),
                                          sentence(fmtHowpublished(paper$howpublished)),
                                          sentence(extraInfo(paper))))
                           }
                           )
                }
            }
        })
        
        JSSextra
}

## This adds to and/or modifies some functions in the environment created by 
## tools::bibstyle (R Core Team [cph])
bibstyle_JSSextraLongNames <- function(style = "JSSextraLongNames", reset = FALSE,
                                       make_default = FALSE){
        ## check if 'style' is registered; if so, return it unless reset is TRUE
        JSSextra <- tools::bibstyle(style, .default = make_default)
        if(!is.null(JSSextra) && !reset)
            return(JSSextra)

        ## we need a separate clone of JSSextra here, so reset = TRUE
        JSSextra <- bibstyle_JSSextra(style, reset = TRUE)

        with(JSSextra, {
          shortName = function(person) {
                          paste(paste(cleanupLatex(person$given), collapse=" "),
                                      cleanupLatex(person$family), sep = " ")
                      }

        })
        
        JSSextra
}