| # File src/library/tools/R/CRANtools.R |
| # Part of the R package, https://www.R-project.org |
| # |
| # Copyright (C) 2014-2017 The R Core Team |
| # |
| # This program is free software; you can redistribute it and/or modify |
| # it under the terms of the GNU General Public License as published by |
| # the Free Software Foundation; either version 2 of the License, or |
| # (at your option) any later version. |
| # |
| # This program is distributed in the hope that it will be useful, |
| # but WITHOUT ANY WARRANTY; without even the implied warranty of |
| # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| # GNU General Public License for more details. |
| # |
| # A copy of the GNU General Public License is available at |
| # https://www.R-project.org/Licenses/ |
| |
| summarize_CRAN_check_status <- |
| function(packages, results = NULL, details = NULL, issues = NULL) |
| { |
| if(is.null(results)) |
| results <- CRAN_check_results() |
| results <- |
| results[!is.na(match(results$Package, packages)) & !is.na(results$Status), ] |
| |
| if(!NROW(results)) { |
| s <- character(length(packages)) |
| names(s) <- packages |
| return(s) |
| } |
| |
| if(any(results$Status != "OK")) { |
| if(is.null(details)) |
| details <- CRAN_check_details() |
| details <- details[!is.na(match(details$Package, packages)), ] |
| ## Remove all ok stubs. |
| details <- details[details$Check != "*", ] |
| ## Remove trailing white space from outputs ... remove eventually |
| ## when this is done on CRAN. |
| details$Output <- sub("[[:space:]]+$", "", details$Output) |
| |
| } else { |
| ## Create empty details directly to avoid the cost of reading |
| ## and subscripting the actual details db. |
| details <- as.data.frame(matrix(character(), ncol = 7L), |
| stringsAsFactors = FALSE) |
| names(details) <- |
| c("Package", "Version", "Flavor", "Check", "Status", "Output", |
| "Flags") |
| } |
| |
| if(is.null(issues)) |
| issues <- CRAN_check_issues() |
| |
| summarize_results <- function(p, r) { |
| if(!NROW(r)) return(character()) |
| tab <- table(r$Status)[c("FAIL", "ERROR", "WARN", "NOTE", "OK")] |
| tab <- tab[!is.na(tab)] |
| paste(c(sprintf("Current CRAN status: %s", |
| paste(sprintf("%s: %s", names(tab), tab), |
| collapse = ", ")), |
| sprintf("See: <https://CRAN.R-project.org/web/checks/check_results_%s.html>", |
| p)), |
| collapse = "\n") |
| } |
| |
| summarize_details <- function(p, d) { |
| if(!NROW(d)) return(character()) |
| |
| pof <- which(names(d) == "Flavor") |
| poo <- which(names(d) == "Output") |
| ## Outputs from checking "whether package can be installed" will |
| ## have a machine-dependent final line |
| ## See ....... for details. |
| ind <- d$Check == "whether package can be installed" |
| if(any(ind)) { |
| d[ind, poo] <- |
| sub("\nSee[^\n]*for details[.]$", "", d[ind, poo]) |
| } |
| txt <- apply(d[-pof], 1L, paste, collapse = "\r") |
| ## Outputs from checking "installed package size" will vary |
| ## according to system. |
| ind <- d$Check == "installed package size" |
| if(any(ind)) { |
| txt[ind] <- |
| apply(d[ind, - c(pof, poo)], |
| 1L, paste, collapse = "\r") |
| } |
| |
| ## Canonicalize fancy quotes. |
| ## Could also try using iconv(to = "ASCII//TRANSLIT")) |
| txt <- .canonicalize_quotes(txt) |
| out <- |
| lapply(split(seq_len(NROW(d)), match(txt, unique(txt))), |
| function(e) { |
| tmp <- d[e[1L], ] |
| flags <- tmp$Flags |
| flavors <- d$Flavor[e] |
| c(sprintf("Version: %s", tmp$Version), |
| if(nzchar(flags)) sprintf("Flags: %s", flags), |
| sprintf("Check: %s, Result: %s", tmp$Check, tmp$Status), |
| sprintf(" %s", |
| gsub("\n", "\n ", tmp$Output, |
| perl = TRUE, useBytes = TRUE)), |
| sprintf("See: %s", |
| paste(sprintf("<https://www.r-project.org/nosvn/R.check/%s/%s-00check.html>", |
| flavors, |
| p), |
| collapse = ",\n "))) |
| }) |
| paste(unlist(lapply(out, paste, collapse = "\n")), |
| collapse = "\n\n") |
| } |
| |
| ## summarize_mtnotes <- function(p, m) { |
| ## if(!length(m)) return(character()) |
| ## tests <- m[, "Test"] |
| ## paths <- m[, "Path"] |
| ## isdir <- !grepl("-Ex.Rout$", paths) |
| ## if(any(isdir)) |
| ## paths[isdir] <- sprintf("%s/", paths[isdir]) |
| ## paste(c(paste("Memtest notes:", |
| ## paste(unique(tests), collapse = " ")), |
| ## sprintf("See: %s", |
| ## paste(sprintf("<https://www.stats.ox.ac.uk/pub/bdr/memtests/%s/%s>", |
| ## tests, |
| ## paths), |
| ## collapse = ",\n "))), |
| ## collapse = "\n") |
| ## } |
| |
| summarize_issues <- function(i) { |
| if(!length(i)) return(character()) |
| ## In principle the hyperrefs can be obtained from the package |
| ## check results page already pointed to by summarize_results(), |
| ## but this is not convenient for plain text processing ... |
| paste(c("Additional issues:", |
| sprintf(" %s <%s>", i$kind, i$href)), |
| collapse = "\n") |
| } |
| |
| summarize <- function(p, r, d, i) { |
| paste(c(summarize_results(p, r), |
| summarize_issues(i), |
| summarize_details(p, d)), |
| collapse = "\n\n") |
| } |
| |
| ## Split according to package. |
| issues <- split(issues[-1L], issues[[1L]]) |
| |
| s <- if(length(packages) == 1L) { |
| summarize(packages, results, details, issues[[packages]]) |
| } else { |
| results <- split(results, factor(results$Package, packages)) |
| details <- split(details, factor(details$Package, packages)) |
| unlist(lapply(packages, |
| function(p) { |
| summarize(p, |
| results[[p]], |
| details[[p]], |
| issues[[p]]) |
| })) |
| } |
| |
| names(s) <- packages |
| class(s) <- "summarize_CRAN_check_status" |
| s |
| } |
| |
| format.summarize_CRAN_check_status <- |
| function(x, header = NA, ...) |
| { |
| if(is.na(header)) header <- (length(x) > 1L) |
| if(header) { |
| s <- sprintf("Package: %s", names(x)) |
| x <- sprintf("%s\n%s\n\n%s", s, gsub(".", "*", s), x) |
| } |
| x |
| } |
| |
| print.summarize_CRAN_check_status <- |
| function(x, ...) |
| { |
| writeLines(paste(format(x, ...), collapse = "\n\n")) |
| invisible(x) |
| } |
| |
| ## Summarize complete CRAN check status according to maintainer. |
| |
| summarize_CRAN_check_status_according_to_maintainer <- |
| function() |
| { |
| pdb <- CRAN_package_db() |
| ind <- !duplicated(pdb[, "Package"]) |
| |
| maintainer <- pdb[, "Maintainer"] |
| maintainer <- tolower(sub(".*<(.*)>.*", "\\1", maintainer)) |
| |
| results <- CRAN_check_results() |
| details <- CRAN_check_details() |
| issues <- CRAN_check_issues() |
| |
| split(format(summarize_CRAN_check_status(pdb[ind, "Package"], |
| results, |
| details, |
| issues), |
| header = TRUE), |
| maintainer[ind]) |
| } |
| |
| CRAN_baseurl_for_src_area <- |
| function() |
| .get_standard_repository_URLs()[1L] |
| |
| ## This allows for partial local mirrors, or to look at a |
| ## more-freqently-updated mirror. |
| CRAN_baseurl_for_web_area <- |
| function() |
| Sys.getenv("R_CRAN_WEB", .get_standard_repository_URLs()[1L]) |
| |
| read_CRAN_object <- |
| function(cran, path) |
| { |
| con <- gzcon(url(sprintf("%s/%s", cran, path), |
| open = "rb")) |
| on.exit(close(con)) |
| readRDS(con) |
| } |
| |
| CRAN_check_results <- |
| function(flavors = NULL) |
| { |
| db <- read_CRAN_object(CRAN_baseurl_for_web_area(), |
| "web/checks/check_results.rds") |
| if(!is.null(flavors)) |
| db <- db[!is.na(match(db$Flavor, flavors)), ] |
| db |
| } |
| |
| CRAN_check_details <- |
| function(flavors = NULL) |
| { |
| db <- read_CRAN_object(CRAN_baseurl_for_web_area(), |
| "web/checks/check_details.rds") |
| if(!is.null(flavors)) |
| db <- db[!is.na(match(db$Flavor, flavors)), ] |
| ## <FIXME> |
| ## Remove eventually ... |
| class(db) <- c("CRAN_check_details", "check_details", "data.frame") |
| ## </FIXME> |
| db |
| } |
| |
| ## Deprecated in 3.4.1 |
| CRAN_memtest_notes <- |
| function() |
| { |
| .Deprecated("CRAN_check_issues") |
| read_CRAN_object(CRAN_baseurl_for_web_area(), |
| "web/checks/memtest_notes.rds") |
| } |
| |
| CRAN_check_issues <- |
| function() |
| read_CRAN_object(CRAN_baseurl_for_web_area(), |
| "web/checks/check_issues.rds") |
| |
| CRAN_package_db <- |
| function() |
| as.data.frame(read_CRAN_object(CRAN_baseurl_for_web_area(), |
| "web/packages/packages.rds"), |
| stringsAsFactors = FALSE) |
| |
| CRAN_aliases_db <- |
| function() |
| read_CRAN_object(CRAN_baseurl_for_src_area(), |
| "src/contrib/Meta/aliases.rds") |
| |
| CRAN_archive_db <- |
| function() |
| read_CRAN_object(CRAN_baseurl_for_src_area(), |
| "src/contrib/Meta/archive.rds") |
| |
| CRAN_current_db <- |
| function() |
| read_CRAN_object(CRAN_baseurl_for_src_area(), |
| "src/contrib/Meta/current.rds") |
| |
| CRAN_rdxrefs_db <- |
| function() |
| read_CRAN_object(CRAN_baseurl_for_src_area(), |
| "src/contrib/Meta/rdxrefs.rds") |
| |
| check_CRAN_mirrors <- |
| function(mirrors = NULL, verbose = FALSE) |
| { |
| retry_upon_error <- function(expr, n = 3L) { |
| i <- 1L |
| repeat { |
| y <- tryCatch(expr, error = identity) |
| if(!inherits(y, "error") || (i >= n)) |
| break |
| i <- i + 1L |
| } |
| y |
| } |
| |
| read_package_db <- function(baseurl) { |
| path <- sprintf("%ssrc/contrib/PACKAGES.gz", baseurl) |
| db <- retry_upon_error({ |
| con <- gzcon(url(path, "rb")) |
| on.exit(close(con)) |
| readLines(con) |
| }) |
| if(inherits(db, "error")) { |
| msg <- sprintf("Reading %s failed with message: %s", |
| path, conditionMessage(db)) |
| return(simpleError(msg)) |
| } |
| db |
| } |
| |
| read_timestamp <- function(baseurl, path) { |
| path <- sprintf("%s%s", baseurl, path) |
| ts <- retry_upon_error(readLines(path)) |
| if(inherits(ts, "error")) { |
| msg <- sprintf("Reading %s failed with message: %s", |
| path, conditionMessage(ts)) |
| return(simpleError(msg)) |
| } |
| as.POSIXct(as.numeric(ts), origin = "1970-01-01") |
| } |
| |
| if_ok <- function(u, v) if(inherits(u, "error")) u else v |
| |
| check_mirror <- function(mirror) { |
| mirror_packages <- read_package_db(mirror) |
| mirror_ts1 <- read_timestamp(mirror, path_ts1) |
| mirror_ts2 <- read_timestamp(mirror, path_ts2) |
| mirror_ts3 <- read_timestamp(mirror, path_ts3) |
| |
| list("PACKAGES" = |
| if_ok(mirror_packages, |
| c("Delta_master_mirror" = |
| sprintf("%d/%d", |
| length(setdiff(master_packages, |
| mirror_packages)), |
| length(master_packages)), |
| "Delta_mirror_master" = |
| sprintf("%d/%d", |
| length(setdiff(mirror_packages, |
| master_packages)), |
| length(mirror_packages)))), |
| "TIME" = |
| if_ok(mirror_ts1, difftime(master_ts1, mirror_ts1)), |
| "TIME_r-release" = |
| if_ok(mirror_ts2, difftime(master_ts2, mirror_ts2)), |
| "TIME_r-old-release" = |
| if_ok(mirror_ts3, difftime(master_ts3, mirror_ts3)) |
| ) |
| } |
| |
| master <- "https://CRAN.R-project.org/" |
| path_ts1 <- "TIME" |
| path_ts2 <- "bin/windows/contrib/r-release/TIME_r-release" |
| path_ts3 <- "bin/windows/contrib/r-old-release/TIME_r-old-release" |
| |
| master_packages <- read_package_db(master) |
| master_ts1 <- read_timestamp(master, path_ts1) |
| master_ts2 <- read_timestamp(master, path_ts2) |
| master_ts3 <- read_timestamp(master, path_ts3) |
| |
| if(is.null(mirrors)) { |
| mirrors <- as.character(utils::getCRANmirrors(all = TRUE)$URL) |
| } |
| |
| results <- lapply(mirrors, |
| function(m) { |
| if(verbose) |
| message(sprintf("Checking %s", m)) |
| suppressWarnings(tryCatch(check_mirror(m), |
| error = identity)) |
| }) |
| names(results) <- mirrors |
| |
| results |
| } |
| |
| CRAN_mirror_maintainers_info <- |
| function(mirrors, db = NULL, collapse = TRUE) |
| { |
| if(is.null(db)) |
| db <- utils::getCRANmirrors(all = TRUE) |
| mirrors <- sort(unique(mirrors)) |
| ind <- match(mirrors, as.character(db$URL)) |
| addresses <- db[ind, "Maintainer"] |
| addresses <- gsub("[[:space:]]*#[[:space:]]*", "@", addresses) |
| to <- unique(unlist(strsplit(addresses, |
| "[[:space:]]*,[[:space:]]*"))) |
| head <- list("To" = to, |
| "CC" = "CRAN@R-project.org", |
| "Subject" = "CRAN mirrors maintained by you", |
| "Reply-To" = "CRAN@R-project.org") |
| if(collapse) { |
| head$To <- paste(head$To, collapse = ",\n ") |
| head <- sprintf("%s: %s", names(head), unlist(head)) |
| } |
| len <- length(addresses) |
| body <- c(if(len > 1L) { |
| "Dear maintainers," |
| } else { |
| "Dear maintainer," |
| }, |
| "", |
| strwrap(paste(if(length(mirrors) > 1L) { |
| "This concerns the following CRAN mirrors" |
| } else { |
| "This concerns the following CRAN mirror" |
| }, |
| "maintained by", |
| if(len > 1L) "one of", |
| "you:")), |
| "", |
| paste0(" ", formatDL(mirrors, addresses, style = "list")) |
| ) |
| list(head = head, body = body) |
| } |
| |
| CRAN_mirror_mirmon_status <- |
| function() |
| { |
| ## See |
| ## <http://www.projects.science.uu.nl/csg/mirmon/mirmon.html#state_file_format>. |
| |
| fields <- |
| c("url", |
| "age", |
| "status_last_probe", |
| "time_last_successful_probe", |
| "probe_history", |
| "state_history", |
| "last_probe") |
| ts_to_POSIXct <- function(ts) { |
| suppressWarnings(as.POSIXct(as.numeric(as.character(ts)), |
| origin = "1970-01-01")) |
| } |
| read_mirmon_state_file <- function(con) { |
| db <- utils::read.table(con, header = FALSE, col.names = fields) |
| db$url <- as.character(db$url) |
| db$age <- ts_to_POSIXct(db$age) |
| db$time_last_successful_probe <- |
| ts_to_POSIXct(db$time_last_successful_probe) |
| db$last_probe <- ts_to_POSIXct(db$last_probe) |
| db$delta <- difftime(Sys.time(), db$age, units = "days") |
| db |
| } |
| state_files <- |
| c("TIME" = "mirror.state", |
| "TIME_r-release" = "mirror_release.state", |
| "TIME_r-old-release" = "mirror_old_release.state") |
| |
| ## Need to always use master for now (the mirrors do not have the |
| ## state files). |
| do.call(rbind, |
| c(Map(function(u, v) { |
| u <- paste0("https://cran.r-project.org/mirmon/state/", u) |
| cbind(read_mirmon_state_file(u), |
| timestamp = v, |
| stringsAsFactors = FALSE) |
| }, |
| state_files, |
| names(state_files)), |
| list(make.row.names = FALSE))) |
| } |
| |
| |
| CRAN_Rd_xref_db_with_expansions <- |
| function() |
| { |
| db <- CRAN_rdxrefs_db() |
| ## Flatten: |
| db <- cbind(do.call(rbind, db), |
| rep.int(names(db), vapply(db, NROW, 0L))) |
| colnames(db) <- c(colnames(db)[1L : 2L], "S_File", "S_Package") |
| unique(cbind(db, .expand_anchored_Rd_xrefs(db))) |
| } |
| |
| CRAN_Rd_xref_available_target_ids <- |
| function() |
| { |
| targets <- lapply(CRAN_aliases_db(), .Rd_available_xref_targets) |
| .Rd_object_id(rep.int(names(targets), lengths(targets)), |
| unlist(targets, use.names = FALSE)) |
| } |
| |
| CRAN_Rd_xref_reverse_dependencies <- |
| function(packages, db = NULL, details = FALSE) |
| { |
| if(is.null(db)) |
| db <- CRAN_Rd_xref_db_with_expansions() |
| y <- split.data.frame(db, db[, "T_Package"])[packages] |
| if(!details) |
| y <- lapply(y, function(e) unique(e[, "S_Package"])) |
| y |
| } |
| |
| CRAN_Rd_xref_problems <- |
| function() |
| { |
| y <- list() |
| |
| db <- CRAN_Rd_xref_db_with_expansions() |
| db <- db[nzchar(db[, "T_Package"]), , drop = FALSE] |
| ## Add ids: |
| db <- cbind(db, |
| T_ID = .Rd_object_id(db[, "T_Package"], db[, "T_File"])) |
| |
| ## Do we have Rd xrefs to current CRAN packages which no longer work? |
| current <- rownames(CRAN_current_db()) |
| db1 <- db[!is.na(match(db[, "T_Package"], current)), , drop = FALSE] |
| y$broken_xrefs_to_current_CRAN_packages <- |
| db1[is.na(match(db1[, "T_ID"], |
| CRAN_Rd_xref_available_target_ids())), , |
| drop = FALSE] |
| |
| ## Do we have Rd xrefs "likely" to archived CRAN packages? |
| ## This is a bit tricky because packages could have been archived on |
| ## CRAN but still be available from somewhere else. The code below |
| ## catches availability in standard repositories, but not in |
| ## additional repositories. |
| repos <- .get_standard_repository_URLs() # CRAN and BioC |
| ## Previous versions used getOption("repos"). |
| archived <- |
| setdiff(names(CRAN_archive_db()), |
| c(rownames(utils::available.packages(filters = list(), |
| repos = repos)), |
| unlist(.get_standard_package_names(), |
| use.names = FALSE))) |
| y$xrefs_likely_to_archived_CRAN_packages <- |
| db[!is.na(match(db[, "T_Package"], archived)), , drop = FALSE] |
| |
| y |
| } |
| |
| .Rd_available_xref_targets <- |
| function(aliases) |
| { |
| ## Argument aliases as obtained from Rd_aliases(), or directly by |
| ## calling |
| ## lapply(rddb, .Rd_get_metadata, "alias") |
| ## on an Rd db. |
| unique(c(unlist(aliases, use.names = FALSE), |
| sub("\\.[Rr]d", "", basename(names(aliases))))) |
| } |
| |
| .Rd_object_id <- |
| function(package, nora) |
| { |
| ## Name OR Alias: nora. |
| sprintf("%s::%s", package, nora) |
| } |
| |
| CRAN_package_maintainers_db <- |
| function() |
| { |
| db <- CRAN_package_db() |
| maintainer <- db[, "Maintainer"] |
| address <- tolower(sub(".*<(.*)>.*", "\\1", maintainer)) |
| maintainer <- gsub("\n", " ", maintainer) |
| data.frame(Package = db[, "Package"], |
| Address = address, |
| Maintainer = maintainer, |
| stringsAsFactors = FALSE) |
| } |
| |
| CRAN_package_maintainers_info <- |
| function(packages, db = NULL, collapse = TRUE) |
| { |
| if(is.null(db)) |
| db <- CRAN_package_maintainers_db() |
| ind <- match(packages, db[, "Package"]) |
| addresses <- db[ind, "Address"] |
| to <- sort(unique(addresses)) |
| head <- list("To" = to, |
| "CC" = "CRAN@R-project.org", |
| "Subject" = "CRAN packages maintained by you", |
| "Reply-To" = "CRAN@R-project.org") |
| if(collapse) { |
| head$To <- paste(head$To, collapse = ",\n ") |
| head <- sprintf("%s: %s", names(head), unlist(head)) |
| } |
| lst <- split(db[ind, "Package"], db[ind, "Maintainer"]) |
| len <- length(addresses) |
| body <- c(if(len > 1L) { |
| "Dear maintainers," |
| } else { |
| "Dear maintainer," |
| }, |
| "", |
| if(length(packages) > 1L) { |
| "This concerns the CRAN packages" |
| } else { |
| "This concerns the CRAN package" |
| }, |
| "", |
| paste(strwrap(paste(sort(packages), collapse = " "), |
| indent = 2L, exdent = 2L), |
| collapse = "\n"), |
| "", |
| paste("maintained by", |
| if(len > 1L) "one of", |
| "you:"), |
| "", |
| paste0(" ", |
| formatDL(vapply(lst, paste, "", collapse = " "), |
| style = "list")) |
| ) |
| list(head = head, body = body) |
| } |
| |
| CRAN_package_reverse_dependencies_and_views <- |
| function(packages) |
| { |
| repos <- getOption("repos") |
| ## Alternatively, use .get_standard_repository_URLs() |
| |
| a <- utils::available.packages(filters = list(), repos = repos) |
| |
| v <- read_CRAN_object(CRAN_baseurl_for_src_area(), |
| "src/contrib/Views.rds") |
| v <- do.call("rbind", |
| mapply(cbind, |
| Package = |
| lapply(v, function(e) e$packagelist$name), |
| View = vapply(v, "[[", "name", FUN.VALUE = ""))) |
| v <- split(v[, 2L], v[, 1L]) |
| |
| r <- package_dependencies(packages, a, reverse = TRUE) |
| rr <- package_dependencies(packages, a, |
| reverse = TRUE, recursive = TRUE) |
| rrs <- package_dependencies(packages, a, "Suggests", |
| reverse = TRUE, recursive = TRUE) |
| |
| ## For formatting reverse dependencies, for now indicate non-CRAN |
| ## ones by adding a '*'. |
| expansions <- unique(c(unlist(r, use.names = FALSE), |
| unlist(rr, use.names = FALSE), |
| unlist(rrs, use.names = FALSE))) |
| names(expansions) <- expansions |
| if("CRAN" %in% names(repos)) { |
| ind <- !startsWith(a[match(expansions, a[, "Package"]), |
| "Repository"], |
| repos["CRAN"]) |
| expansions[ind] <- paste0(expansions[ind], "*") |
| } |
| |
| rxrefs <- CRAN_Rd_xref_reverse_dependencies(packages) |
| |
| fmt <- function(x) { |
| if(length(x)) paste(sort(x), collapse = " ") else NA_character_ |
| } |
| |
| y <- lapply(packages, |
| function(p) { |
| c(Package = p, |
| "Reverse depends" = |
| fmt(expansions[r[[p]]]), |
| "Additional recursive reverse depends" = |
| fmt(expansions[setdiff(rr[[p]], r[[p]])]), |
| "Reverse recursive suggests" = |
| fmt(expansions[rrs[[p]]]), |
| "Reverse Rd xref depends" = |
| fmt(rxrefs[[p]]), |
| "Views" = |
| fmt(v[[p]])) |
| }) |
| y <- as.data.frame(do.call(rbind, y), stringsAsFactors = FALSE) |
| class(y) <- c("CRAN_package_reverse_dependencies_and_views", |
| class(y)) |
| y |
| } |
| |
| format.CRAN_package_reverse_dependencies_and_views <- |
| function(x, ...) |
| { |
| apply(x, 1L, |
| function(e) { |
| paste(formatDL(e[!is.na(e)], |
| style = "list", indent = 2L), |
| collapse = "\n") |
| }) |
| } |
| |
| print.CRAN_package_reverse_dependencies_and_views <- |
| function(x, ...) |
| { |
| writeLines(paste(format(x, ...), collapse = "\n\n")) |
| invisible(x) |
| } |
| |
| CRAN_package_reverse_dependencies_with_maintainers <- |
| function(packages, which = c("Depends", "Imports", "LinkingTo"), |
| recursive = FALSE) |
| { |
| db <- CRAN_package_db() |
| |
| rdepends <- package_dependencies(packages, db, which, |
| recursive = recursive, |
| reverse = TRUE) |
| rdepends <- sort(unique(unlist(rdepends))) |
| pos <- match(rdepends, db[, "Package"], nomatch = 0L) |
| |
| db[pos, c("Package", "Version", "Maintainer")] |
| } |
| |
| CRAN_package_dependencies_with_dates <- |
| function(packages) |
| { |
| repos <- .get_standard_repository_URLs() # CRAN and BioC |
| a <- utils::available.packages(filters = list(), repos = repos) |
| |
| pc <- CRAN_package_db() |
| pb <- NULL # Compute if necessary ... |
| |
| d <- package_dependencies(packages, a, which = "most") |
| ## We currently keep the base packages dependencies, which have no |
| ## date. Hence, filter these out ... |
| base_packages <- .get_standard_package_names()[["base"]] |
| lapply(d, |
| function(e) { |
| e <- setdiff(as.character(e), base_packages) |
| i <- match(e, pc[, "Package"]) |
| d <- pc[i, "Published"] |
| if(any(j <- is.na(i))) { |
| eb <- e[j] |
| if(is.null(pb)) |
| pb <<- BioC_package_db() |
| ib <- match(eb, pb[, "Package"]) |
| d[j] <- pb[ib, "Date/Publication"] |
| e[j] <- paste0(eb, "*") |
| } |
| d <- as.Date(d) |
| o <- order(d, decreasing = TRUE) |
| data.frame(Package = e[o], Date = d[o], |
| stringsAsFactors = FALSE) |
| }) |
| } |
| |
| CRAN_packages_with_maintainer_matching <- |
| function(pattern, ...) |
| { |
| pdb <- CRAN_package_db() |
| ind <- grep(pattern, pdb[, "Maintainer"], ...) |
| pdb[ind, "Package"] |
| } |
| |
| write_texts_to_dir <- |
| function(lst, dir, verbose = FALSE) |
| { |
| dir.create(dir, showWarnings = FALSE, recursive = FALSE) |
| |
| Map(function(m, s) { |
| if(verbose) |
| message(sprintf("Processing %s ...", m)) |
| writeLines(paste(s, collapse = "\n\n"), |
| file.path(dir, sprintf("%s.txt", m))) |
| }, |
| names(lst), |
| lst) |
| |
| invisible() |
| } |
| |
| CRAN_package_URL <- function(p) |
| paste0("https://CRAN.R-project.org/package=", p) |
| |
| CRAN_package_check_URL <- function(p) |
| sprintf("https://CRAN.R-project.org/web/checks/check_results_%s.html", |
| p) |
| |
| BioC_package_db <- |
| function() |
| { |
| urls <- .get_standard_repository_URLs() |
| urls <- urls[startsWith(names(urls), "BioC")] |
| if(!length(urls)) return(NULL) |
| info <- lapply(urls, function(u) { |
| con <- url(paste0(u, "/VIEWS")) |
| on.exit(close(con)) |
| read.dcf(con) |
| }) |
| Reduce(function(u, v) merge(u, v, all = TRUE), |
| lapply(info, |
| as.data.frame, |
| stringsAsFactors = FALSE)) |
| } |
