.
obfuscate <- function(s)
sapply(s,
function(e)
paste(sprintf("%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)),
"
",
"
",
"",
""),
out)
}
write_check_issue_kinds_db_as_HTML <-
function(db = check_issue_kinds_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")
kinds <- rownames(db)
db$Details <-
ifelse(is.na(db$Details),
"",
sprintf(" 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)),
"
",
"
",
"",
""),
out)
}
check_flavor_summary <-
function(dir =
file.path("~", "tmp", "R.check",
"r-devel-linux-x86_64-debian-gcc"),
check_dirs_root = file.path(dir, "PKGS"))
{
if(!file_test("-d", check_dirs_root)) return()
## Just making sure ...
lc_ctype <- Sys.getlocale("LC_CTYPE")
Sys.setlocale("LC_CTYPE", "en_US.UTF-8")
on.exit(Sys.setlocale("LC_CTYPE", lc_ctype))
get_description_fields_as_utf8 <-
function(dfile, fields = c("Version", "Priority", "Maintainer")) {
## Mimick tools:::.read_description(), but always re-encode to
## UTF-8.
meta <- if(file.exists(dfile))
try(read.dcf(dfile,
fields = unique(c(fields, "Encoding")))[1L, ],
silent = TRUE)
else
NULL
## What if this fails? Grr ...
if(inherits(meta, "try-error") || is.null(meta)) {
meta <- rep.int("", length(fields))
names(meta) <- fields
return(meta)
}
if(!is.na(encoding <- meta["Encoding"]))
meta <- iconv(meta, encoding, "UTF-8", sub = "byte")
meta[fields]
}
check_dirs <- list.files(path = check_dirs_root,
pattern = "\\.Rcheck", full.names = TRUE)
check_logs <- file.path(check_dirs, "00check.log")
if(!all(ind <- file.exists(check_logs))) {
check_dirs <- check_dirs[ind]
check_logs <- check_logs[ind]
}
## Want Package, Version, Priority, Maintainer, Status, Flags.
summary <- matrix(character(), nrow = length(check_dirs), ncol = 6L)
fields <- c("Version", "Priority", "Maintainer")
for(i in seq_along(check_dirs)) {
check_dir <- check_dirs[i]
meta <- get_description_fields_as_utf8(file.path(check_dir,
"00package.dcf"))
meta["Maintainer"] <-
trimws(gsub("\n", " ", meta["Maintainer"]))
lines <- read_check_log(check_logs[i], FALSE)
## Alternatives for left and right quotes.
lqa <- "'|\u2018"
rqa <- "'|\u2019"
## Group when used ...
## Re-encode to UTF-8 using the session charset info.
re <- "^\\* using session charset: "
pos <- grep(re, lines, perl = TRUE, useBytes = TRUE)
enc <- if(length(pos))
sub(re, "", lines[pos[1L]], useBytes = TRUE)
else ""
lines <- iconv(lines, enc, "UTF-8", sub = "byte")
if(any(bad <- !validUTF8(lines)))
lines[bad] <- iconv(lines[bad], to = "ASCII", sub = "byte")
## Get header.
re <- sprintf("^\\* this is package (%s)(.*)(%s) version (%s)(.*)(%s)$",
lqa, rqa, lqa, rqa)
pos <- grep(re, lines, perl = TRUE)
if(!length(pos)) {
## This really should not happen ...
status <- flags <- NA_character_
## Perhaps drop at the end?
} else {
pos <- pos[1L]
header <- lines[seq_len(pos - 1L)]
lines <- lines[-seq_len(pos)]
flags <- if(any(startsWith(header,
"* this is a Windows-only package, skipping installation"))) {
"--install=no"
} else {
re <- sprintf("^\\* using options? (%s)(.*)(%s)$", lqa, rqa)
if(length(pos <- grep(re, header, perl = TRUE))) {
sub(re, "\\2", header[pos[1L]], perl = TRUE)
} else ""
}
## See tools:::check_packages_in_dir_results().
pos <- which(startsWith(lines, "* loading checks for arch"))
pos <- pos[pos < length(lines)]
pos <- pos[startsWith(lines[pos + 1L], "** checking")]
if(length(pos))
lines <- lines[-pos]
pos <- which(startsWith(lines, "* checking examples"))
pos <- pos[pos < length(lines)]
pos <- pos[startsWith(lines[pos + 1L],
"** running examples for arch")]
if(length(pos))
lines <- lines[-pos]
pos <- which(startsWith(lines, "* checking tests"))
pos <- pos[pos < length(lines)]
pos <- pos[startsWith(lines[pos + 1L],
"** running tests for arch")]
if(length(pos))
lines <- lines[-pos]
re <- "^\\*\\*? ((checking|creating|running examples for arch|running tests for arch) .*) \\.\\.\\.( (\\[[^ ]*\\]))?( (NOTE|WARNING|ERROR)|)$"
m <- regexpr(re, lines, perl = TRUE)
ind <- (m > 0L)
status <-
if(any(ind)) {
status <- sub(re, "\\6", lines[ind], perl = TRUE)
if(any(status == "")) "FAILURE"
else if(any(status == "ERROR")) "ERROR"
else if(any(status == "WARNING")) "WARNING"
else "NOTE"
} else {
"OK"
}
}
summary[i, ] <-
cbind(tools::file_path_sans_ext(basename(check_dir)),
rbind(meta, deparse.level = 0),
status, flags)
}
colnames(summary) <- c("Package", fields, "Status", "Flags")
##
## 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 = ""))
tag <- character(length(status))
if(length(pos <- grep("^OK", status)))
tag[pos] <- "ok"
if(length(pos <- grep("^NOTE", status)))
tag[pos] <- "yo"
if(length(pos <- grep("^(WARN|ERROR|FAIL)", status)))
tag[pos] <- "ko"
pos <- which(nzchar(status))
if(length(pos))
status[pos] <-
sprintf(" %s ",
tag[pos],
check_log_URL,
results$Flavor[pos],
package[pos],
status[pos])
if(length(pos) < length(status))
status[-pos] <- " "
##
## 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 ",
package, package),
Hyperstat = status)
## Create a "flat" check summary db with one column per flavor.
## Do this here for efficiency in case we want to provide a flat
## summary by maintainer as well.
ind <- !is.na(results$Status)
db <- split(results[ind,
c("Package", "Version",
"Hyperpack", "Hyperstat", "Priority",
"Maintainer",
"Maintainer_address",
"Maintainer_id")],
results$Flavor[ind])
## Eliminate the entries with no check status right away for
## simplicity.
for(i in seq_along(db)) names(db[[i]])[4L] <- names(db)[i]
db <- Reduce(function(x, y) merge(x, y, all = TRUE), db)
## And replace NAs and turn to character.
##
## Need to special case hyperstats now as these need empty table
## cells right away, so
##
## db[] <- lapply(db,
## function(s) {
## ifelse(is.na(s), "",
## if(is.numeric(s)) sprintf("%.2f", s)
## else as.character(s))
## })
##
## no longer works ...
j <- which(names(db) %in% rownames(check_flavors_db))
db[, j] <- lapply(db[, j],
function(s) {
ifelse(is.na(s), " ", s)
})
db[, -j] <- lapply(db[, -j],
function(s) {
ifelse(is.na(s), "",
if(is.numeric(s)) sprintf("%.2f", s)
else as.character(s))
})
##
## Start by creating the check summary HTML file.
out <- file(file.path(dir, "check_summary.html"), "w")
writeLines(check_summary_html_header(), out)
if(verbose) message("Writing check results summary")
writeLines(c("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(c(rep.int(" %s ", 2L),
rep.int("%s", length(flavors)),
rep.int(" %s ", 2L)),
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 %s %s %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(c(rep.int(" %s ", 3L),
rep.int("%s", length(flavors)),
rep.int(" %s ", 1L)),
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 ",
package, package)
flavors_db <-
check_flavors_db[flavors,
c("Flavor", "OS_type", "CPU_type", "Spec")]
flavors_db$OS_type <- gsub(" ", " ", flavors_db$OS_type)
c("
",
paste("",
" Maintainer ",
" Package ",
" Version ",
paste(do.call(sprintf,
c(list(paste("",
"",
"%s %s %s %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 ",
sub("^address:", "", n),
sub(" <", " <",
db[i[1L], "Maintainer"],
fixed = TRUE)),
rep_len("", l - 1L)),
hyperpack[i]),
db[i, c("Version",
flavors,
"Priority")]))
},
nms,
ind),
use.names = FALSE),
"
")
}
check_summary_html_footer <-
function()
c("
",
"",
"")
write_check_timings_summary_as_HTML <-
function(results, out = "")
{
if(!length(results)) return()
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")
writeLines(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,
" ",
"
",
"
",
"",
""),
out)
}
write_check_timings_for_flavor_as_HTML <-
function(results, flavor, out = "")
{
db <- results[results$Flavor == flavor, ]
if(nrow(db) == 0L || all(is.na(db$T_total))) return()
db <- db[order(db$T_total, decreasing = TRUE), ]
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")
## Need to efficiently replace missings in timings and flags.
## (Could we have a missing check time?)
fields <- c("T_check", "T_install", "Flags")
db[fields] <-
lapply(db[fields],
function(s)
ifelse(is.na(s), "",
if(is.numeric(s)) sprintf("%.2f", s)
else as.character(s)))
writeLines(c("",
"",
"",
"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 ",
## FIXME hyperstat
## " %s ",
"%s",
" %s ",
" ")),
db[c("Hyperpack", "T_total", "T_check",
"T_install", "Hyperstat", "Flags")])),
"
",
"
",
"",
""),
out)
}
write_check_results_for_packages_as_HTML <-
function(results, dir, details = NULL, issues = NULL)
{
verbose <- interactive()
## Drop entries with no status.
results <- results[!is.na(results$Status), ]
## Simplify results.
results[] <-
lapply(results,
function(s) {
ifelse(is.na(s), "",
if(is.numeric(s)) sprintf("%.2f", s)
else as.character(s))
})
ind <- split(seq_len(nrow(results)), results$Package)
nms <- names(ind)
details <- split(details, factor(details$Package, nms))
for(i in seq_along(ind)) {
package <- nms[i]
out <- file.path(dir, sprintf("check_results_%s.html", package))
if(verbose) message(sprintf("Writing %s", out))
write_check_results_for_package_as_HTML(package,
results[ind[[i]], ,
drop = FALSE],
details[[package]],
issues[[package]],
out)
}
}
write_check_results_for_package_as_HTML <-
function(package, entries, details, issues, out = "")
{
lines <-
c("",
"",
"",
sprintf("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 ",
## FIXME hyperstat
## " %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"),
error = function(e) NULL),
"")
},
"
",
"",
"")
writeLines(lines, out)
}
check_details_for_package_as_HTML <-
function(d)
{
if(!NROW(d)) return(character())
htmlify <- function(s) {
s <- iconv(s, sub = "byte")
s <- tools:::.replace_chars_by_hex_subs(s, tools:::invalid_HTML_chars_re)
s <- gsub("&", "&", s, fixed = TRUE)
s <- gsub("<", "<", s, fixed = TRUE)
s <- gsub(">", ">", s, fixed = TRUE)
s
}
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")
}
## Regularize fancy quotes.
## Could also try using iconv(to = "ASCII//TRANSLIT"))
txt <- gsub("(\u2018|\u2019)", "'", txt, perl = TRUE)
txt <- gsub("(\u201c|\u201d)", '"', txt, perl = TRUE)
lapply(split(seq_len(NROW(d)), match(txt, unique(txt))),
function(e) {
tmp <- d[e[1L], ]
flags <- tmp$Flags
flavors <- d$Flavor[e]
c("",
htmlify(sprintf("Version: %s", tmp$Version)),
" ",
if(nzchar(flags)) {
c(htmlify(sprintf("Flags: %s", flags)), " ")
},
htmlify(sprintf("Check: %s", tmp$Check)),
" ",
htmlify(sprintf("Result: %s", tmp$Status)),
if(nzchar(tmp$Output)) {
## Changed on 2023-11-24 to use a monospace font
## and preserve whitespace.
## c(sprintf(" %s",
## gsub("\n",
## " \n ",
## htmlify(tmp$Output),
## perl = TRUE)),
## " ")
c("",
paste0(" ",
gsub("\n", "\n ",
htmlify(tmp$Output),
perl = TRUE)),
" ")
} else " ",
sprintf("%s: %s",
if(length(flavors) == 1L) "Flavor"
else "Flavors",
paste(sprintf("%s ",
flavors, tmp$Package, flavors),
collapse = ", ")),
"
")
})
}
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 ", x$href, x$kind),
collapse = "\n"),
"
")
}
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"),
error = function(e) NULL),
"")
})
}
lines <-
c(lines,
"
",
"",
"")
writeLines(lines, out)
}
write_check_index <-
function(out = "")
{
writeLines(c(check_summary_html_header(),
paste("",
"",
"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 = ""),
"",
"