Stardust_tuning/R-3.6.0/src/library/tools/R/bibstyle.R

In SimoneAvesani/Stardust_rCASC: stardust: Improving Spatial Transcriptomics Data Analysis Through Space Aware Modularity Optimization Based Clustering.

#  File src/library/tools/R/bibstyle.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2013 The R Core Team
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  A copy of the GNU General Public License is available at
#  https://www.R-project.org/Licenses/

# Functions for making Rd and human readable versions of bibentry records.

# Clean up LaTeX accents and braces
cleanupLatex <- function(x) {
    if (!length(x)) return(x)
    latex <- tryCatch(parseLatex(x), error = identity)
    if (inherits(latex, "error")) {
    	x
    } else {
    	deparseLatex(latexToUtf8(latex), dropBraces=TRUE)
    }
}

makeJSS <- function() {

    # First, some utilities

    collapse <- function(strings)
        paste(strings, collapse="\n")

    # Add a period if there's no sentence punctuation already
    addPeriod <- function(string)
        sub("([^.?!])$", "\\1.", string)

    # Separate args by sep, add a period at the end.
    sentence <- function(..., sep = ", ") {
        strings <- c(...)
        if (length(strings)) {
            addPeriod(paste(strings, collapse = sep))
        }
    }

    # Now some simple markup

    plain <- function(pages)
        if (length(pages)) collapse(pages)

    plainclean <- function(s) plain(cleanupLatex(s))

    emph <- function(s)
        if (length(s)) paste0("\\emph{", collapse(s), "}")

    emphclean <- function(s) emph(cleanupLatex(s))

    # This creates a function to label a field by adding a prefix or
    # suffix (or both)

    label <- function(prefix=NULL, suffix=NULL, style=plain) {
        force(prefix); force(suffix); force(style)
        function(s)
            if (length(s)) style(paste0(prefix, collapse(s), suffix))
    }

    labelclean <- function(prefix=NULL, suffix=NULL, style=plain) {
        f <- label(prefix, suffix, style)
        function(s) f(cleanupLatex(s))
    }

    # Now the formatters for each particular field.  These take
    # a character vector; if length zero, they return NULL, otherwise
    # a single element character vector putting everything together

    fmtAddress <- plainclean
    fmtBook <- emphclean
    fmtBtitle <- emphclean
    fmtChapter <- labelclean(prefix="chapter ")
    fmtDOI <- label(prefix="\\doi{", suffix="}")
    fmtEdition <- labelclean(suffix=" edition")
    fmtEprint <- plain
    fmtHowpublished <- plainclean
    fmtISBN <- label(prefix = "ISBN ")
    fmtISSN <- label(prefix="ISSN ")
    fmtInstitution <- plainclean
    fmtNote <- plainclean
    fmtPages <- plain
    fmtSchool <- plainclean
    ## fmtTechreportnumber <- labelclean(prefix="Technical Report ")
    fmtUrl <- label(prefix="\\url{", suffix="}")
    fmtTitle <- function(title)
        if (length(title))
            paste0("\\dQuote{",
                   addPeriod(collapse(cleanupLatex(title))), "}")

    fmtYear <- function(year) {
        if (!length(year)) year <- "????"
        paste0("(", collapse(year), ")")
    }

    fmtType <- function(type, default) {
        if(length(type) && any(nzchar(type)))
            plainclean(type)
        else
            default
    }

    # Now some more complicated ones that look at multiple fields
    volNum <- function(paper) {
        if (length(paper$volume)) {
            result <- paste0("\\bold{", collapse(paper$volume), "}")
            if (length(paper$number))
                result <- paste0(result, "(", collapse(paper$number), ")")
            result
        }
    }

    ## Format one person object in short "Murdoch DJ" format
    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=" ")
    }

    # Format all authors for one paper
    authorList <- function(paper) {
        names <- sapply(paper$author, shortName)
        if (length(names) > 1L)
            result <- paste(names, collapse = ", ")
        else
            result <- names
        result
    }

    # Format all editors for one paper
    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
    }

    extraInfo <- function(paper) {
        result <- paste(c(fmtDOI(paper$doi), fmtNote(paper$note),
                          fmtEprint(paper$eprint), fmtUrl(paper$url)),
                        collapse=", ")
        if (nzchar(result)) result
    }

    bookVolume <- function(book) {
        result <- ""
        if (length(book$volume))
            result <- paste("volume", collapse(book$volume))
        if (length(book$number))
            result <- paste(result, "number", collapse(book$number))
        if (length(book$series))
            result <- paste(result, "series", collapse(book$series))
        if (nzchar(result)) result
    }

    bookPublisher <- function(book) {
        if (length(book$publisher)) {
            result <- collapse(book$publisher)
            if (length(book$address))
                result <- paste(result, collapse(book$address), sep = ", ")
            result
        }
    }

    procOrganization <- function(paper) {
        if (length(paper$organization)) {
            result <- collapse(cleanupLatex(paper$organization))
            if (length(paper$address))
                result <- paste(result, collapse(cleanupLatex(paper$address)), sep =", ")
            result
        }
    }

    fmtTechreportnumber <- function(paper) {
        if(length(paper$number)) {
            paste(fmtType(paper$type, "Technical Report"),
                  plainclean(paper$number))
        }
    }

    formatArticle <- function(paper) {
        collapse(c(fmtPrefix(paper),
                   sentence(authorList(paper), fmtYear(paper$year), sep = " "),
                   fmtTitle(paper$title),
                   sentence(fmtBook(paper$journal), volNum(paper),
                            fmtPages(paper$pages)),
                   sentence(fmtISSN(paper$issn), extraInfo(paper))))
    }

    formatBook <- function(book) {
        authors <- authorList(book)
        if(!length(authors))
            authors <- editorList(book)

        collapse(c(fmtPrefix(book),
                   sentence(authors, fmtYear(book$year), sep = " "),
                   sentence(fmtBtitle(book$title), bookVolume(book),
                            fmtEdition(book$edition)),
                   sentence(bookPublisher(book)),
                   sentence(fmtISBN(book$isbn), extraInfo(book))))
    }

    formatInbook <- function(paper) {
        authors <- authorList(paper)
        editors <- editorList(paper)
        if(!length(authors)) {
            authors <- editors
            editors <- NULL
        }
        collapse(c(fmtPrefix(paper),
                   sentence(authors, fmtYear(paper$year), sep =" "),
                   fmtTitle(paper$title),
                   paste("In", sentence(editors, fmtBtitle(paper$booktitle),
                                        bookVolume(paper),
                                        fmtChapter(paper$chapter),
                                        fmtEdition(paper$edition),
                                        fmtPages(paper$pages))),
                   sentence(bookPublisher(paper)),
                   sentence(fmtISBN(paper$isbn), extraInfo(paper))))
    }

    formatIncollection <- function(paper) {
        collapse(c(fmtPrefix(paper),
                   sentence(authorList(paper), fmtYear(paper$year), sep = " "),
                   fmtTitle(paper$title),
                   paste("In", sentence(editorList(paper),
                                        fmtBtitle(paper$booktitle),
                                        bookVolume(paper),
                                        fmtEdition(paper$edition),
                                        fmtPages(paper$pages))),
                   sentence(bookPublisher(paper)),
                   sentence(fmtISBN(paper$isbn), extraInfo(paper))))
    }

    formatInProceedings <- function(paper)
        collapse(c(fmtPrefix(paper),
                   sentence(authorList(paper), fmtYear(paper$year), sep = " "),
                   fmtTitle(paper$title),
                   paste("In", sentence(editorList(paper),
                                        fmtBtitle(paper$booktitle),
                                        bookVolume(paper),
                                        fmtEdition(paper$edition),
                                        fmtPages(paper$pages))),
                   sentence(procOrganization(paper)),
                   sentence(fmtISBN(paper$isbn), extraInfo(paper))))

    formatManual <- function(paper) {
        collapse(c(fmtPrefix(paper),
                   sentence(authorList(paper), fmtYear(paper$year), sep = " "),
                   sentence(fmtBtitle(paper$title), bookVolume(paper),
                            fmtEdition(paper$edition)),
                   sentence(procOrganization(paper)),
                   sentence(fmtISBN(paper$isbn), extraInfo(paper))))
    }

    formatMastersthesis <- function(paper) {
        collapse(c(fmtPrefix(paper),
                   sentence(authorList(paper), fmtYear(paper$year), sep = " "),
                   sentence(fmtBtitle(paper$title)),
                   sentence(fmtType(paper$type, "Master's thesis"),
                            fmtSchool(paper$school),
                            fmtAddress(paper$address)),
                   sentence(extraInfo(paper))))
    }

    formatPhdthesis <- function(paper) {
        collapse(c(fmtPrefix(paper),
                   sentence(authorList(paper), fmtYear(paper$year), sep = " "),
                   sentence(fmtBtitle(paper$title)),
                   sentence(fmtType(paper$type, "Ph.D. thesis"),
                            fmtSchool(paper$school),
                            fmtAddress(paper$address)),
                   sentence(extraInfo(paper))))
    }

    formatMisc <- function(paper) {
        collapse(c(fmtPrefix(paper),
                   sentence(authorList(paper), fmtYear(paper$year), sep = " "),
                   fmtTitle(paper$title),
                   sentence(fmtHowpublished(paper$howpublished)),
                   sentence(extraInfo(paper))))
    }

    formatProceedings <- function(book) {
        if (is.null(book$editor)) editor <- "Anonymous (ed.)"
        else editor <- editorList(book)
        collapse(c(fmtPrefix(book), # not paper
                   sentence(editor, fmtYear(book$year), sep = " "),
                   sentence(fmtBtitle(book$title), bookVolume(book)),
                   sentence(procOrganization(book)),
                   sentence(fmtISBN(book$isbn), fmtISSN(book$issn),
                            extraInfo(book))))
    }

    formatTechreport <- function(paper) {
        collapse(c(fmtPrefix(paper),
                   sentence(authorList(paper), fmtYear(paper$year), sep = " "),
                   fmtTitle(paper$title),
                   sentence(fmtTechreportnumber(paper),
                            fmtInstitution(paper$institution),
                            fmtAddress(paper$address)),
                   sentence(extraInfo(paper))))
    }

    formatUnpublished <- function(paper) {
        collapse(c(fmtPrefix(paper),
                   sentence(authorList(paper), fmtYear(paper$year), sep = " "),
                   fmtTitle(paper$title),
                   sentence(extraInfo(paper))))
    }

    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 <- ""
            result[i] <- authors
        }
        result
    }

    # Replace this if you want a bibliography style
    # that puts a prefix on each entry, e.g. [n]
    # The formatting routine will have added a field .index
    # as a 1-based index within the complete list.

    fmtPrefix <- function(paper) NULL

    cite <- function(key, bib, ...)
        utils::citeNatbib(key, bib, ...) # the defaults are JSS style

    environment()
}

