Improve checking the ROR IDs.

git-svn-id: https://svn.r-project.org/R/trunk@87641 00db46b3-68df-0310-9c12-caf00c1e9a41

Author: hornik

src/library/tools/R/QC.R

@@ -3901,6 +3901,17 @@ function(aar, strict = FALSE)
                     if(length(ids))
                         out$bad_authors_at_R_field_has_persons_with_dup_ORCID_identifiers <-
                             ids
+                    ids <- .ROR_ID_from_person(aar)
+                    pos <- which(!is.na(ids))
+                    ids <- ids[pos]
+                    pos <- pos[!.ROR_ID_is_valid(ids)]
+                    if(length(pos))
+                        out$bad_authors_at_R_field_has_persons_with_bad_ROR_identifiers <-
+                            format(aar[pos])
+                    ids <- ids[duplicated(ids)]
+                    if(length(ids))
+                        out$bad_authors_at_R_field_has_persons_with_dup_ROR_identifiers <-
+                            ids
                 }
                 if(strict >= 3L) {
                     non_standard_roles <-
@@ -4007,7 +4018,15 @@ function(x)
       if(length(bad <- x[["bad_authors_at_R_field_has_persons_with_dup_ORCID_identifiers"]])) {
           c(gettext("Authors@R field gives persons with duplicated ORCID identifiers:"),
             paste0("  ", bad))
-      }
+      },
+      if(length(bad <- x[["bad_authors_at_R_field_has_persons_with_bad_ROR_identifiers"]])) {
+          c(gettext("Authors@R field gives persons with invalid ROR identifiers:"),
+            paste0("  ", bad))
+      },
+      if(length(bad <- x[["bad_authors_at_R_field_has_persons_with_dup_ROR_identifiers"]])) {
+          c(gettext("Authors@R field gives persons with duplicated ROR identifiers:"),
+            paste0("  ", bad))
+      }      
       )
 }
 
@@ -8203,6 +8222,20 @@ function(dir, localOnly = FALSE, pkgSize = NA)
                 if(length(pos))
                     out$bad_ORCID_iDs <- odb[pos, , drop = FALSE]
             }
+            ## Also check ROR IDs.
+            rdb <- .ROR_ID_db_from_package_sources(dir)
+            if(NROW(rdb)) {
+                ## Only look at things that may be valid: the others are
+                ## complained about elsewhere.
+                ind <- grepl(.ROR_ID_variants_regexp, rdb[, 1L])
+                rdb <- rdb[ind, , drop = FALSE]
+            }
+            if(NROW(rdb) && requireNamespace("curl", quietly = TRUE)) {
+                ids <- .ROR_ID_canonicalize(rdb[, 1L])
+                pos <- which(!.ROR_ID_is_alive(ids))
+                if(length(pos))
+                    out$bad_ROR_IDs <- rdb[pos, , drop = FALSE]
+            }
         }
     }
 
@@ -8984,6 +9017,17 @@ function(x, ...)
                                      collapse = ", "))),
                     collapse = "\n")
           }),
+      fmt(if(length(y <- x$bad_ROR_IDs)) {
+              paste(c(if(NROW(y) > 1L)
+                          "Found the following (possibly) invalid ROR IDs:"
+                      else
+                          "Found the following (possibly) invalid ROR IDs:",
+                      sprintf("  ID: %s\t(from: %s)",
+                              unlist(y[, 1L]),
+                              vapply(y[, 2L], paste, "",
+                                     collapse = ", "))),
+                    collapse = "\n")
+          }),
       fmt(if(length(y <- x$encoding))
               c(sprintf("Package encoding '%s' is deprecated.", y),
                 "Please change to UTF-8 for non-ASCII content.")),

src/library/tools/R/rortools.R

@@ -48,23 +48,31 @@
 
 ### ** .ROR_ID_is_alive
 
-## See <https://ror.readme.io/v2/docs/rest-api>
+.ROR_ID_is_alive <- function(x) {
+    ## For now use HEAD requests for the full ROR ID.
+    ## See <https://ror.readme.io/v2/docs/rest-api> for getting more
+    ## information.
+    ## Assume all given ids are canonical.
+    urls <- sprintf("https://ror.org/%s", x)
+    resp <- .curl_multi_run_worker(urls, nobody = TRUE)
+    vapply(resp, .curl_response_status_code, 0L) == 200L
+}
 
 ### ** ROR_ID_from_person
 
-ROR_ID_from_person <- function(x)
+.ROR_ID_from_person <- function(x)
     vapply(unclass(x),
            function(e) e$comment["ROR"] %||% NA_character_,
            "")
 
-### ** ROR_ID_db_from_package_sources
+### ** .ROR_ID_db_from_package_sources
 
-ROR_ID_db_from_package_sources <-
+.ROR_ID_db_from_package_sources <-
 function(dir, add = FALSE)
 {
-    ids1 <- ROR_ID_from_person(.persons_from_metadata(dir))
+    ids1 <- .ROR_ID_from_person(.persons_from_metadata(dir))
     ids1 <- ids1[!is.na(ids1)]
-    ids2 <- ROR_ID_from_person(.persons_from_citation(dir))
+    ids2 <- .ROR_ID_from_person(.persons_from_citation(dir))
     ids2 <- ids2[!is.na(ids2)]
     db  <- data.frame(ID = c(character(), ids1, ids2),
                       Parent = c(rep_len("DESCRIPTION",