Implement set_main_contributors()

NAMESPACE

@@ -48,7 +48,6 @@ importFrom(rlang,abort)
 importFrom(rlang,caller_arg)
 importFrom(rlang,caller_env)
 importFrom(rlang,enexprs)
-importFrom(rlang,expr)
 importFrom(rlang,is_bool)
 importFrom(rlang,is_named)
 importFrom(rlang,is_string)
@@ -69,6 +68,7 @@ importFrom(tidyselect,any_of)
 importFrom(tidyselect,starts_with)
 importFrom(vctrs,vec_duplicate_any)
 importFrom(vctrs,vec_group_id)
+importFrom(vctrs,vec_rank)
 importFrom(vctrs,vec_restore)
 importFrom(yaml,as.yaml)
 importFrom(yaml,yaml.load)

R/checkers.R

@@ -64,8 +64,8 @@ are_credit_roles <- function(x) {
   all(x %in% credit_roles()) || all(x %in% credit_roles(FALSE))
 }
 
-dots_are_call <- function(...) {
-  nargs() == 1L && is.call(expr(...))
+are_calls <- function(...) {
+  all(map_vec(enexprs(...), is.call))
 }
 
 search_ <- function(x, callback, na_rm = TRUE, n = 1) {

R/plume-package.R

@@ -14,11 +14,11 @@
 #' @importFrom purrr list_rbind list_transpose list_assign list_modify
 #' @importFrom readr read_file write_lines
 #' @importFrom rlang %||% := abort set_names
-#' @importFrom rlang expr enexprs sym syms
+#' @importFrom rlang enexprs sym syms
 #' @importFrom rlang is_named is_string is_bool is_true
 #' @importFrom rlang caller_env caller_arg
 #' @importFrom glue glue glue_collapse
-#' @importFrom vctrs vec_group_id vec_duplicate_any vec_restore
+#' @importFrom vctrs vec_group_id vec_duplicate_any vec_restore vec_rank
 #' @importFrom jsonlite toJSON parse_json
 #' @importFrom yaml yaml.load as.yaml
 #' @importFrom R6 R6Class

R/plume-quarto.R

@@ -48,7 +48,7 @@
 #' @export
 PlumeQuarto <- R6Class(
   classname = "PlumeQuarto",
-  inherit = StatusSetterQuarto,
+  inherit = StatusSetterPlumeQuarto,
   public = list(
     #' @description Create a `PlumeQuarto` object.
     #' @param data A data frame containing author-related data.

R/plume.R

@@ -1,3 +1,7 @@
+.names_plume <- list_modify(.names, public = list(
+   internals = list(contributor_rank = "contributor_rank")
+ ))
+
 .symbols <- list(
   affiliation = NULL,
   corresponding = "\\*",
@@ -49,7 +53,7 @@
 #' @export
 Plume <- R6Class(
   classname = "Plume",
-  inherit = StatusSetter,
+  inherit = StatusSetterPlume,
   public = list(
     #' @description Create a `Plume` object.
     #' @param data A data frame containing author-related data.
@@ -82,7 +86,8 @@ Plume <- R6Class(
         initials_given_name = FALSE,
         family_name_first = FALSE,
         interword_spacing = TRUE,
-        orcid_icon = orcid()
+        orcid_icon = orcid(),
+        by = NULL
     ) {
       super$initialize(
         data,
@@ -91,7 +96,8 @@ Plume <- R6Class(
         credit_roles,
         initials_given_name,
         family_name_first,
-        interword_spacing
+        interword_spacing,
+        by = NULL
       )
       check_list(symbols, force_names = TRUE)
       check_orcid_icon(orcid_icon)
@@ -245,11 +251,7 @@ Plume <- R6Class(
         out <- mutate(out, !!pars$author := dot(.data[[pars$author]]))
       }
       out <- summarise(out, !!pars$var := enumerate(
-        if (!by_author && alphabetical_order) {
-          sort(.data[[pars$var]])
-        } else {
-          .data[[pars$var]]
-        },
+        contribution_items(pars, by_author, alphabetical_order),
         last = sep_last
       ), .by = all_of(pars$grp_var))
       if (are_credit_roles(private$roles) || private$crt) {
@@ -261,6 +263,7 @@ Plume <- R6Class(
   ),
 
   private = list(
+    plume_names = .names_plume,
     symbols = .symbols,
     orcid_icon = NULL,
 
@@ -301,7 +304,7 @@ Plume <- R6Class(
 
     contribution_pars = function(roles_first, by_author, literal_names) {
       vars <- private$pick(
-        "initials", "literal_name", "role", "id",
+        "initials", "literal_name", "role", "id", "contributor_rank",
         squash = FALSE
       )
       has_initials <- private$has_col(vars$initials)
@@ -325,9 +328,22 @@ Plume <- R6Class(
         has_initials = has_initials,
         author = author,
         grp_var = grp_var,
+        rank = vars$contributor_rank,
         var = var,
         format = format
       )
     }
   )
 )
+
+ contribution_items <- function(pars, by_author, alphabetical_order) {
+   data <- dplyr::pick(any_of(c(pars$var, pars$rank)))
+   cols <- c(
+     if (has_name(data, pars$rank)) pars$rank,
+     if (alphabetical_order) pars$var
+   )
+   if (!is.null(cols) && !by_author) {
+     data <- arrange(data, across(any_of(cols)))
+   }
+   data[[pars$var]]
+ }

R/set-default-names.R

@@ -7,7 +7,7 @@
 #' @details
 #' Available names are:
 #'
-#' `r wrap(list_fetch_all(.names, "public", "orcid", squash = TRUE), "\x60")`.
+#' `r wrap(list_fetch_all(.names_plume, "public", "orcid", squash = TRUE), "\x60")`.
 #'
 #' Using `.plume_quarto = TRUE` adds `deceased`, `equal_contributor`, `number`,
 #' `dropping_particle` and `acknowledgements`.
@@ -42,6 +42,6 @@ set_default_names <- function(..., .plume_quarto = FALSE) {
     arg = "..."
   )
   check_bool(.plume_quarto)
-  nms <- if (.plume_quarto) .names_quarto else .names
+  nms <- if (.plume_quarto) .names_quarto else .names_plume
   list_replace(nms, dots)
 }

R/status-setter.R

@@ -6,9 +6,15 @@ StatusSetter <- R6Class(
   classname = "StatusSetter",
   inherit = PlumeHandler,
   public = list(
-    initialize = function(...) {
+    initialize = function(..., by) {
       super$initialize(...)
-      private$by <- private$pick("id")
+      check_string(by, allow_empty = FALSE, allow_null = TRUE)
+      if (is.null(by)) {
+        private$by <- private$pick("id")
+      } else {
+        private$check_col(by)
+        private$by <- by
+      }
     },
 
     #' @description Set corresponding authors.
@@ -27,38 +33,76 @@ StatusSetter <- R6Class(
     by = NULL,
 
     set_status = function(col, ..., by) {
+      by <- private$snatch_by()
+      binder$bind(private$plume[[by]])
+      private$plume <- mutate(
+        private$plume,
+        !!private$pick(col) := vec_in(.data[[by]], collect_dots(...))
+      )
+      invisible(self)
+    },
+
+    snatch_by = function() {
+      env <- caller_env(2L)
+      by <- env$by %||% env$.by
       if (missing(by)) {
         by <- private$by
       } else {
-        check_string(by, allow_empty = FALSE)
+        arg <- if (is.null(env$by)) ".by" else "by"
+        check_string(by, allow_empty = FALSE, arg = arg)
       }
       private$check_col(by)
-      binder$bind(private$plume[[by]])
-      dots <- if (dots_are_call(...)) c(...) else enexprs(...)
-      private$plume <- mutate(
-        private$plume,
-        !!private$pick(col) := vec_in(.data[[by]], dots)
-      )
+      by
+    }
+  )
+)
+
+#' @title StatusSetterPlume class
+#' @description Internal class extending `StatusSetter` for `Plume`.
+StatusSetterPlume <- R6Class(
+  classname = "StatusSetterPlume",
+  inherit = StatusSetter,
+  public = list(
+    #' @description Force one or more contributors' names to appear first in the
+    #'   contribution list.
+    #' @param ... One or more unquoted expressions separated by commas.
+    #'   Expressions matching values in the column defined by `by`/`.by`
+    #'   determine main contributors. Expressions can be named after any role to
+    #'   set different main contributors to different roles at once, in which
+    #'   case the `.roles` parameter will be ignored. Matching of values is
+    #'   case-insensitive.
+    #' @param .roles Roles to assign main contributors to.
+    #' @param .by Variable used to specify which authors are equal contributors.
+    #'   By default, uses authors' id.
+    #' @return The class instance.
+    set_main_contributors = function(..., .roles = NULL, .by) {
+      private$set_ranks(..., .roles = .roles, .by = .by)
+    }
+  ),
+
+  private = list(
+    set_ranks = function(..., .roles, .by) {
+      check_character(.roles, allow_duplicates = FALSE)
+      by <- private$snatch_by()
+      vars <- private$pick("role", "contributor_rank", squash = FALSE)
+      dots <- collect_dots(...)
+      if (!is_named(dots)) {
+        dots <- assign_to_names(dots, names = .roles)
+      }
+      out <- unnest(private$plume, col = all_of(vars$role))
+      out <- add_contribution_ranks(out, dots, private$roles, by, vars)
+      private$plume <- nest(out, !!vars$role := squash(vars))
       invisible(self)
     }
   )
 )
 
 #' @title StatusSetterQuarto class
 #' @description Internal class extending `StatusSetter` for `PlumeQuarto`.
-StatusSetterQuarto <- R6Class(
+StatusSetterPlumeQuarto <- R6Class(
   classname = "StatusSetterQuarto",
   inherit = StatusSetter,
   public = list(
-    initialize = function(..., by) {
-      super$initialize(...)
-      check_string(by, allow_empty = FALSE, allow_null = TRUE)
-      if (!is.null(by)) {
-        private$check_col(by)
-        private$by <- by
-      }
-    },
-
     #' @description Set equal contributors.
     #' @param ... One or more unquoted expressions separated by commas.
     #'   Expressions matching values in the column defined by `by` determine

R/utils-tbl.R

@@ -72,6 +72,25 @@ add_orcid_links <- function(data, orcid, compact = FALSE) {
   data
 }
 
+add_contribution_ranks <- function(data, values, roles, by, cols) {
+  data <- col_init(data, cols$contributor_rank)
+  iwalk(values, \(value, key) {
+    data[cols$contributor_rank] <<- if_else(
+      is_not_na(roles[key]) & data[[cols$role]] == roles[key],
+      rank(data[[by]], value),
+      data[[cols$contributor_rank]]
+    )
+  })
+  data
+}
+
+col_init <- function(data, name) {
+  if (!has_name(data, name)) {
+    data[name] <- NA
+  }
+  data
+}
+
 assign_roles <- function(data, roles) {
   data
   iwalk(roles, \(value, key) {

R/utils.R

@@ -54,6 +54,31 @@ vec_in <- function(x, y, ignore_case = TRUE) {
   x %in% y
 }
 
+vec_match <- function(x, y, ignore_case = TRUE) {
+  if (ignore_case) {
+    x <- tolower(x)
+    y <- tolower(y)
+  }
+  match(x, y)
+}
+
+rank <- function(x, base) {
+  matches <- vec_match(x, base)
+  vec_rank(matches, ties = "dense")
+}
+
+assign_to_names <- function(x, names) {
+  x <- rep(list(x), length(names))
+  set_names(x, names)
+}
+
+collect_dots <- function(...) {
+  if (are_calls(...)) {
+    return(c(...))
+  }
+  enexprs(...)
+}
+
 condense <- function(x) {
   vec_drop_na(unique(x))
 }