R/zzz.R

In rorcid: Interface to the 'Orcid.org' API

ocom <- function(l) Filter(Negate(is.null), l)
ocom2 <- function(l) Filter(function(l) !is.null(l) && length(l) > 0, l)

orcid_base <- function() "https://pub.orcid.org/v3.0"

ojson <- "application/vnd.orcid+json; qs=4"

orc_GET <- function(url, args = list(), ctype = ojson, ...) {
  cli <- crul::HttpClient$new(
    url = url,
    opts = list(...),
    headers = list(
      Accept = ctype,
      `User-Agent` = orcid_ua(),
      'X-USER-AGENT' = orcid_ua(),
      Authorization = orcid_auth()
    )
  )
  res <- cli$get(query = args)
  errs(res)
  res$parse("UTF-8")
}

check_key <- function() {
  x <- Sys.getenv("ORCID_TOKEN", "")
  if (x == "") {
    x <- getOption("orcid_token", "")
  }
  if (x == "") NULL else x
}

orcid_ua <- function() {
  versions <- c(
    paste0("r-curl/", utils::packageVersion("curl")),
    paste0("crul/", utils::packageVersion("crul")),
    sprintf("rOpenSci(rorcid/%s)", utils::packageVersion("rorcid"))
  )
  paste0(versions, collapse = " ")
}

`%||%` <- function(x, y) {
  if (is.null(x) || length(x) == 0) y else x
}

errs <- function(x) {
  if (x$status_code > 201) {
    xx <- jsonlite::fromJSON(x$parse("UTF-8"))
    if (any(c("error-code", "errorCode") %in% names(xx))) {
      # match by status code
      fun <- fauxpas::find_error_class(x$status_code)$new()
      fun$mssg <- xx$`developer-message` %||% xx$developerMessage
      fun$do_verbose(x)
    } else {
      # if no error message in response, just general stop
      fauxpas::http(x)
    }
  }
}

fuzzydoi <- function(x, fuzzy = FALSE) {
  if (fuzzy) {
    x
  } else {
    sprintf("digital-object-ids:\"%s\"", x)
  }
}

orc_parse <- function(x){
  out <- jsonlite::fromJSON(x, TRUE, flatten = TRUE)
  df <- tibble::as_tibble(out$result)
  attr(df, "found") <- out$`num-found`
  return(df)
}

# From the plyr package
failwith <- function(default = NULL, f, quiet = FALSE) {
  f <- match.fun(f)
  function(...) try_default(f(...), default, quiet = quiet)
}

# From the plyr package
try_default <- function(expr, default, quiet = FALSE) {
  result <- default
  if (quiet) {
    tryCatch(result <- expr, error = function(e) {
    })
  }
  else {
    try(result <- expr)
  }
  result
}

pluck <- function(x, name, type) {
  if (missing(type)) {
    lapply(x, "[[", name)
  } else {
    vapply(x, "[[", name, FUN.VALUE = type)
  }
}

pop <- function(x, name) x[ !names(x) %in% name ]

orcid_prof_helper <- function(x, path, ctype = ojson, parse = TRUE, ...) {
  url2 <- file.path(orcid_base(), x, path)
  out <- orc_GET(url2, ctype = ctype, ...)
  if (parse) switch_parser(ctype, out) else out
}

switch_parser <- function(ctype, x) {
  switch(
    ctype,
    `application/vnd.orcid+xml; qs=5` = px(x),
    `application/orcid+xml; qs=3` = px(x),
    `application/xml` = px(x),
    `application/vnd.orcid+json; qs=4` = pj(x),
    `application/orcid+json; qs=2` = pj(x),
    `application/json` = pj(x),
    `application/vnd.citationstyles.csl+json` = pj(x),
    stop("no parser found for ", ctype)
  )
}

pj <- function(z) jsonlite::fromJSON(z, flatten = TRUE)
px <- function(z) xml2::read_xml(z)

