.
obfuscate <- function(s)
sapply(s,
function(e)
paste(sprintf("&#x%x;", as.integer(charToRaw(e))),
collapse = ""))
write_check_flavors_db_as_HTML <-
function(db = check_flavors_db, out = "")
{
if(out == "")
out <- stdout()
else if(is.character(out)) {
out <- file(out, "wt")
on.exit(close(out))
}
if(!inherits(out, "connection"))
stop("'out' must be a character string or connection")
##
## Drop Spec for now ...
db$Spec <- NULL
##
flavors <- rownames(db)
db$Details <-
ifelse(is.na(db$Details),
"",
sprintf(" Details ",
db$Details))
writeLines(c("",
"",
"",
"CRAN Package Check Flavors ",
"",
"
CRAN Package Check Flavors ",
"
",
sprintf("Last updated on %s.",
format(Sys.time(), usetz = TRUE)),
"
",
"
",
"Systems used for CRAN package checking.",
"
",
"
",
paste("",
paste(sprintf(" %s ",
gsub(" ", " ",
c("Flavor", "R Version",
"OS Type", "CPU Type",
"OS Info", "CPU Info",
"Compilers", "LC_CTYPE",
""))),
collapse = " "),
" "),
do.call(sprintf,
c(list(paste("",
paste(rep.int(" %s ",
ncol(db) + 1L),
collapse = " "),
" ")),
list(.valid_HTML_id_attribute(flavors)),
list(flavors),
db)),
"
",
"
Details ", db$Details))
writeLines(c("",
"",
"",
"CRAN Package Check Issue Kinds ",
"",
"
CRAN Package Check Issue Kinds ",
"
",
sprintf("Last updated on %s.",
format(Sys.time(), usetz = TRUE)),
"
",
"
",
paste("",
paste(sprintf(" %s ",
c("Kind", "Description",
"Details")),
collapse = " "),
" "),
do.call(sprintf,
c(list(paste("",
paste(rep.int(" %s ",
ncol(db) + 1L),
collapse = " "),
" ")),
list(.valid_HTML_id_attribute(kinds)),
list(kinds),
db)),
"
",
"
## Short term fix to ensure more consistency in the summaries,
## remove eventually.
summary[, "Flags"] <-
trimws(sub(" *--no-stop-on-test-error", "", summary[, "Flags"]))
##
data.frame(summary, stringsAsFactors = FALSE)
}
check_flavor_timings <-
function(dir =
file.path("~", "tmp", "R.check",
"r-devel-linux-x86_64-debian-gcc"))
{
if(length(grep("windows", basename(dir)))) {
status <- file.path(dir, "PKGS", "Status")
if(!file.exists(status)) return()
status <- read.table(status, header = TRUE)
timings <- status[c("packages", "insttime", "checktime")]
}
else if(length(tfile <- Sys.glob(file.path(dir, "*-times.tab")))) {
## Only get total time in this case, hence return right away.
timings <- read.table(tfile[1L], header = TRUE,
stringsAsFactors = FALSE)
names(timings) <- c("Package", "T_total")
timings$T_install <- NA_real_
timings$T_check <- NA_real_
return(timings)
}
else if(length(grep("macos|osx", basename(dir)))) {
chkinfo_file <- file.path(dir, "PKGS", "00_summary_chkinfo")
if(!file.exists(chkinfo_file)) return()
chkinfo <- read.table(chkinfo_file, sep = "|", header = FALSE)
## For the record ...
names(chkinfo) <-
c("Package", "Version", "chk_result", "has_error",
"has_warnings", "has_notes", "check_start",
"check_duration", "flags")
timings <- list2DF(list(Package = chkinfo$Package,
T_total = chkinfo$check_duration))
timings$T_install <- NA_real_
timings$T_check <- NA_real_
return(timings)
}
else if(file.exists(tfile <- file.path(dir, "timings.csv"))) {
return(read.csv(tfile))
}
else {
t_c <- get_timings_from_timings_files(file.path(dir,
"time_c.out"))
t_i <- get_timings_from_timings_files(file.path(dir,
"time_i.out"))
if(is.null(t_i) || is.null(t_c)) return()
##
## We get error information ('Command exited with non-zero
## status') from both timings files, but currently do not use
## this further.
##
timings <- merge(t_i[c("Package", "T_total")],
t_c[c("Package", "T_total")],
by = "Package", all = TRUE)
}
names(timings) <- c("Package", "T_install", "T_check")
timings$T_total <-
rowSums(timings[, c("T_install", "T_check")], na.rm = TRUE)
timings
}
get_timings_from_timings_files <-
function(tfile)
{
timings_files <- c(tfile, paste(tfile, "prev", sep = "."))
timings_files <- timings_files[file.exists(timings_files)]
if(!length(timings_files)) return()
x <- paste(readLines(timings_files[1L], warn = FALSE),
collapse = "\n")
## Safeguard against possibly incomplete entries.
## (Could there be incomplete ones not at eof?)
is_complete <- grepl("swaps$", x)
x <- unlist(strsplit(x, "swaps(\n|$)"))
if(!is_complete) x <- x[-length(x)]
x <- paste(x, "swaps", sep = "")
## Eliminate 'Command exited with non-zero ...'
bad <- rep("OK", length(x))
bad[grep(": Command (exited|terminated)[^\n]*\n", x)] <- "ERROR"
x <- sub(": Command (exited|terminated)[^\n]*\n", ": ", x)
x <- sub("([0-9])system .*", "\\1", x)
x <- sub("([0-9])user ", "\\1 ", x)
x <- sub(": ", " ", x)
##
## This fails when for some reason there are duplicated entries, so
## let's be nice ...
## con <- textConnection(c("User System", x))
## x <- read.table(con)
##
con <- textConnection(x)
y <- tryCatch(scan(con, list("", 0, 0), quiet = TRUE),
error = function(e) return(NULL))
close(con)
if(is.null(y)) return()
ind <- !duplicated(y[[1L]])
t_u <- y[[2L]][ind]
t_s <- y[[3L]][ind]
data.frame(Package = y[[1L]][ind], Status = bad[ind],
T_user = t_u, T_system = t_s, T_total = t_u + t_s,
stringsAsFactors = FALSE)
}
check_results_db <-
function(dir = file.path("~", "tmp", "R.check"), flavors = NULL)
{
if(is.null(flavors))
flavors <- row.names(check_flavors_db)
flavors <- flavors[file.exists(file.path(dir, flavors))]
verbose <- interactive()
results <- vector("list", length(flavors))
names(results) <- flavors
for(flavor in flavors) {
if(verbose)
message(sprintf("Getting check summary for flavor %s", flavor))
summary <- check_flavor_summary(file.path(dir, flavor))
if(verbose)
message(sprintf("Getting check timings for flavor %s", flavor))
timings <- check_flavor_timings(file.path(dir, flavor))
## Sanitize: if there are no results, skip this flavor.
if(!NROW(summary)) next
results[[flavor]] <- if(is.null(timings))
cbind(Flavor = flavor,
summary, T_check = NA, T_install = NA, T_total = NA)
else
cbind(Flavor = flavor,
merge(summary,
timings[, c("Package", "T_install",
"T_check", "T_total")],
by = "Package", all.x = TRUE))
}
names(results) <- NULL
do.call(rbind, results)
}
check_summary_summary <-
function(results)
{
flavor <- results$Flavor
flavor <- factor(flavor, levels = unique(flavor))
status <- results$Status
## status[status == "NOTE"] <- "OK"
status <- factor(status,
levels = c("OK", "NOTE", "WARN", "ERROR", "FAIL"))
tab <- table(flavor, status)
cbind(tab, Total = rowSums(tab, na.rm = TRUE))
}
check_timings_summary <-
function(results)
{
tab <- aggregate(results[, c("T_check", "T_install", "T_total")],
list(Flavor = results$Flavor), sum, na.rm = TRUE)
out <- as.matrix(tab[, -1L])
rownames(out) <- tab$Flavor
out
}
write_check_results_db_as_HTML <-
function(results, dir = file.path("~", "tmp", "R.check", "web"),
details = NULL, issues = NULL)
{
if(is.null(results)) return()
dir <- path.expand(dir)
if(!file_test("-d", dir))
dir.create(dir, recursive = TRUE)
verbose <- interactive()
## HTMLify checks results.
## First, create a version with hyperlinked *and* commented status
## info (in case a full check was not performed).
## Also add hyperlinked package variable.
## Extract maintainer addresses from Maintainer and create unique
## maintainer ids (valid as HTML ids) from these; replace Maintainer
## by a hmlified version which has the address part obfuscated.
re <- "^[[:space:]]*([^[:space:]].*[^[:space:]])[[:space:]]*(<([^<>@]+)@([^<>@]+)>) *$"
ind <- grepl(re, results$Maintainer)
address <- sub(re, "\\3 at \\4", results$Maintainer)
## Note that this gives an empty address for maintainer 'ORPHANED',
## so that we use 'check_results_.html' for the results page for
## that maintainer.
results$Maintainer_address <- ifelse(ind, address, "")
## Local parts of email addresses are case sensitive in principle,
## but HTML id attribute values are case insensitive. Hence use
## lower case for the ids, and hope for the best.
results$Maintainer_id <-
ifelse(ind,
tolower(.valid_HTML_id_attribute(sprintf("address:%s",
address))),
"")
results$Maintainer <- sub(re, "\\1", results$Maintainer)
results$Maintainer <-
gsub("&", "&", results$Maintainer, fixed = TRUE)
results$Maintainer <-
gsub("<", "<", results$Maintainer, fixed = TRUE)
results$Maintainer <-
gsub(">", ">", results$Maintainer, fixed = TRUE)
results$Maintainer <-
gsub(" ", " ", results$Maintainer, fixed = TRUE)
results$Maintainer[ind] <-
sprintf("%s <%s>",
results$Maintainer[ind],
obfuscate(results$Maintainer_address[ind]))
package <- results$Package
status <-
ifelse(is.na(results$Status) | is.na(results$Flags), "",
paste(results$Status,
ifelse(nzchar(results$Flags), "*", ""),
sep = ""))
if(length(ind <- grep("^OK", status)))
status[ind] <- sprintf("%s ",
status[ind])
if(length(ind <- grep("^NOTE", status)))
status[ind] <- sprintf("%s ",
status[ind])
if(length(ind <- grep("^(WARN|ERROR|FAIL)", status)))
status[ind] <- sprintf("%s ",
status[ind])
if(length(ind <- nzchar(status)))
status[ind] <-
paste("",
status[ind],
" ",
sep = "")
##
## sprintf() now is optimized for a length one format string.
##
## Using
## sprintf("%s ",
## check_log_URL, results$Flavor[ind],
## package[ind], status[ind])
## is much clearer, but apparently also much slower ...
##
## This is because sprintf() is vectorized in its fmt argument, and
## hence coerces its argument for each line. When using factors,
## coerce them to character right away:
## sprintf("%s ",
## check_log_URL, as.character(results$Flavor[ind]),
## package[ind], status[ind])
##
##
##
results <-
cbind(results,
Hyperpack =
sprintf("%s Status summary:
",
check_summary_html_summary(results)),
out)
writeLines(paste("",
"",
"Results by maintainer ",
" ",
"
"),
out)
writeLines(paste("",
"",
"Results by package ",
" ",
"
"),
out)
writeLines(check_summary_html_footer(), out)
close(out)
## Create check summary details by maintainer.
out <- file(file.path(dir, "check_summary_by_maintainer.html"), "w")
if(verbose) message("Writing check results summary by maintainer")
writeLines(c(check_summary_html_header(),
paste("",
"",
"Results by package ",
" ",
"
"),
"Results by maintainer:
",
paste("",
"Maintainers can directly adress their results via",
"https://CRAN.R-project.org/web/checks/check_summary_by_maintainer.html#address:id ,",
"where id is obtained from the shown email address",
"with all characters different from letters, digits, hyphens,",
"underscores, colons, and periods replaced by underscores.",
"
",
"",
"Alternatively, they can use the individual maintainer",
"results pages linked to from the maintainer fields.",
"
",
"",
"Results with asterisks (*) indicate that checking",
"was not fully performed.",
"
"),
check_results_html_details_by_maintainer(db),
check_summary_html_footer()),
out)
close(out)
## Create check summary details by package.
out <- file(file.path(dir, "check_summary_by_package.html"), "w")
if(verbose) message("Writing check results summary by package")
writeLines(c(check_summary_html_header(),
paste("",
"",
"Results by maintainer ",
" ",
"
"),
"Results by package:
",
paste("",
"Results with asterisks (*) indicate that checking",
"was not fully performed.",
"
"),
check_results_html_details_by_package(db),
check_summary_html_footer()),
out)
close(out)
## Remove the comment/flag info from hyperstatus.
results$Hyperstat <- sub("\\*", "", results$Hyperstat)
## Overall check timings summary.
out <- file.path(dir, "check_timings.html")
if(verbose) message(sprintf("Writing %s", out))
write_check_timings_summary_as_HTML(results, out)
## Individual timings for flavors.
for(flavor in unique(results$Flavor)) {
out <- file.path(dir, sprintf("check_timings_%s.html", flavor))
if(verbose) message(sprintf("Writing %s", out))
write_check_timings_for_flavor_as_HTML(results, flavor, out)
}
## Older code had this split according to package ...
issues <- split(issues[-1L], issues[[1L]])
## Results for each package.
write_check_results_for_packages_as_HTML(results, dir, details,
issues)
## Results for each address.
write_check_results_for_addresses_as_HTML(results, dir, details,
issues)
## And finally, a little index.
write_check_index(file.path(dir, "index.html"))
}
check_summary_html_header <-
function()
c("",
"",
"",
"CRAN Package Check Results ",
"",
"
CRAN Package Check Results ",
"
",
sprintf("Last updated on %s.",
format(Sys.time(), usetz = TRUE)),
"
",
"
",
"Results for installing and checking packages",
"using the three current flavors of R on systems running",
"Debian GNU/Linux, Fedora, macOS and Windows.",
"
")
check_summary_html_summary <-
function(results)
{
tab <- check_summary_summary(results)
tab <- tab[ , colSums(tab) > 0, drop = FALSE]
flavors <- rownames(tab)
fmt <- paste("
",
" %s ",
paste(rep.int(" %s ",
ncol(tab)),
collapse = " "),
" Details ",
" ")
c("
",
paste("",
paste("",
c("Flavor", colnames(tab), ""),
" ",
collapse = " "),
" "),
do.call(sprintf,
c(list(fmt,
.valid_HTML_id_attribute(flavors),
flavors),
split(tab, col(tab)),
list(flavors))),
"
")
}
check_results_html_details_by_package <-
function(db)
{
flavors <- intersect(names(db), row.names(check_flavors_db))
fmt <- paste("
",
paste(rep.int(" %s ", length(flavors) + 4L),
collapse = " "),
" ")
package <- db$Package
db <- db[order(package), ]
## Prefer to link to package check results pages (rather than
## package web pages) from the check summaries. To change back, use
## hyperpack <- db[, "Hyperpack"]
hyperpack <- sprintf("
%s ",
package, package)
db$Maintainer <-
sprintf("
%s ",
sub("^address:", "", db$Maintainer_id),
db$Maintainer)
flavors_db <-
check_flavors_db[flavors,
c("Flavor", "OS_type", "CPU_type", "Spec")]
flavors_db$OS_type <- gsub(" ", " ", flavors_db$OS_type)
c("
",
paste("",
" Package ",
" Version ",
paste(do.call(sprintf,
c(list(paste("",
"",
"%s ",
" ",
" "),
.valid_HTML_id_attribute(flavors)),
flavors_db)),
collapse = " "),
" Maintainer ",
" Priority ",
" "),
do.call(sprintf,
c(list(fmt, hyperpack),
db[c("Version", flavors, "Maintainer", "Priority")])),
"
")
}
check_results_html_details_by_maintainer <-
function(db)
{
## Very similar to the above.
## Obviously, this could be generalized ...
flavors <- intersect(names(db), row.names(check_flavors_db))
fmt <- paste("
",
paste(rep.int(" %s ", length(flavors) + 4L),
collapse = " "),
"")
## Drop entries with missing maintainer address.
db <- db[nzchar(db$Maintainer_address), ]
## FIXME:
## Drop entries for orphaned packages.
## db <- db[db$Maintainer != "ORPHANED", ]
## And sort according to maintainer.
db <- db[order(db$Maintainer_address, db$Maintainer), ]
ind <- split(seq_along(db$Maintainer_id), db$Maintainer_id)
nms <- names(ind)
package <- db$Package
## Prefer to link to package check results pages (rather than
## package web pages) from the check summaries. To change back, use
## hyperpack <- db[, "Hyperpack"]
hyperpack <- sprintf("%s ",
paste("",
" Maintainer ",
" Package ",
" Version ",
paste(do.call(sprintf,
c(list(paste("",
"",
"%s ",
" ",
" "),
.valid_HTML_id_attribute(flavors)),
flavors_db)),
collapse = " "),
" Priority ",
" "),
unlist(Map(function(n, i) {
l <- length(i)
do.call(sprintf,
c(list(fmt,
c(sprintf(" id=\"%s\"", n),
rep_len("", l - 1L)),
c(sprintf("%s
")
}
check_summary_html_footer <-
function()
c(" CRAN Package Check Timings ",
"",
"
CRAN Package Check Timings ",
"
",
sprintf("Last updated on %s.",
format(Sys.time(), usetz = TRUE)),
"
",
"
",
"Available overall timings (in seconds) for installing and checking all CRAN packages.",
"
"),
out)
tab <- check_timings_summary(results)
tab <- tab[tab[, "T_total"] > 0, ]
flavors <- rownames(tab)
fmt <- paste("
",
" %s ",
" %.2f ",
" %.2f ",
" %.2f ",
" Details ",
" ")
## For some flavors we only have the total time: show nothing
## instead of 0.00 for the install or check times in this case.
tab <- sprintf(fmt,
.valid_HTML_id_attribute(flavors), flavors,
tab[, "T_check"],
tab[, "T_install"],
tab[, "T_total"],
flavors)
tab <- gsub(" 0.00", " ", tab)
writeLines(c("
",
paste("",
"",
" Flavor ",
" Tcheck ",
" Tinstall ",
" Ttotal ",
" ",
" ",
" "),
"",
tab,
" ",
"
",
"
CRAN Package Check Timings ",
"",
sprintf("
CRAN Package Check Timings for %s ",
flavor),
"
",
sprintf("Last updated on %s.",
format(Sys.time(), usetz = TRUE)),
"
",
"
",
"Timings for installing and checking packages",
sprintf("for %s on a system running %s (CPU: %s).",
check_flavors_db[flavor, "Flavor"],
check_flavors_db[flavor, "OS_kind"],
check_flavors_db[flavor, "CPU_info"]),
"
",
"
",
sprintf("Total seconds: %.2f (%.2f hours).",
sum(db$T_total, na.rm = TRUE),
sum(db$T_total, na.rm = TRUE) / 3600),
"
",
"
",
paste("",
" Package ",
" Ttotal ",
" Tcheck ",
" Tinstall ",
" Status ",
" Flags ",
" "),
do.call(sprintf,
c(list(paste("",
" %s ",
" %.2f ",
" %s ",
" %s ",
" %s ",
" %s ",
" ")),
db[c("Hyperpack", "T_total", "T_check",
"T_install", "Hyperstat", "Flags")])),
"
",
"
CRAN Package Check Results for Package %s ",
package),
"",
sprintf(paste("
CRAN Package Check Results for Package",
" %s ",
" "),
package, package),
"
",
sprintf("Last updated on %s.",
format(Sys.time(), usetz = TRUE)),
"
",
"
",
paste("",
" Flavor ",
" Version ",
" Tinstall ",
" Tcheck ",
" Ttotal ",
" Status ",
" Flags ",
" "),
do.call(sprintf,
c(list(paste("",
"",
" %s ",
" ",
" %s ",
" %s ",
" %s ",
" %s ",
" %s ",
" %s ",
" ")),
list(.valid_HTML_id_attribute(entries$Flavor)),
entries[c("Flavor", "Version",
"T_install", "T_check", "T_total",
"Hyperstat", "Flags")])),
"
",
## FIXME issues
## memtest_notes_for_package_as_HTML(mtnotes),
issues_for_package_as_HTML(issues),
if(length(s <- check_details_for_package_as_HTML(details))) {
c("
Check Details ",
"",
tryCatch(paste(unlist(s), collapse = "\n\n"),
error = function(e) NULL),
"")
},
"
",
htmlify(sprintf("Version: %s\n", tmp$Version)),
"%s
")
})
}
memtest_notes_for_package_as_HTML <-
function(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])
c("",
"Memtest notes:",
paste(sprintf("%s ",
tests, paths, tests),
collapse = "\n"),
"
")
}
## FIXME issues
## issues_for_package_as_HTML <-
## function(x)
## {
## if(!length(x)) return(character())
##
## tests <- x[, "Test"]
## paths <- x[, "Path"]
## ## isdir <- !grepl("-Ex.Rout$", paths)
## ## if(any(isdir))
## ## paths[isdir] <- sprintf("%s/", paths[isdir])
##
## c("",
## "Additional issues:",
## paste(sprintf("%s ",
## tests, paths, tests),
## collapse = "\n"),
## "
")
## }
issues_for_package_as_HTML <-
function(x)
{
if(!length(x)) return(character())
c("",
"",
paste(sprintf("%s
")
}
write_check_results_for_addresses_as_HTML <-
function(results, dir, details, issues)
{
verbose <- interactive()
packages <- lapply(split(results$Package,
sub("^address:", "", results$Maintainer_id)),
function(e) sort(unique(e)))
results <- split(results, factor(results$Package))
details <- split(details, factor(details$Package, names(results)))
addresses <- names(packages)
for(i in seq_along(packages)) {
address <- addresses[i]
out <- file.path(dir, sprintf("check_results_%s.html", address))
if(verbose) message(sprintf("Writing %s ...", out))
packages_for_address <- packages[[i]]
write_check_results_for_address_as_HTML(address,
packages_for_address,
results[packages_for_address],
details[packages_for_address],
issues[packages_for_address],
out)
}
}
write_check_results_for_address_as_HTML <-
function(address, packages, results, details, issues, out = "")
{
maintainer <- results[[1L]][1L, "Maintainer"]
## Summaries.
tab <- do.call(rbind,
lapply(results,
function(r) {
categories <-
c("FAIL", "ERROR", "WARN", "NOTE", "OK")
table(factor(r$Status, categories))
}))
tab <- tab[, colSums(tab) > 0, drop = FALSE]
tab[tab == 0] <- ""
lines <-
c("",
"",
"",
sprintf("CRAN Package Check Results for Maintainer %s ",
maintainer),
"",
"",
sprintf("
CRAN Package Check Results for Maintainer ‘%s’ ",
maintainer),
"
",
sprintf("Last updated on %s.",
format(Sys.time(), usetz = TRUE)),
"
")
##
## This used to conditionalize on length(package) > 1L.
## Scott Chamberlain suggests to always
## provide the summary table.
if(length(packages) > 0L) {
fmt <- paste("",
" %s ",
paste(rep.int(" %s ",
ncol(tab)),
collapse = " "),
" ")
lines <-
c(lines,
"",
paste("",
paste("",
c("Package", colnames(tab)),
" ",
collapse = " "),
" "),
do.call(sprintf,
c(list(fmt,
packages,
packages),
split(tab, col(tab)))),
"
")
}
##
for(package in packages) {
tabp <- tab[package, ]
tabp <- tabp[tabp != ""]
lines <-
c(lines,
sprintf("
Package %s ",
package,
package,
package),
"
",
"Current CRAN status:",
paste(sprintf("%s: %s", names(tabp), tabp),
collapse = ", "),
"
",
## FIXME issues
## memtest_notes_for_package_as_HTML(mtnotes[[package]]),
issues_for_package_as_HTML(issues[[package]]),
if(length(s <-
check_details_for_package_as_HTML(details[[package]]))) {
c(## "
Check Details ",
"",
tryCatch(paste(unlist(s), collapse = "\n\n"),
error = function(e) NULL),
"")
})
}
lines <-
c(lines,
"
",
"",
"Package check summary ",
" ",
"
",
sep = ""),
paste("",
"",
"Package check results by package ",
" ",
"
",
sep = ""),
paste("",
"",
"Package check results by maintainer ",
" ",
"
",
sep = ""),
paste("",
"",
"Package check timings ",
" ",
"
",
sep = ""),
paste("",
"",
"Package check flavors ",
" ",
"
",
sep = ""),
"",
"