Skip to content

Commit

Permalink
tests_preview_facet.png
Browse files Browse the repository at this point in the history
  • Loading branch information
@tdhock
tdhock committed Sep 26, 2024
1 parent 45e74f2 commit ea4103f
Show file tree
Hide file tree
Showing 5 changed files with 118 additions and 87 deletions.
2 changes: 1 addition & 1 deletion DESCRIPTION
View file
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
Package: atime
Type: Package
Title: Asymptotic Timing
Version: 2024.9.23
Version: 2024.9.25
Authors@R: c(
person("Toby", "Hocking",
email="[email protected]",
Expand Down
4 changes: 4 additions & 0 deletions NEWS
View file
Original file line number Diff line number Diff line change
@@ -1,3 +1,7 @@
Changes in version 2024.9.25

- atime_pkg creates tests_preview_facet.png if N.tests.preview (default 4, can be defined in atime/tests.R) is less than the number of test cases. It should be informative even when zoomed out, since it shows only the test cases which had smallest p-values (most significant differences between HEAD and min). Recommended for display as thumbnail/preview image with links to the larger tests_preview_all.png that includes all test results (which may not be readable/informative unless you zoom/scroll, if there are 10+ tests).

Changes in version 2024.9.23

- atime_pkg_test_info returns un-evaluated calls to atime_versions, to make it easier to run one test at a time.
Expand Down
154 changes: 85 additions & 69 deletions R/test.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -22,10 +22,10 @@ atime_pkg <- function(pkg.path=".", tests.dir=NULL){
limit.dt.list <- list()
compare.dt.list <- list()
test.info <- atime_pkg_test_info(pkg.path, tests.dir)
for(test.name in names(test.info$test.list)){
atv.call <- test.info$test.call[[test.name]]
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.name]] <- atime.list
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"]
Expand All @@ -42,8 +42,8 @@ atime_pkg <- function(pkg.path=".", tests.dir=NULL){
expr.name %in% HEAD.compare, .(
seconds=as.numeric(time[[1]])
), by=.(N, unit, expr.name)][, log10.seconds := log10(seconds)][]
compare.dt.list[[test.name]] <- data.table(
test.name, largest.common.timings)
compare.dt.list[[Test]] <- data.table(
Test, largest.common.timings)
test.args <- list()
for(commit.i in seq_along(HEAD.compare)){
commit.name <- HEAD.compare[[commit.i]]
Expand All @@ -53,17 +53,17 @@ atime_pkg <- function(pkg.path=".", tests.dir=NULL){
test.args$alternative <- "greater"
p.value <- do.call(stats::t.test, test.args)$p.value
hline.df <- with(atime.list, data.frame(seconds.limit, unit="seconds"))
limit.dt.list[[test.name]] <- data.table(test.name, hline.df)
bench.dt.list[[test.name]] <- data.table(
test.name, p.value, best.list$meas)
limit.dt.list[[Test]] <- data.table(Test, hline.df)
bench.dt.list[[Test]] <- data.table(
Test, p.value, 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)
one.blank <- data.table(test.name, best.list$meas[1])
one.blank <- data.table(Test, best.list$meas[1])
one.blank[, N := xmax]
blank.dt.list[[test.name]] <- one.blank
blank.dt.list[[Test]] <- one.blank
gg <- ggplot2::ggplot()+
ggplot2::ggtitle(test.name)+
ggplot2::ggtitle(Test)+
ggplot2::theme_bw()+
ggplot2::facet_grid(unit ~ expr.name, scales="free")+
ggplot2::geom_hline(ggplot2::aes(
Expand Down Expand Up @@ -98,72 +98,87 @@ atime_pkg <- function(pkg.path=".", tests.dir=NULL){
ggplot2::coord_cartesian(xlim=c(NA,xmax))
out.png <- file.path(
dirname(test.info$tests.R),
paste0(gsub("[: /]", "_", test.name), ".png"))
paste0(gsub("[: /]", "_", Test), ".png"))
grDevices::png(out.png, width=test.info$width.in*nrow(max.dt), height=test.info$height.in, units="in", res=100)
print(gg)
grDevices::dev.off()
}
bench.dt <- rbindlist(bench.dt.list)[, Test := test.name]
bench.dt <- rbindlist(bench.dt.list)
setkey(bench.dt, p.value)
bench.dt[, p.str := sprintf("%.2e", p.value)]
bench.dt[, P.value := factor(p.str, unique(p.str))]
meta.dt <- unique(bench.dt[, .(Test, test.name, P.value)])
limit.dt <- rbindlist(limit.dt.list)[meta.dt, on="test.name"]
blank.dt <- rbindlist(blank.dt.list)[meta.dt, on="test.name"]
compare.dt <- rbindlist(compare.dt.list)[meta.dt, on="test.name"]
meta.dt <- unique(bench.dt[, .(Test, 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"))
save(
pkg.results, bench.dt, limit.dt, test.info, blank.dt,
file=tests.RData)
## create all and preview facet PNGs.
N.tests <- length(test.info$test.list)
gg <- ggplot2::ggplot()+
ggplot2::ggtitle(paste(
N.tests,
"test cases, ordered by p-value (T-test, HEAD>min, dots show data tested)"))+
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 ~ P.value + Test, scales="free", labeller="label_both")+
ggplot2::geom_line(ggplot2::aes(
N, empirical, color=expr.name),
data=bench.dt)+
ggplot2::geom_blank(ggplot2::aes(
N, empirical),
data=blank.dt)+
ggplot2::geom_ribbon(ggplot2::aes(
N, ymin=q25, ymax=q75, fill=expr.name),
data=bench.dt[unit=="seconds"],
alpha=0.5)+
ggplot2::geom_point(ggplot2::aes(
N, seconds, color=expr.name),
shape=1,
data=compare.dt)+
ggplot2::scale_x_log10()+
ggplot2::scale_y_log10("median line, quartiles band")+
directlabels::geom_dl(ggplot2::aes(
N, empirical, color=expr.name, label=expr.name),
method="right.polygons",
data=bench.dt)+
ggplot2::theme(legend.position="none")
out.png <- file.path(
dirname(test.info$tests.R), "tests_all_facet.png")
grDevices::png(
out.png,
width=test.info$width.in*N.tests,
height=test.info$height.in,
units="in",
res=100)
print(gg)
grDevices::dev.off()
out_N_list <- list(all=N.tests)
if(test.info$N.tests.preview < N.tests){
out_N_list$preview <- 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"]
blank.dt <- rbindlist(blank.dt.list)[N_meta, on="Test"]
compare.dt <- rbindlist(compare.dt.list)[N_meta, on="Test"]
N_bench <- bench.dt[N_meta, on="Test"]
## 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 p-value (T-test, HEAD>min, dots show data tested)",
N_int, N_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 ~ 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::geom_point(ggplot2::aes(
N, seconds, color=expr.name),
shape=1,
data=compare.dt)+
ggplot2::scale_x_log10()+
ggplot2::scale_y_log10("median line, quartiles band")+
directlabels::geom_dl(ggplot2::aes(
N, empirical, color=expr.name, label=expr.name),
method="right.polygons",
data=N_bench)+
ggplot2::theme(legend.position="none")
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.tests,
height=test.info$height.in,
units="in",
res=100)
print(gg)
grDevices::dev.off()
if(N_name=="all"){
save(
pkg.results, bench.dt, limit.dt, test.info, blank.dt,
file=tests.RData)
}
}
pkg.results
}

Expand All @@ -186,6 +201,7 @@ atime_pkg_test_info <- function(pkg.path=".", tests.dir=NULL){
tests.parsed <- parse(test.env$tests.R)
eval(tests.parsed, test.env)
default.list <- list(
N.tests.preview=4,
width.in=4,
height.in=8,
expand.prop=0.5,
Expand Down Expand Up @@ -242,10 +258,10 @@ atime_pkg_test_info <- function(pkg.path=".", tests.dir=NULL){
sha.vec=sha.vec)
test.env$test.list <- inherit_args(test.env$test.list, pkg.sha.args)
test.env$test.call <- list()
for(test.name in names(test.env$test.list)){
test.env$test.call[[test.name]] <- as.call(c(
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.name]]))
test.env$test.list[[Test]]))
}
test.env
}
Expand All @@ -271,11 +287,11 @@ inherit_args <- function(L, common.args){
out <- list()
for(L.i in seq_along(L)){
test.args <- L[[L.i]]
test.name <- names(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.name]] <- out.args
out[[Test]] <- out.args
}
}
out
Expand Down
6 changes: 4 additions & 2 deletions man/atime_pkg.Rd
View file
Original file line number Diff line number Diff line change
Expand Up @@ -55,8 +55,10 @@ atime_pkg_test_info(pkg.path=".", tests.dir=NULL)
come from results of \code{atime_versions}. Side effect is that
data/plot files are saved in \code{atime} directory, including
tests.RData (test results which can be read into R if you want to make
your own alternative plots/analyses), and tests_all_facet.png (plot
summarizing all test results).
your own alternative plots/analyses), tests_all_facet.png (plot
summarizing all test results), tests_preview_facet.png (plot
summarizing only most significant results), and install_seconds.txt
(total number of seconds used to install different package versions).
}