bibstyle <- local({
    styles <- list(JSS = makeJSS())
    default <- "JSS"
    function(style, envir, ..., .init = FALSE, .default=TRUE) {
        newfns <- list(...)
        if (missing(style) || is.null(style)) {
            if (!missing(envir) || length(newfns) || .init)
            	stop("Changes require specified 'style'")
            style <- default
        } else {
	    if (!missing(envir)) {
		stopifnot(!.init)
		styles[[style]] <<- envir
	    }
	    if (.init) styles[[style]] <<- makeJSS()
	    if (length(newfns) && style == "JSS")
		stop("The default JSS style may not be modified.")
	    for (n in names(newfns))
		assign(n, newfns[[n]], envir=styles[[style]])
            if (.default)
            	default <<- style
        }
        styles[[style]]
    }
})

getBibstyle <- function(all = FALSE) {
    if (all)
    	names(environment(bibstyle)$styles)
    else
    	environment(bibstyle)$default
}

toRd.bibentry <- function(obj, style=NULL, ...) {
    obj <- sort(obj, .bibstyle=style)
    style <- bibstyle(style, .default = FALSE)
    env <- new.env(hash = FALSE, parent = style)
    bib <- unclass(obj)
    result <- character(length(bib))
    for (i in seq_along(bib)) {
    	env$paper <- bib[[i]]
    	result[i] <- with(env,
    	    switch(attr(paper, "bibtype"),
    	    Article = formatArticle(paper),
    	    Book = formatBook(paper),
    	    InBook = formatInbook(paper),
    	    InCollection = formatIncollection(paper),
    	    InProceedings = formatInProceedings(paper),
    	    Manual = formatManual(paper),
    	    MastersThesis = formatMastersthesis(paper),
    	    Misc = formatMisc(paper),
    	    PhdThesis = formatPhdthesis(paper),
    	    Proceedings = formatProceedings(paper),
    	    TechReport = formatTechreport(paper),
    	    Unpublished = formatUnpublished(paper),
    	    paste("bibtype", attr(paper, "bibtype"),"not implemented") ))
    }
    result
}