Nothing
find_tests_file <- function(pkg.path, tests.dir){
stopifnot(is.character(tests.dir))
checked <- list()
for(one.test.dir in tests.dir){
tests.R <- file.path(pkg.path, one.test.dir, "atime", "tests.R")
if(file.exists(tests.R))return(tests.R)
checked[[one.test.dir]] <- tests.R
}
stop("could not find tests.R file after checking ", paste(checked, collapse=", "))
}
atime_pkg <- function(pkg.path=".", tests.dir=NULL){
## For an example package see
## https://github.com/tdhock/binsegRcpp/blob/another-branch/inst/atime/tests.R
each.sign.rank <- unit <- . <- N <- expr.name <- reference <- fun.name <-
empirical <- q25 <- q75 <- p.str <- p.value <- P.value <-
seconds.limit <- time <- log10.seconds <- seconds <- Test <-
N.factor <- unit.value <- x.str <- NULL
## above to avoid CRAN check NOTE.
pkg.results <- list()
blank.dt.list <- list()
bench.dt.list <- list()
limit.dt.list <- list()
compare.dt.list <- list()
issue <- character()
test.info <- atime_pkg_test_info(pkg.path, tests.dir)
for(Test in names(test.info$test.list)){
atv.call <- test.info$test.call[[Test]]
atime.list <- eval(atv.call, test.info)
pkg.results[[Test]] <- atime.list
best.list <- atime::references_best(atime.list)
ref.dt <- best.list$ref[each.sign.rank==1]
sec.dt <- best.list$meas[unit=="seconds"]
max.dt <- sec.dt[, .(
N.values=.N, max.N=max(N)
), by=.(expr.name)]
compare.name <- intersect(
c('merge-base', test.info$base.name, test.info$CRAN.name),
names(test.info$sha.vec)
)[1]
HEAD.compare <- c(test.info$HEAD.name, compare.name)
sec.HEAD.compare <- sec.dt[expr.name %in% HEAD.compare]
max.HEAD.compare <- sec.HEAD.compare[N==max(N)]
if(is.na(compare.name)){
p.value <- 0
n.factor <- 1
}else if(nrow(max.HEAD.compare)==1){
max.name <- max.HEAD.compare$expr.name
missing.name <- setdiff(HEAD.compare, max.name)
missing.max <- sec.HEAD.compare[expr.name==missing.name, max(N)]
if(missing.name==test.info$HEAD.name){
issue[[Test]] <- paste0(
missing.name,
" stopped early")
}
pred.obj <- predict(best.list)
setkey(pred.obj$pred, expr.name)
pred.compare <- pred.obj$pred[HEAD.compare]
n.factor <- pred.obj$pred[test.info$HEAD.name, N]/pred.obj$pred[compare.name, N]
compare.dt.list[[Test]] <- data.table(
Test, pred.compare[, .(N, expr.name, unit, seconds=unit.value)])
if(is.na(n.factor)){ # can't interpolate, only one data point.
n.factor <- missing.max/max.HEAD.compare$N
compare.dt.list[[Test]] <- sec.HEAD.compare[
, .SD[which.max(N), .(seconds=unlist(time), N)]
, by=expr.name
][
, data.table(Test, N, expr.name, unit="seconds", seconds)
]
}
p.value <- 0
}else{
n.factor <- 1
largest.common.timings <- max.HEAD.compare[
, .(
seconds=as.numeric(time[[1]])
), by=.(N, unit, expr.name)][
, log10.seconds := log10(seconds)
][]
compare.dt.list[[Test]] <- data.table(
Test, largest.common.timings[, .(
N, expr.name, unit, seconds)])
test.args <- list()
for(commit.i in seq_along(HEAD.compare)){
commit.name <- HEAD.compare[[commit.i]]
test.args[[commit.i]] <- largest.common.timings[
expr.name==commit.name, log10.seconds]
}
test.args$alternative <- "greater"
p.value <- do.call(stats::t.test, test.args)$p.value
if(p.value < test.info$pval.thresh){
issue[[Test]] <- sprintf(
"%s slower P<%s",
test.info$HEAD.name,
paste(test.info$pval.thresh))
}
}
hline.df <- with(atime.list, data.frame(seconds.limit, unit="seconds"))
limit.dt.list[[Test]] <- data.table(Test, hline.df)
bench.dt.list[[Test]] <- data.table(
Test, p.value, n.factor, best.list$meas)
log10.range <- range(log10(atime.list$meas$N))
expand <- diff(log10.range)*test.info$expand.prop
xmax <- 10^(log10.range[2]+expand)
blank.dt.list[[Test]] <- data.table(Test, best.list$meas[1])[, N := xmax]
gg <- ggplot2::ggplot()+
ggplot2::ggtitle(Test)+
ggplot2::theme_bw()+
ggplot2::facet_grid(unit ~ expr.name, scales="free")+
ggplot2::geom_hline(ggplot2::aes(
yintercept=seconds.limit),
color="grey",
data=hline.df)+
ggplot2::geom_line(ggplot2::aes(
N, reference, group=paste(expr.name, fun.name)),
color="grey50",
data=ref.dt)+
ggplot2::scale_color_manual(values=test.info$version.colors)+
ggplot2::scale_fill_manual(values=test.info$version.colors)+
ggplot2::geom_line(ggplot2::aes(
N, empirical, color=expr.name),
data=best.list$meas)+
ggplot2::geom_ribbon(ggplot2::aes(
N, ymin=q25, ymax=q75, fill=expr.name),
data=best.list$meas[unit=="seconds"],
alpha=0.5)+
ggplot2::scale_x_log10()+
ggplot2::scale_y_log10("median line, quartiles band")+
directlabels::geom_dl(ggplot2::aes(
N, reference, label.group=paste(expr.name, fun.name), label=fun.name),
data=ref.dt,
color="grey",
method="bottom.polygons")+
directlabels::geom_dl(ggplot2::aes(
N, empirical, color=expr.name, label=expr.name),
method="right.polygons",
data=best.list$meas)+
ggplot2::theme(legend.position="none")+
ggplot2::coord_cartesian(xlim=c(NA,xmax))
out.png <- file.path(
dirname(test.info$tests.R),
paste0(gsub('[\':\\ /*|<>"?\n\r]', "_", Test), ".png"))
grDevices::png(out.png, width=test.info$width.in*nrow(max.dt), height=test.info$height.in, units="in", res=100)
suppressWarnings(print(gg))
grDevices::dev.off()
}
num2fac <- function(x.num){
x.dt <- data.table(x.num, x.str=sprintf("%.2e", x.num))
levs <- x.dt[order(x.num), unique(x.str)]
factor(x.dt$x.str, levs)
}
bench.dt <- setkey(rbindlist(bench.dt.list)[, let(
P.value = num2fac(p.value),
N.factor = num2fac(n.factor)
)], N.factor, p.value)
meta.dt <- unique(bench.dt[, .(Test, N.factor, P.value)])
tests.RData <- sub("R$", "RData", test.info$tests.R)
install.seconds <- sapply(pkg.results, "[[", "install.seconds")
cat(
sum(install.seconds),
file=file.path(dirname(tests.RData), "install_seconds.txt"))
## create all and preview facet PNGs.
N.tests <- length(test.info$test.list)
out_N_list <- list(
all=N.tests,
preview=min(N.tests, test.info$N.tests.preview))
for(N_name in names(out_N_list)){
N_int <- out_N_list[[N_name]]
N_meta <- meta.dt[1:N_int]
limit.dt <- rbindlist(limit.dt.list)[N_meta, on="Test", nomatch=0L]
blank.dt <- rbindlist(blank.dt.list)[N_meta, on="Test", nomatch=0L]
compare.dt <- if(length(compare.dt.list))rbindlist(compare.dt.list)[N_meta, on="Test", nomatch=0L]
issues.dt <- if(length(issue))data.table(issue, Test=names(issue))[N_meta, on="Test", nomatch=0L]
N_bench <- bench.dt[N_meta, on="Test", nomatch=0L]
## Plot only compare.dt
##ggplot()+geom_point(aes(seconds, expr.name), shape=1, data=compare.dt)+facet_grid(. ~ P.value + Test, labeller=label_both, scales="free")+scale_x_log10()
gg <- ggplot2::ggplot()+
ggplot2::ggtitle(sprintf(
"%d test cases (%s), ordered by N.factor (max_N_HEAD/max_N_%s) and P.value (T-test)",
N_int, N_name, compare.name))+
ggplot2::theme_bw()+
ggplot2::geom_hline(ggplot2::aes(
yintercept=seconds.limit),
color="grey",
data=limit.dt)+
ggplot2::scale_color_manual(values=test.info$version.colors)+
ggplot2::scale_fill_manual(values=test.info$version.colors)+
ggplot2::facet_grid(
unit ~ N.factor + P.value + Test, scales="free", labeller="label_both")+
ggplot2::geom_line(ggplot2::aes(
N, empirical, color=expr.name),
data=N_bench)+
ggplot2::geom_blank(ggplot2::aes(
N, empirical),
data=blank.dt)+
ggplot2::geom_ribbon(ggplot2::aes(
N, ymin=q25, ymax=q75, fill=expr.name),
data=N_bench[unit=="seconds"],
alpha=0.5)+
ggplot2::scale_x_log10()+
ggplot2::scale_y_log10("median line, quartiles band")+
ggplot2::theme(legend.position="none")
if(length(compare.dt.list)){
gg <- gg+ggplot2::geom_point(ggplot2::aes(
N, seconds, color=expr.name),
shape=1,
data=compare.dt)
}
if(length(issue)){
gg <- gg+ggplot2::geom_label(ggplot2::aes(
0, 0,
label=issue),
hjust=0,
vjust=0,
alpha=0.5,
data=data.table(issues.dt, unit="seconds"))
}
gg <- gg+directlabels::geom_dl(ggplot2::aes(
N, empirical, color=expr.name, label=expr.name),
method="right.polygons",
data=N_bench)
out.png <- file.path(
dirname(test.info$tests.R),
sprintf("tests_%s_facet.png", N_name))
grDevices::png(
out.png,
width=test.info$width.in*N_int,
height=test.info$height.in,
units="in",
res=100)
suppressWarnings(print(gg))
grDevices::dev.off()
if(N_name=="all"){
save(
pkg.results, bench.dt, limit.dt, test.info, blank.dt,
file=tests.RData)
if(length(issue)){
markdown <- issues.dt[, sprintf(
"* %s for `%s`",
issue,
Test)]
markdown_text <- paste(markdown, collapse="\n")
}else{
markdown_text <- paste0("No obvious timing issues in ", test.info$HEAD.name)
}
cat(
markdown_text,
file=file.path(dirname(tests.RData), "HEAD_issues.md"))
}
}
pkg.results
}
default.version.colors <- c(#RColorBrewer::brewer.pal(7, "Dark2")
HEAD="#1B9E77",
base="#D95F02",
"merge-base"="#7570B3",
CRAN="#E7298A",
Before="#66A61E",
Regression="#E6AB02", Slow="#E6AB02",
Fixed="#A6761D", Fast="#A6761D"
)
atime_pkg_test_info <- function(pkg.path=".", tests.dir=NULL){
if(is.null(tests.dir)){
tests.dir <- c("inst",".ci")
}
test.env <- new.env()
test.env$tests.R <- find_tests_file(pkg.path, tests.dir)
tests.parsed <- parse(test.env$tests.R)
eval(tests.parsed, test.env)
default.list <- list(
pval.thresh=0.01,
N.tests.preview=4,
width.in=4,
height.in=8,
expand.prop=0.5,
version.colors=default.version.colors)
for(var.name in names(default.list)){
if(is.null(test.env[[var.name]])){
test.env[[var.name]] <- default.list[[var.name]]
}
}
pkg.DESC <- file.path(pkg.path, "DESCRIPTION")
DESC.mat <- read.dcf(pkg.DESC)
Package <- DESC.mat[,"Package"]
ap <- utils::available.packages()
repo <- git2r::repository(pkg.path)
HEAD.commit <- git2r::revparse_single(repo, "HEAD")
sha.vec <- c()
HEAD.name <- paste0("HEAD=",git2r::repository_head(repo)$name)
sha.vec[[HEAD.name]] <- git2r::sha(HEAD.commit)
if(Package %in% rownames(ap)){
CRAN.name <- paste0("CRAN=",ap[Package,"Version"])
sha.vec[[CRAN.name]] <- ""
}else{
CRAN.name <- NA_character_
}
base.ref <- Sys.getenv("GITHUB_BASE_REF", "master")
base.commit <- tryCatch({
git2r::revparse_single(repo, base.ref)
}, error=function(e){
NULL
})
base.name <- paste0("base=",base.ref)
if(git2r::is_commit(base.commit)){
add_if_new <- function(name, commit.obj){
sha <- git2r::sha(commit.obj)
if(!sha %in% sha.vec){
sha.vec[[name]] <<- sha
}
}
add_if_new(base.name, base.commit)
mb.commit <- git2r::merge_base(HEAD.commit, base.commit)
add_if_new("merge-base", mb.commit)
}
abbrev2name <- c(
HEAD=HEAD.name,
base=base.name,
CRAN=CRAN.name)
test.env$HEAD.name <- HEAD.name
test.env$base.name <- base.name
test.env$CRAN.name <- CRAN.name
names(test.env$version.colors) <- ifelse(
names(test.env$version.colors) %in% names(abbrev2name),
abbrev2name[names(test.env$version.colors)],
names(test.env$version.colors))
common.args <- list(
N.env.parent=test.env,
pkg.path=pkg.path,
sha.vec=sha.vec)
test.env$sha.vec <- sha.vec
test.env$test.list <- inherit_args(test.env$test.list, common.args)
test.env$test.call <- list()
for(Test in names(test.env$test.list)){
test.env$test.call[[Test]] <- as.call(c(
quote(atime::atime_versions),
test.env$test.list[[Test]]))
}
test.env
}
get_test_args <- function(){
s.parent <- sys.parent()
pfun <- sys.function(s.parent)
two.funs <- list(pfun, atime_versions)
name.vecs <- lapply(two.funs, function(f)names(formals(f)))
could.copy <- Reduce(intersect, name.vecs)
mc <- as.list(match.call(pfun, sys.call(s.parent))[-1])
common.names <- intersect(names(mc), could.copy)
possible.uneval <- c("setup","expr")
uneval.names <- intersect(common.names, possible.uneval)
eval.names <- setdiff(common.names, possible.uneval)
p.frame <- parent.frame()
test.args <- mget(eval.names, p.frame)
test.args[uneval.names] <- mc[uneval.names]
test.args
}
atime_test <- function(N, setup, expr, times, seconds.limit, verbose, pkg.edit.fun, result, ...){
c(get_test_args(), ...)
}
atime_test_list <- function(N, setup, expr, times, seconds.limit, verbose, pkg.edit.fun, result, tests=NULL, ...){
common.args <- get_test_args()
L <- c(tests, list(...))
inherit_args(L, common.args)
}
inherit_args <- function(L, common.args){
out <- list()
for(L.i in seq_along(L)){
test.args <- L[[L.i]]
Test <- names(L)[[L.i]]
if(!is.null(test.args)){
out.args <- common.args
out.args[names(test.args)] <- test.args
out[[Test]] <- out.args
}
}
out
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.