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