data_authors <- function(pkg = ".", roles = default_roles()) {
pkg <- as_pkgdown(pkg)
author_info <- pkg$meta$authors %||% list()
all <- pkg %>%
pkg_authors() %>%
purrr::map(author_list, author_info, pkg = pkg)
main <- pkg %>%
pkg_authors(roles) %>%
purrr::map(author_list, author_info, pkg = pkg)
more_authors <- length(main) != length(all)
comments <- pkg %>%
pkg_authors() %>%
purrr::map(author_list, author_info, pkg = pkg) %>%
purrr::map("comment") %>%
purrr::compact() %>%
length() > 0
print_yaml(list(
all = all,
main = main,
needs_page = more_authors || comments
))
}
default_roles <- function() {
c("aut", "cre", "fnd")
}
pkg_authors <- function(pkg, role = NULL) {
if (pkg$desc$has_fields("Authors@R")) {
authors <- unclass(pkg$desc$get_authors())
} else {
# Just show maintainer
authors <- unclass(utils::as.person(pkg$desc$get_maintainer()))
authors[[1]]$role <- "cre"
}
if (is.null(role)) {
authors
} else {
purrr::keep(authors, ~ any(.$role %in% role))
}
}
data_home_sidebar_authors <- function(pkg = ".") {
pkg <- as_pkgdown(pkg)
roles <- pkg$meta$authors$sidebar$roles %||% default_roles()
data <- data_authors(pkg, roles)
authors <- data$main %>% purrr::map_chr(author_desc, comment = FALSE)
bullets <- c(
markdown_text_inline(
pkg$meta$authors$sidebar$before,
pkgdown_field(pkg, c("authors", "sidebar", "before"))
),
authors,
markdown_text_inline(
pkg$meta$authors$sidebar$after,
pkgdown_field(pkg, c("authors", "sidebar", "after"))
)
)
if (data$needs_page) {
bullets <- c(bullets, a(tr_("More about authors..."), "authors.html"))
}
sidebar_section(tr_("Developers"), bullets)
}
data_authors_page <- function(pkg) {
data <- list(
pagetitle = tr_("Authors"),
authors = data_authors(pkg)$all
)
data$before <- markdown_text_block(pkg$meta$authors$before)
data$after <- markdown_text_block(pkg$meta$authors$after)
return(data)
}
author_name <- function(x, authors, pkg) {
name <- format_author_name(x$given, x$family)
if (!(name %in% names(authors))) {
return(name)
}
author <- authors[[name]]
if (!is.null(author$html)) {
name <- markdown_text_inline(
author$html,
pkgdown_field(pkg, c("authors", name, "html"))
)
}
if (is.null(author$href)) {
name
} else {
a(name, author$href)
}
}
format_author_name <- function(given, family) {
given <- paste(given, collapse = " ")
if (is.null(family)) {
given
} else {
paste0(given, " ", family)
}
}
author_list <- function(x, authors_info = NULL, comment = FALSE, pkg) {
name <- author_name(x, authors_info, pkg = pkg)
roles <- paste0(role_lookup(x$role), collapse = ", ")
substr(roles, 1, 1) <- toupper(substr(roles, 1, 1))
orcid <- purrr::pluck(x$comment, "ORCID")
x$comment <- remove_name(x$comment, "ORCID")
list(
name = name,
roles = roles,
comment = linkify(x$comment),
orcid = orcid_link(orcid)
)
}
author_desc <- function(x, comment = TRUE) {
paste(
x$name,
"<br />\n<small class = 'roles'>", x$roles, "</small>",
if (!is.null(x$orcid)) {
x$orcid
},
if (comment && !is.null(x$comment) && length(x$comment) != 0) {
paste0("<br/>\n<small>(", linkify(x$comment), ")</small>")
}
)
}
orcid_link <- function(orcid) {
if (is.null(orcid)) {
return(NULL)
}
paste0(
"<a href='https://orcid.org/", orcid, "' target='orcid.widget' aria-label='ORCID'>",
"<span class='fab fa-orcid orcid' aria-hidden='true'></span></a>"
)
}
# Derived from:
# db <- utils:::MARC_relator_db
# db <- db[db$usage != "",]
# dput(setNames(tolower(db$term), db$code))
# # and replace creater with maintainer
role_lookup <- function(abbr) {
# CRAN roles are translated
roles <- c(
aut = tr_("author"),
com = tr_("compiler"),
ctr = tr_("contractor"),
ctb = tr_("contributor"),
cph = tr_("copyright holder"),
cre = tr_("maintainer"),
dtc = tr_("data contributor"),
fnd = tr_("funder"),
rev = tr_("reviewer"),
ths = tr_("thesis advisor"),
trl = tr_("translator")
)
# Other roles are left as is
marc_db <- getNamespace("utils")$MARC_relator_db
extra <- setdiff(marc_db$code, names(roles))
roles[extra] <- tolower(marc_db$term[match(extra, marc_db$code)])
out <- unname(roles[abbr])
if (any(is.na(out))) {
missing <- abbr[is.na(out)]
cli::cli_warn("Unknown MARC role abbreviation{?s}: {.field {missing}}")
out[is.na(out)] <- abbr[is.na(out)]
}
out
}
# helpers -----------------------------------------------------------------
remove_name <- function(x, name) {
stopifnot(is.character(name), length(name) == 1)
nms <- names(x)
if (is.null(nms)) {
return(x)
}
out <- x[!(nms %in% name)]
if (all(names(out) == "")) {
names(out) <- NULL
}
out
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.