# parse_people -----------------------------------------------------------------
## internal method, takes R person object and turns to codemeta / json-ld
## FIXME if @id is available, avoid replicate listing of node?
#' @importFrom utils as.person
#' @importFrom methods is
parse_people <- function(people, codemeta) {
people <- as.person(people)
if (length(people) == 0) {
return(codemeta)
}
## people with no role are assumed to be "Author" role
role_mapping <- list(
author = c("aut", NA), # NA = people without a role
contributor = c("ctb", "com", "dtc", "ths", "trl"),
copyrightHolder = "cph",
funder = "fnd",
maintainer = "cre"
)
# get the names of the role entries in codemeta as given in role_mapping
roles <- names(role_mapping)
# call people_with_role on each element of role_mapping and assign the
# resulting lists to the corresponding entries in codemeta
codemeta[roles] <- lapply(role_mapping, people_with_role, people = people)
# return codemeta
codemeta
}
# people_with_role -------------------------------------------------------------
people_with_role <- function(people, role = "aut") {
# If there is more than one role requested, call this function recursively
# for each role, combine the results with c() and return
if (length(role) > 1) {
return(do.call(c, lapply(role, people_with_role, people = people)))
}
# if role is NA, has_role is TRUE for all people without any role!
has_role <- locate_role(people, role)
# return NULL if there are no people with the required (or without any) role
if (! any(has_role)) {
return(NULL)
}
# create schema for each person with the selected (or without any) role
lapply(people[has_role], person_to_schema)
}
# locate_role ------------------------------------------------------------------
# role = NA returns TRUE for all people without a role
#' @importFrom purrr map_lgl
locate_role <- function(people, role = "aut") {
if (is.na(role)) {
purrr::map_lgl(people, person_has_no_role)
} else {
purrr::map_lgl(people, person_has_role, role = role)
}
}
# person_has_no_role -----------------------------------------------------------
#' @noRd
person_has_no_role <- function(person) {
stopifnot(inherits(person, "person"))
is.null(person$role)
}
# person_has_role --------------------------------------------------------------
#' @noRd
person_has_role <- function(person, role) {
stopifnot(inherits(person, "person"))
any(grepl(role, person$role))
}
# person_to_schema -------------------------------------------------------------
person_to_schema <- function(p) {
p <- as.person(p)
if (length(p) == 0) {
return(NULL)
}
## assume type is Organization if family name is null
type <- get_type_of_person(p)
# initialise the metadata list, depending on the type of person
codemeta <- switch(
type,
"Person" = list(
"@type" = type,
givenName = p$given,
familyName = p$family
),
"Organization" = list(
"@type" = type,
name = c(p$given, p$family)
)
)
## add email and ORCID, if given
codemeta <- c(codemeta, drop_null(list(
email = p$email,
"@id" = get_orcid_of_person(p) # may return NULL
## Store ORCID also in comment?
)))
codemeta
}
# get_type_of_person -----------------------------------------------------------
#' @noRd
get_type_of_person <- function(p) {
stopifnot(inherits(p, "person"))
if (is.null(p$family) || is.null(p$given)) {
"Organization"
} else {
"Person"
}
}
# get_orcid_of_person ----------------------------------------------------------
#' @noRd
get_orcid_of_person <- function(p)
{
# get the comment field of the person
comment <- p$comment
# return NULL if there is no comment for that person
if (is.null(comment)) {
return(NULL)
}
# return the full comment if it contains "orcid"
if (any(grepl("orcid", comment))) {
return(comment[grepl("orcid",comment)])
}
# return NULL if the named vector does not contain an element "ORCID"
if (! "ORCID" %in% names(comment)) {
return(NULL)
}
# get the (unnamed) element "ORDID" from the comment vector
id <- unname(comment["ORCID"])
# make sure that an URL to orcid.org is returned.
if (! grepl("^https?", id)) {
paste0("https://orcid.org/", id)
} else {
id
}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.