orcid_putcode_helper <- function(path, orcid, put_code, format, ...) {
  if (!is.null(put_code)) {
    if (length(orcid) > 1) {
      stop("if 'put_code' is given, 'orcid' must be length 1")
    }
  }
  pth <- if (is.null(put_code)) path else file.path(path, put_code)
  if (length(pth) > 1) {
    stats::setNames(
      Map(function(z) orcid_prof_helper(orcid, z, ctype = format), pth),
      put_code)
  } else {
    nmd <- if (!is.null(put_code)) put_code else orcid
    stats::setNames(
      lapply(orcid, orcid_prof_helper, path = pth, ctype = format, ...), nmd)
  }
}

as_dt <- function(x, tibble = TRUE, att = NULL) {
  z <- data.table::setDF(
    data.table::rbindlist(x, use.names = TRUE, fill = TRUE)
  )
  if (!is.null(att)) {
    for (i in seq_along(att)) attr(z, names(att)[i]) <- att[[i]]
  }
  if (tibble) z <- tibble::as_tibble(z)
  return(z)
}

path_picker <- function(put_code, summary, pth_single) {
  if (!summary) {
    if (is.null(put_code)) paste0(pth_single, "s") else pth_single
  } else {
    if (is.null(put_code)) {
      stop("if summary == TRUE, must give 1 or more put_code")
    }
    file.path(pth_single, "summary")
  }
}

#'@title extract BibTeX record from ORCID JSON sring if available
#'
#'@description Helper function to extract BibTeX records which may be
#'available in the string returned from ORCID. The function is exported.
#'
#'@param x (**required**): the output of `cite_put()`
#'
#'@return Function returns a formated BibTeX record, if nothing
#'was found or the BibTeX record is invalid, the input is passed
#'through without modifying it
#'
#'@seealso [jsonlite::fromJSON], `cite_put`
#'
#'@md
#'@noRd
extract_bibtex <- function(x) {

  ##parse jsonlite input (this was what we expect)
  bib <- jsonlite::fromJSON(x)

  ##Does any citation string exist?
  if (any("citation" %in% names(bib))) {
    ##check whether we have a BibTeX record
    if (bib$citation$`citation-type` != "bibtex") {
      pc <- bib$`put-code`
      warning(paste0("No BibTeX record found for record with put-code: ", pc),
              call. = FALSE)
      return(x)
    }

    ##remove all line breaks, they cause too many problems
    bib <- gsub("\\n", replacement = "", bib$citation$`citation-value`, fixed = TRUE, useBytes = TRUE)
    bib <- gsub("\n", replacement = "", bib, fixed = TRUE, useBytes = TRUE)

    ##houskeeping to avoid BibTeX format problems
    ##>> check for double backslash, there are probably wrong
    bib <- gsub("\\\\", replacement = "\\", bib, fixed = TRUE)

    ##>> extract BibTeX entries
    bib_type <- regmatches(bib, regexpr("@[a-z]+", bib, perl = TRUE))
    bib_keywords <- unlist(regmatches(bib, gregexpr("[a-z]+(?=\\s*?=)", bib, perl = TRUE)))
    bib_entries <- trimws(unlist(strsplit(bib, split = "[a-z]+\\s*?="))[-1])
    names(bib_entries) <- bib_keywords

    ##>> missing or wrong cite keys cause all kind of trouble, we reset them
    if (any(c("author", "year") %in% bib_keywords)) {
      cite_key <- trimws(strsplit(bib_entries["author"], "and", fixed = TRUE)[[1]][1])
      cite_key <- strsplit(cite_key, ",", fixed = TRUE)[[1]][1]
      cite_key <- regmatches(cite_key, gregexpr("[[:alpha:]]+", cite_key))[[1]]
      cite_key <- paste0(
        cite_key, "_",
        regmatches(bib_entries["year"], gregexpr("[[:digit:]]+", bib_entries["year"]))[[1]][1],
        paste(sample(letters, 3, TRUE), collapse = ""))
    } else {
      cite_key <- paste(sample(letters, 12, replace = TRUE), collapse = "")
    }

    ##>> glue everything together and add line breaks and tabs
    x <-  paste0(paste0(bib_type, "{", cite_key, ",\n"),
                 paste(paste0("\t", bib_keywords, " = ", bib_entries),
                       collapse = "\n"))

    ##>> fix last bracket to have a nice record entry
    x <- paste0(strtrim(x, nchar(x) - 1), "\n}")
  }
  return(x)
}