1
2#' @importFrom utils as.person
3
4parse_authors_at_r <- function(x) {
5
6  if (is.null(x) || is.na(x)) return(NULL)
7
8  # Need a connection on R 3.6 and before, because the encoding will
9  # be messed up. Also need to set the input to `unknown`.
10  Encoding(x) <- "unknown"
11  con <- textConnection(x)
12  on.exit(close(con), add = TRUE)
13  out <- tryCatch(
14    eval(parse(con, encoding = "UTF-8")),
15    error = identity
16  )
17
18  if (inherits(out, "error")) NULL else out
19}
20
21
22deparse_authors_at_r <- function(x, package = NULL) {
23  # this is to fix a revdep failure in attachment
24  if (identical(Sys.getenv("_R_CHECK_PACKAGE_NAME_"), "attachment") &&
25      identical(Sys.getenv("TESTTHAT"), "true") &&
26      is.na(Sys.getenv("ATTACHMENT_FIXED", NA_character_))) {
27    return(old_deparse_authors_at_r(x))
28  }
29  fmt <- lapply(unclass(x), deparse_author_at_r)
30  lines <- vapply(fmt, paste, character(1), collapse = "\n    ")
31  if (length(fmt) == 1) {
32    paste0("\n    ", lines)
33  } else {
34    paste0(
35      "c(\n",
36      paste("   ", lines, collapse = ",\n"),
37      "\n  )"
38    )
39  }
40}
41
42deparse_author_at_r <- function(x1) {
43  x1 <- x1[! vapply(x1, is.null, TRUE)]
44  d <- function(n) {
45    if (n %in% names(x1)) fixed_deparse1(x1[[n]]) else ""
46  }
47  hdr <- paste0(
48    "person(",
49    d("given"),
50    if (any(c("family", "middle", "email") %in% names(x1))) ", ",
51    d("family"),
52    if (any(c("middle", "email") %in% names(x1))) ", ",
53    d("middle"),
54    if ("email" %in% names(x1)) ", ",
55    d("email"),
56    if ("role" %in% names(x1)) paste0(", role = ", d("role"))
57  )
58
59  x1 <- x1[setdiff(names(x1), c("given", "family", "middle", "role", "email"))]
60
61  if (length(x1) == 0) {
62    paste0(hdr, ")")
63  } else {
64    c(
65      paste0(hdr, ","),
66      paste0(
67        rep("       ", length(x1)),
68        names(x1), " = ", vapply(x1, fixed_deparse1, ""),
69        c(rep(",", length(x1) - 1), ")")
70      )
71    )
72  }
73}
74
75old_deparse_authors_at_r <- function(x) {
76  fmt <- lapply(unclass(x), old_deparse_author_at_r)
77  if (length(fmt) == 1) {
78    paste0("\n", paste0("    ", fmt[[1]], collapse = "\n"))
79  } else {
80    for (i in seq_along(fmt)) {
81      fmt[[i]] <- paste0("  ", fmt[[i]])
82      fmt[[i]][[length(fmt[[i]])]] <- paste0(fmt[[i]][[length(fmt[[i]])]], ",")
83    }
84    fmt[[1]][[1]] <- sub("^  ", "c(", fmt[[1]][[1]])
85    n <- length(fmt)
86    fmt[[n]][[length(fmt[[n]])]] <- sub(",$", ")", fmt[[n]][[length(fmt[[n]])]])
87    paste0("\n", paste0("    ", unlist(fmt), collapse = "\n"))
88  }
89}
90
91old_deparse_author_at_r <- function(x1) {
92  x1 <- x1[! vapply(x1, is.null, TRUE)]
93  paste0(
94    c("person(", rep("       ", length(x1) - 1)),
95    names(x1), " = ", vapply(x1, fixed_deparse1, ""),
96    c(rep(",", length(x1) - 1), ")")
97  )
98}
99
100set_author_field <- function(authors, which, field, value) {
101  rval <- unclass(authors)
102  for (w in which) rval[[w]][[field]] <- value
103  class(rval) <- class(authors)
104  rval
105}
106
107
108ensure_authors_at_r <- function(obj) {
109  if (! obj$has_fields("Authors@R")) {
110    stop("No 'Authors@R' field!\n",
111         "You can create one with $add_author.\n",
112         "You can also use $coerce_authors_at_r() to change Author fields")
113  }
114}
115
116## Find an author in the Authors@R field, based on a particular
117## specification. E.g. it is enough to give the first name.
118
119search_for_author <- function(authors, given = NULL, family = NULL,
120                              email = NULL, role = NULL, comment = NULL,
121                              orcid = NULL) {
122
123  matching <-
124    ngrepl(given, authors$given) &
125    ngrepl(family, authors$family) &
126    ngrepl(email, authors$email) &
127    ngrepl(role, authors$role) &
128    ngrepl(comment, authors$comment) &
129    ngrepl(orcid, authors$comment)
130
131  list(index = which(matching), authors = authors[matching])
132}
133
134
135idesc_get_authors <- function(self, private, ensure = TRUE) {
136  stopifnot(is_flag(ensure))
137  if (ensure) ensure_authors_at_r(self)
138  parse_authors_at_r(self$get("Authors@R"))
139}
140
141
142idesc_get_author <- function(self, private, role) {
143  stopifnot(is_string(role))
144  if (self$has_fields("Authors@R")) {
145    aut <- self$get_authors()
146    roles <- aut$role
147    ## Broken person() API, vector for 1 author, list otherwise...
148    if (!is.list(roles)) roles <- list(roles)
149    selected <- vapply(roles, function(r) all(role %in% r), TRUE)
150    aut[selected]
151  } else {
152    NULL
153  }
154}
155
156idesc_set_authors <- function(self, private, authors) {
157  stopifnot(is_authors(authors))
158  self$set("Authors@R", deparse_authors_at_r(authors))
159}
160
161check_author_args <- function(given = NULL, family = NULL, email = NULL,
162                              role = NULL, comment = NULL,
163                              orcid = NULL) {
164  stopifnot(
165    is_string_or_null(given),
166    is_string_or_null(family),
167    is_string_or_null(email),
168    is_character_or_null(role),
169    is_named_character_or_null(comment),
170    is_string_or_null(orcid)
171  )
172}
173
174#' @importFrom utils person
175
176idesc_add_author <- function(self, private, given, family, email, role,
177                             comment, orcid = NULL) {
178  check_author_args(given, family, email, role, comment, orcid)
179  orig <- idesc_get_authors(self, private, ensure = FALSE)
180
181  if (!is.null(orcid)) {
182    comment["ORCID"] <- orcid
183  }
184
185  newp <- person(given = given, family = family, email = email,
186                 role = role, comment = comment)
187  new_authors <- if (is.null(orig)) newp else c(orig, newp)
188  self$set_authors(new_authors)
189}
190
191
192idesc_add_role <- function(self, private, role, given, family, email,
193                           comment, orcid = NULL) {
194
195  stopifnot(is.character(role))
196  check_author_args(given, family, email, comment = comment,
197                    orcid = orcid)
198
199  orig <- idesc_get_authors(self, private, ensure = FALSE)
200  wh <- search_for_author(
201    orig, given = given, family = family, email = email, comment = comment,
202    orcid = orcid,
203    role = NULL
204  )
205
206  for (w in wh$index) {
207    orig <- set_author_field(
208      orig,
209      w,
210      "role",
211      unique(c(orig[[w]]$role, role))
212    )
213  }
214
215  self$set_authors(orig)
216}
217
218idesc_add_orcid <- function(self, private, orcid, given, family, email,
219                            comment, role) {
220
221  check_author_args(given = given, family = family,
222                    email = email,
223                    comment = comment,
224                    orcid = orcid, role = role)
225
226  orig <- idesc_get_authors(self, private, ensure = FALSE)
227  wh <- search_for_author(
228    orig, given = given, family = family, email = email, comment = comment,
229    orcid = NULL,
230    role = role
231  )
232
233  if (length(wh$index) > 1) {
234    stop("More than one author correspond to the provided arguments.
235         ORCID IDs have to be distinct.",
236         call. = FALSE)
237  }
238
239  orig <- set_author_field(
240      orig,
241      wh$index,
242      "comment",
243      add_orcid_to_comment(orig[wh$index]$comment,
244                           orcid)
245    )
246
247  self$set_authors(orig)
248}
249
250idesc_del_author <- function(self, private, given, family, email, role,
251                            comment, orcid = NULL) {
252
253  check_author_args(given, family, email, role, comment, orcid)
254
255  orig <- idesc_get_authors(self, private, ensure = FALSE)
256  wh <- search_for_author(
257    orig, given = given, family = family, email = email,
258    comment = comment, orcid = orcid
259  )
260
261  if (length(wh$index) == 0) {
262    desc_message("Could not find author to remove.")
263  } else {
264    au <- if (length(wh$index) == 1) "Author" else "Authors"
265    desc_message(
266      au, "removed: ",
267      paste(wh$authors$given, wh$authors$family, collapse = ", "),
268      "."
269    )
270    self$set_authors(orig[-wh$index])
271  }
272
273  invisible(self)
274}
275
276
277idesc_del_role <- function(self, private, role, given, family, email,
278                          comment, orcid = NULL) {
279
280  stopifnot(is.character(role))
281  check_author_args(given, family, email, role = NULL, comment, orcid)
282
283  orig <- idesc_get_authors(self, private, ensure = FALSE)
284  wh <- search_for_author(
285    orig, given = given, family = family, email = email, comment = comment,
286    orcid = orcid, role = NULL
287  )
288
289  for (w in wh$index) {
290    orig <- set_author_field(
291      orig,
292      w,
293      "role",
294      setdiff(orig[[w]]$role, role)
295    )
296  }
297
298  self$set_authors(orig)
299}
300
301
302idesc_change_maintainer <- function(self, private, given, family, email,
303                                   comment, orcid = NULL) {
304  check_author_args(given, family, email, role = NULL, comment, orcid)
305  ensure_authors_at_r(self)
306  self$del_role(role = "cre")
307  self$add_role(role = "cre", given = given, family = family,
308                email = email, comment = comment, orcid = orcid)
309}
310
311
312#' @importFrom utils tail
313
314idesc_add_me <- function(self, private, role, comment, orcid = NULL) {
315  stopifnot(
316    is_character_or_null(role),
317    is_named_character_or_null(comment),
318    is_string_or_null(orcid)
319  )
320  check_for_package("whoami", "$add_me needs the 'whoami' package")
321
322 # guess ORCID
323  if (is.null(orcid)) {
324    orcid <- Sys.getenv("ORCID_ID")
325    if (orcid == "") {
326      orcid <- NULL
327    }
328  }
329
330  fn <- parse_full_name(whoami::fullname())
331  family <- fn$family
332  given <- fn$given
333  email <- whoami::email_address()
334  self$add_author(given = given, family = family, email = email,
335                  comment = comment, role = role, orcid = orcid)
336}
337
338idesc_add_author_gh <- function(self, private, username, role, comment, orcid = NULL) {
339  stopifnot(
340    is_character_or_null(role),
341    is.character(username),
342    is_named_character_or_null(comment),
343    is_string_or_null(orcid)
344  )
345
346  gh_info <- author_gh(username)
347
348  fn <- parse_full_name(gh_info$name)
349  family <- fn$family
350  given <- fn$given
351  email <- gh_info$email
352  self$add_author(given = given, family = family, email = email,
353                  comment = comment, role = role, orcid = orcid)
354}
355
356author_gh <- function(username) {
357  opt <- getOption("desc.gh_user")
358  if (!is.null(opt)) return(opt)
359  check_for_package("gh", "$add_author_gh needs the 'gh' package")
360  gh::gh("GET /users/:username", username = username)
361}
362
363idesc_get_maintainer <- function(self, private) {
364  if (self$has_fields("Maintainer")) {
365    unname(self$get("Maintainer"))
366  } else if (self$has_fields("Authors@R")) {
367    format(
368      self$get_author(role = "cre"),
369      include = c("given", "family", "email")
370    )
371  } else {
372    NA_character_
373  }
374}
375
376
377idesc_coerce_authors_at_r <- function(self, private) {
378  has_authors_at_r = self$has_fields("Authors@R")
379  has_author = self$has_fields("Author")
380  if (! (has_authors_at_r | has_author) ) {
381    stop("No 'Authors@R' or 'Author' field!\n",
382         "You can create one with $add_author")
383  }
384
385  if ( !has_authors_at_r & has_author) {
386    # Get author field
387    auth = self$get("Author")
388    auth = as.person(auth)
389    auth$role = "aut"
390
391    # Get maintainer field - set creator role
392    man = self$get_maintainer()
393    man = as.person(man)
394    man$role = c("cre")
395
396    # Set author as maintainer
397    auths = man
398
399    # If Maintainer in Author field, remove it and keep the maintainer one
400    # may want to use del_author
401    check_same = function(x) {
402      identical(c(man$given, man$family),
403                c(x$given, x$family))
404    }
405    same_auth = sapply(auth, check_same)
406    auth = auth[!same_auth]
407    if (length(auth) > 0) {
408      auths = c(auths, auth)
409    }
410    self$set_authors(auths)
411  }
412}
413
414
415# helper to add or replace ORCID in comment
416add_orcid_to_comment <- function(comment, orcid){
417
418  comment["ORCID"] <- orcid
419  comment
420}
421
422