\author{Toby Dylan Hocking}
Expand Down
39 changes: 24 additions & 15 deletions tests/testthat/test-versions.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -29,21 +29,7 @@ test_that("atime_versions_exprs error when expr does not contain pkg:", {
}, "expr should contain at least one instance of binsegRcpp:: to replace with binsegRcpp.be2f72e6f5c90622fe72e1c315ca05769a9dc854:", fixed=TRUE)
})

test_that("atime_pkg produces tests_all_facet.png", {
repo <- git2r::repository(tdir)
## https://github.com/tdhock/binsegRcpp/tree/another-branch
git2r::checkout(repo, branch="another-branch")
inst.atime <- file.path(tdir, "inst", "atime")
options(repos="http://cloud.r-project.org")#required to check CRAN version.
result.list <- atime::atime_pkg(tdir)
tests_all_facet.png <- file.path(inst.atime, "tests_all_facet.png")
expect_true(file.exists(tests_all_facet.png))
install_seconds.txt <- file.path(inst.atime, "install_seconds.txt")
install.seconds <- scan(install_seconds.txt, n=1, quiet=TRUE)
expect_is(install.seconds, "numeric")
})

test_that("atime_pkg produces RData with expected names", {
test_that("atime_pkg produces tests_all_facet.png not tests_preview_facet.png", {
repo <- git2r::repository(tdir)
## https://github.com/tdhock/binsegRcpp/tree/atime-test-funs
git2r::checkout(repo, branch="atime-test-funs")
Expand All @@ -66,6 +52,29 @@ test_that("atime_pkg produces RData with expected names", {
bench.seconds <- sapply(result.list, "[[", "bench.seconds")
expect_is(bench.seconds, "numeric")
expect_identical(names(bench.seconds), expected.names)
## also test global PNG.
tests_all_facet.png <- file.path(atime.dir, "tests_all_facet.png")
expect_true(file.exists(tests_all_facet.png))
##N.tests.preview undefined, default 4 == N.tests=4 so should not make PNG.
tests_preview_facet.png <- file.path(atime.dir, "tests_preview_facet.png")
expect_false(file.exists(tests_preview_facet.png))
})

test_that("atime_pkg produces tests_all_facet.png and tests_preview_facet.png", {
repo <- git2r::repository(tdir)
## https://github.com/tdhock/binsegRcpp/tree/another-branch
git2r::checkout(repo, branch="another-branch")
inst.atime <- file.path(tdir, "inst", "atime")
options(repos="http://cloud.r-project.org")#required to check CRAN version.
result.list <- atime::atime_pkg(tdir)
tests_all_facet.png <- file.path(inst.atime, "tests_all_facet.png")
expect_true(file.exists(tests_all_facet.png))
##N.tests.preview=2 < N.tests=4 so should make one more PNG with those two.
tests_preview_facet.png <- file.path(inst.atime, "tests_preview_facet.png")
expect_true(file.exists(tests_preview_facet.png))
install_seconds.txt <- file.path(inst.atime, "install_seconds.txt")
install.seconds <- scan(install_seconds.txt, n=1, quiet=TRUE)
expect_is(install.seconds, "numeric")
})

test_that("pkg.edit.fun is a function", {
Expand Down

0 comments on commit ea4103f

Please sign in to comment.