diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index a3ac618..5a1f4d0 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -31,6 +31,12 @@ jobs: steps: - uses: actions/checkout@v3 + - name: git config user.name + run: git config --global user.name "atime GitHub Actions" + + - name: git config user.email + run: git config --global user.email toby.hocking@r-project.org + - uses: r-lib/actions/setup-pandoc@v2 - uses: r-lib/actions/setup-r@v2 diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml index 2c5bb50..0feccfd 100644 --- a/.github/workflows/test-coverage.yaml +++ b/.github/workflows/test-coverage.yaml @@ -17,6 +17,12 @@ jobs: steps: - uses: actions/checkout@v3 + - name: git config user.name + run: git config --global user.name "atime GitHub Actions" + + - name: git config user.email + run: git config --global user.email toby.hocking@r-project.org + - uses: r-lib/actions/setup-r@v2 with: use-public-rspm: true diff --git a/DESCRIPTION b/DESCRIPTION index 0db9511..9fcdfaa 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: atime Type: Package Title: Asymptotic Timing -Version: 2024.8.11 +Version: 2024.9.23 Authors@R: c( person("Toby", "Hocking", email="toby.hocking@r-project.org", diff --git a/NAMESPACE b/NAMESPACE index 680ef2e..8cf170e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -9,6 +9,7 @@ export(atime_versions) export(atime_versions_remove) export(atime_versions_exprs) export(atime_pkg) +export(atime_pkg_test_info) export(atime_test) export(atime_test_list) export(glob_find_replace) diff --git a/NEWS b/NEWS index e5cab9b..e5e54bf 100644 --- a/NEWS +++ b/NEWS @@ -1,3 +1,8 @@ +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. +- atime_versions result list contains bench.seconds and install.seconds, to compare how much time is spent in each step. + Changes in version 2024.8.11 - atime_test_list evaluates any arguments that are copied to each test, except setup and expr. diff --git a/R/references.R b/R/references.R index cf91a5d..b3f6157 100644 --- a/R/references.R +++ b/R/references.R @@ -45,6 +45,9 @@ references_best <- function(L, fun.list=NULL){ N <- expr.name <- . <- fun.name <- dist <- empirical <- reference <- fun.latex <- overall.rank <- each.sign.rank <- NULL ## Above for R CMD check. + if(!inherits(L,"atime")){ + stop("L argument to references_best should have class atime") + } DT <- L[["measurements"]] not.found <- L$unit.col.vec[!L$unit.col.vec %in% names(DT)] if(length(not.found)){ diff --git a/R/test.R b/R/test.R index 3c2902c..5436520 100644 --- a/R/test.R +++ b/R/test.R @@ -1,7 +1,245 @@ -test_file_to_env <- function(tests.R){ +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 <- 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() + 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]] + atime.list <- eval(atv.call, test.info) + pkg.results[[test.name]] <- 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)] + largest.common.N <- sec.dt[N==min(max.dt$max.N)] + ## TODO: fixed comparison? + compare.name <- largest.common.N[ + expr.name!=test.info$HEAD.name + ][which.min(median), expr.name] + HEAD.compare <- c(test.info$HEAD.name, compare.name) + largest.common.timings <- largest.common.N[ + 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) + 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 + 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) + 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[, N := xmax] + blank.dt.list[[test.name]] <- one.blank + gg <- ggplot2::ggplot()+ + ggplot2::ggtitle(test.name)+ + 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("[: /]", "_", test.name), ".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] + 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"] + tests.RData <- sub("R$", "RData", test.info$tests.R) + save( + pkg.results, bench.dt, limit.dt, test.info, blank.dt, + file=tests.RData) + gg <- ggplot2::ggplot()+ + 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") + N.tests <- length(test.info$test.list) + 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() + 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() - tests.parsed <- parse(tests.R) + 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( + 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) + CRAN.name <- paste0("CRAN=",ap[Package,"Version"]) + if(Package %in% rownames(ap)){ + sha.vec[[CRAN.name]] <- "" + } + 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)) + pkg.sha.args <- list( + pkg.path=pkg.path, + 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( + quote(atime::atime_versions), + test.env$test.list[[test.name]])) + } test.env } @@ -19,6 +257,10 @@ atime_test_list <- function(..., N, setup, expr, times, seconds.limit, verbose, common.args <- mget(eval.names) common.args[uneval.names] <- mc[uneval.names] 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]] diff --git a/R/versions.R b/R/versions.R index 29835ed..fa86ad9 100644 --- a/R/versions.R +++ b/R/versions.R @@ -124,10 +124,17 @@ atime_versions_install <- function(Package, pkg.path, new.Package.vec, sha.vec, atime_versions <- function(pkg.path, N=default_N(), setup, expr, sha.vec=NULL, times=10, seconds.limit=0.01, verbose=FALSE, pkg.edit.fun=pkg.edit.default, result=FALSE, ...){ ver.args <- list( pkg.path, substitute(expr), sha.vec, verbose, pkg.edit.fun, ...) - ver.exprs <- do.call(atime_versions_exprs, ver.args) + install.seconds <- system.time({ + ver.exprs <- do.call(atime_versions_exprs, ver.args) + })[["elapsed"]] a.args <- list( N, substitute(setup), ver.exprs, times, seconds.limit, verbose, result) - do.call(atime, a.args) + bench.seconds <- system.time({ + out.list <- do.call(atime, a.args) + })[["elapsed"]] + out.list$install.seconds <- install.seconds + out.list$bench.seconds <- bench.seconds + out.list } get_sha_vec <- function(sha.vec, dots.vec){ @@ -181,207 +188,3 @@ atime_versions_exprs <- function(pkg.path, expr, sha.vec=NULL, verbose=FALSE, pk a.args } -atime_pkg <- function(pkg.path=".", tests.dir="inst"){ - ## 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 <- NULL - ## above to avoid CRAN check NOTE. - 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) - CRAN.name <- paste0("CRAN=",ap[Package,"Version"]) - if(Package %in% rownames(ap)){ - sha.vec[[CRAN.name]] <- "" - } - 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) - ## TODO take from tests.R file. - width.in <- 4 - height.in <- 8 - expand.prop <- 0.5 - 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) - } - tests.R <- file.path(pkg.path, tests.dir, "atime", "tests.R") - test.env <- test_file_to_env(tests.R) - color.vec <- if(is.character(test.env$version.colors)){ - test.env$version.colors - }else{ - 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" - ) - } - abbrev2name <- c( - HEAD=HEAD.name, - base=base.name, - CRAN=CRAN.name) - names(color.vec) <- ifelse( - names(color.vec) %in% names(abbrev2name), - abbrev2name[names(color.vec)], - names(color.vec)) - pkg.results <- list() - blank.dt.list <- list() - bench.dt.list <- list() - limit.dt.list <- list() - compare.dt.list <- list() - for(test.name in names(test.env$test.list)){ - pkg.sha.args <- list(pkg.path=pkg.path, sha.vec=sha.vec) - user.args <- test.env$test.list[[test.name]] - atv.args <- c(pkg.sha.args, user.args) - atime.list <- do.call(atime_versions, atv.args) - pkg.results[[test.name]] <- 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)] - largest.common.N <- sec.dt[N==min(max.dt$max.N)] - ## TODO: fixed comparison? - compare.name <- largest.common.N[ - expr.name!=HEAD.name - ][which.min(median), expr.name] - HEAD.compare <- c(HEAD.name, compare.name) - largest.common.timings <- largest.common.N[ - 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) - 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 - 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) - log10.range <- range(log10(atime.list$meas$N)) - expand <- diff(log10.range)*expand.prop - xmax <- 10^(log10.range[2]+expand) - one.blank <- data.table(test.name, best.list$meas[1]) - one.blank[, N := xmax] - blank.dt.list[[test.name]] <- one.blank - gg <- ggplot2::ggplot()+ - ggplot2::ggtitle(test.name)+ - 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=color.vec)+ - ggplot2::scale_fill_manual(values=color.vec)+ - 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(tests.R), - paste0(gsub("[: /]", "_", test.name), ".png")) - grDevices::png(out.png, width=width.in*nrow(max.dt), height=height.in, units="in", res=100) - print(gg) - grDevices::dev.off() - } - bench.dt <- rbindlist(bench.dt.list)[, Test := test.name] - 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"] - tests.RData <- sub("R$", "RData", tests.R) - save( - pkg.results, bench.dt, limit.dt, color.vec, blank.dt, - file=tests.RData) - gg <- ggplot2::ggplot()+ - ggplot2::theme_bw()+ - ggplot2::geom_hline(ggplot2::aes( - yintercept=seconds.limit), - color="grey", - data=limit.dt)+ - ggplot2::scale_color_manual(values=color.vec)+ - ggplot2::scale_fill_manual(values=color.vec)+ - 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(tests.R), "tests_all_facet.png") - N.tests <- length(test.env$test.list) - grDevices::png(out.png, width=width.in*N.tests, height=height.in, units="in", res=100) - print(gg) - grDevices::dev.off() - pkg.results -} diff --git a/inst/global_edit.R b/inst/global_edit.R new file mode 100644 index 0000000..cfe3f54 --- /dev/null +++ b/inst/global_edit.R @@ -0,0 +1,41 @@ +extra.tests <- list(rpois=atime::atime_test(expr=rpois(N,1))) +test.list <- atime::atime_test_list( + pkg.edit.fun=function(old.Package, new.Package, sha, new.pkg.path){ + pkg_find_replace <- function(glob, FIND, REPLACE){ + atime::glob_find_replace(file.path(new.pkg.path, glob), FIND, REPLACE) + } + Package_regex <- gsub(".", "_?", old.Package, fixed=TRUE)#data_?table + ## old.Package = data.table + Package_ <- gsub(".", "_", old.Package, fixed=TRUE)#data_table + new.Package_ <- paste0(Package_, "_", sha)#data_table_ddb345a + pkg_find_replace( + "DESCRIPTION", + paste0("Package:\\s+", old.Package), + paste("Package:", new.Package)) + pkg_find_replace( + file.path("src","Makevars.*in"), + Package_regex, + new.Package_) + pkg_find_replace( + file.path("R", "onLoad.R"), + Package_regex, + new.Package_) + pkg_find_replace( + file.path("R", "onLoad.R"), + sprintf('packageVersion\\("%s"\\)', old.Package), + sprintf('packageVersion\\("%s"\\)', new.Package)) + pkg_find_replace( + file.path("src", "init.c"), + paste0("R_init_", Package_regex), + paste0("R_init_", gsub("[.]", "_", new.Package_))) + pkg_find_replace( + "NAMESPACE", + sprintf('useDynLib\\("?%s"?', Package_regex), + paste0('useDynLib(', new.Package_)) + }, + N=9, + test_N_expr=atime::atime_test(N=2, expr=rnorm(N)), + test_expr=atime::atime_test(expr=rnorm(N)), + tests=extra.tests +) + diff --git a/man/atime.Rd b/man/atime.Rd index d96d091..a436891 100644 --- a/man/atime.Rd +++ b/man/atime.Rd @@ -36,36 +36,40 @@ result=FALSE, ...)} \examples{ ## Example 1: polynomial and exponential time string functions. -string.result <- atime::atime( +atime_result_string <- atime::atime( + seconds.limit=0.001, N=unique(as.integer(10^seq(0,3.5,l=100))), setup={ subject <- paste(rep("a", N), collapse="") pattern <- paste(rep(c("a?", "a"), each=N), collapse="") + linear_size_replacement <- paste(rep("REPLACEMENT", N), collapse="") }, - seconds.limit=0.001, PCRE.match=regexpr(pattern, subject, perl=TRUE), TRE.match=regexpr(pattern, subject, perl=FALSE), constant.replacement=gsub("a","constant size replacement",subject), - linear.replacement=gsub("a",subject,subject)) -plot(string.result) + linear.replacement=gsub("a",linear_size_replacement,subject)) +plot(atime_result_string) -## Example 2: split data table vs frame, constant factor difference. -library(data.table) -split.result <- atime::atime( +## Example 2: combine using rbind inside or outside for loop. +atime_result_rbind <- atime::atime( + seconds.limit=0.001, setup={ - set.seed(1) - DT <- data.table( - x1 = rep(c("c","d"), l=N), - x2 = rep(c("x","y"), l=N), - x3 = rep(c("a","b"), l=N), - y = rnorm(N) - )[sample(.N)] - DF <- as.data.frame(DT) + DF <- data.frame(i=1:100) }, - seconds.limit=0.001, - frame=split(DF[names(DF) != "x1"], DF["x1"], drop = TRUE), - table=split(DT, by = "x1", keep.by = FALSE, drop = TRUE) + inside={ + big.frame <- data.frame() + for(table.i in 1:N){ + big.frame <- rbind(big.frame, DF) + } + }, + outside={ + big.frame.list <- list() + for(table.i in 1:N){ + big.frame.list[[table.i]] <- DF + } + big.frame <- do.call(rbind, big.frame.list) + } ) -plot(split.result) +plot(atime_result_rbind) } diff --git a/man/atime_pkg.Rd b/man/atime_pkg.Rd index df01045..52f49b2 100644 --- a/man/atime_pkg.Rd +++ b/man/atime_pkg.Rd @@ -1,14 +1,25 @@ \name{atime_pkg} \alias{atime_pkg} +\alias{atime_pkg_test_info} \title{Asymptotic timing package tests} -\description{Computation time and memory for several R expressions of +\description{R package performance testing, by computing time/memory + usage of several R expressions of several different data sizes, for several package - versions (base, HEAD, CRAN, merge-base, others specified by user).} -\usage{atime_pkg(pkg.path=".", tests.dir="inst")} + versions (base, HEAD, CRAN, merge-base, other historical references + specified by user). + \code{atime_pkg_test_info} returns an environment containing test + code/calls (useful for running a single test), whereas + \code{atime_pkg} runs all tests and saves results/plots to disk. +} +\usage{ +atime_pkg(pkg.path=".", tests.dir=NULL) +atime_pkg_test_info(pkg.path=".", tests.dir=NULL) +} \arguments{ \item{pkg.path}{path to git repository containing R package.} - \item{tests.dir}{path to directory which contains atime/tests.R, - relative to \code{pkg.path} (default \code{"inst"}).} + \item{tests.dir}{path to directory which contains \code{atime/tests.R}, + relative to \code{pkg.path} (default \code{NULL} means first + existing directory of \code{"inst"} or \code{".ci"}).} } \details{ There should be a \code{tests.R} code file which @@ -19,17 +30,28 @@ \code{pkg.edit.fun} and \code{version_name="1234567890abcdef"}) to be passed as named arguments to \code{atime_versions}, along with the following versions which are passed using the \code{sha.vec} argument: - base ref comes from GITHUB_BASE_REF environment variable (default master), - HEAD ref is the branch that you want to merge into base, - CRAN is current published version (sha value \code{""}), - merge-base is most recent common ancestor commit between base and - HEAD. - The \code{tests.R} code file can define \code{version.colors} which should be - a character vector (names for versions, values for colors; names/versions are - HEAD, base, CRAN, merge-base, and any others you may define such as - Before, Regression, Slow, Fixed, Fast). + \code{base} ref comes from \code{GITHUB_BASE_REF} environment variable (default \code{master}), + \code{HEAD} ref is the branch that you want to merge into base, + \code{CRAN} is current published version (sha value \code{""}), + \code{merge-base} is most recent common ancestor commit between \code{base} and + \code{HEAD}. + For visualization, default colors are provided for versions with names: + \code{HEAD}, \code{base}, \code{CRAN}, \code{merge-base}, + \code{Before}, \code{Regression}, \code{Slow}, \code{Fixed}, + \code{Fast}; other version names will be gray using + the default colors. + If \code{tests.R} defines a variable named \code{version.colors}, then + it should be a character vector of colors to be used instead of the + default (names for versions, values for colors). } -\value{Named list, names come from names of \code{test.list}, and values +\value{ + \code{atime_pkg_test_info} returns an environment in which the code of + \code{tests.R} was evaluated, including a variable \code{test.call} + which is a list of un-evaluated \code{atime_versions} calls, + one for each test + (use with \code{eval} to run a single test). + \code{atime_pkg} returns a named list of test results, + names come from names of \code{test.list}, and values 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 diff --git a/man/references_best.Rd b/man/references_best.Rd index cabf070..0ed3004 100644 --- a/man/references_best.Rd +++ b/man/references_best.Rd @@ -26,26 +26,54 @@ references_best(L, fun.list=NULL) \examples{ ## Example 1: polynomial and exponential time string functions. -string.result <- atime::atime( +atime_result_string <- atime::atime( + seconds.limit=0.001, N=unique(as.integer(10^seq(0,4,l=100))), setup={ subject <- paste(rep("a", N), collapse="") pattern <- paste(rep(c("a?", "a"), each=N), collapse="") + linear_size_replacement <- paste(rep("REPLACEMENT", N), collapse="") }, - seconds.limit=0.001, PCRE.match=regexpr(pattern, subject, perl=TRUE), TRE.match=regexpr(pattern, subject, perl=FALSE), constant.replacement=gsub("a","constant size replacement",subject), - linear.replacement=gsub("a",subject,subject)) -(string.best <- atime::references_best(string.result)) + linear.replacement=gsub("a",linear_size_replacement,subject)) +(refs_best_string <- atime::references_best(atime_result_string)) ## plot method shows each expr and unit in a separate panel. ## default is to show closest larger and smaller references. -plot(string.best) +plot(refs_best_string) ## modifying plot.references changes violet references shown by plot. -string.best$plot.references <- string.best$ref[c("N","N^2","N^3","2^N"),on="fun.name"] -plot(string.best) +refs_best_string$plot.references <- refs_best_string$ref[c("N","N^2","N^3","2^N"),on="fun.name"] +plot(refs_best_string) ## predict method computes N for given units (default seconds limit). -string.pred = predict(string.best) -plot(string.pred) +(pred_string <- predict(refs_best_string)) +plot(pred_string) + +## Example 2: combine using rbind inside or outside for loop. +atime_result_rbind <- atime::atime( + seconds.limit=0.001, + setup={ + DF <- data.frame(i=1:100) + }, + inside={ + big.frame <- data.frame() + for(table.i in 1:N){ + big.frame <- rbind(big.frame, DF) + } + }, + outside={ + big.frame.list <- list() + for(table.i in 1:N){ + big.frame.list[[table.i]] <- DF + } + big.frame <- do.call(rbind, big.frame.list) + } +) +(refs_best_rbind <- atime::references_best(atime_result_rbind)) +plot(refs_best_rbind) +refs_best_rbind$plot.references <- refs_best_rbind$ref[c("N","N^2"),on="fun.name"] +plot(refs_best_rbind) +(pred_rbind <- predict(refs_best_rbind)) +plot(pred_rbind) } diff --git a/tests/testthat/test-CRAN.R b/tests/testthat/test-CRAN.R index f0c4946..9d8badc 100644 --- a/tests/testthat/test-CRAN.R +++ b/tests/testthat/test-CRAN.R @@ -414,15 +414,3 @@ test_that("error for new unit name conflicting with existing", { }, "result is 1 row data frame with column(s) named median, kilobytes (reserved for internal use); please fix by changing the column name(s) in your results", fixed=TRUE) }) -test_that("pkg.edit.fun is a function", { - example_tests.R <- system.file("example_tests.R", package="atime") - test.env <- atime:::test_file_to_env(example_tests.R) - test_N_expr <- test.env$test.list$test_N_expr - expect_identical(test_N_expr$pkg.edit.fun, test.env$edit.data.table) - expect_identical(test_N_expr$N, 2) - expect_identical(test_N_expr$expr, quote(rnorm(N))) - test_expr <- test.env$test.list$test_expr - expect_identical(test_expr$pkg.edit.fun, test.env$edit.data.table) - expect_identical(test_expr$N, 9) - expect_identical(test_expr$expr, quote(rnorm(N))) -}) diff --git a/tests/testthat/test-versions.R b/tests/testthat/test-versions.R index 953619b..75c7173 100644 --- a/tests/testthat/test-versions.R +++ b/tests/testthat/test-versions.R @@ -57,5 +57,36 @@ test_that("atime_pkg produces RData with expected names", { ) expect_identical(names(pkg.results), expected.names) expect_is(bench.dt[["Test"]], "character") + install.seconds <- sapply(result.list, "[[", "install.seconds") + expect_is(install.seconds, "numeric") + expect_identical(names(install.seconds), expected.names) + bench.seconds <- sapply(result.list, "[[", "bench.seconds") + expect_is(bench.seconds, "numeric") + expect_identical(names(bench.seconds), expected.names) }) +test_that("pkg.edit.fun is a function", { + example_tests.R <- system.file("example_tests.R", package="atime") + tests.dir <- file.path(tempfile(), ".ci", "atime") + dir.create(tests.dir, showWarnings = FALSE, recursive = TRUE) + tests.R <- file.path(tests.dir, "tests.R") + file.copy(example_tests.R, tests.R) + ci.dir <- dirname(tests.dir) + pkg.dir <- dirname(ci.dir) + DESCRIPTION <- file.path(pkg.dir, "DESCRIPTION") + cat("Package: atime\nVersion: 1.0\n", file=DESCRIPTION) + git2r::init(pkg.dir) + repo <- git2r::repository(pkg.dir) + git2r::add(repo, DESCRIPTION) + git2r::commit(repo, "test commit") + options(repos="http://cloud.r-project.org")#required to check CRAN version. + test.env <- atime::atime_pkg_test_info(pkg.dir) + test_N_expr <- test.env$test.list$test_N_expr + expect_identical(test_N_expr$pkg.edit.fun, test.env$edit.data.table) + expect_identical(test_N_expr$N, 2) + expect_identical(test_N_expr$expr, quote(rnorm(N))) + test_expr <- test.env$test.list$test_expr + expect_identical(test_expr$pkg.edit.fun, test.env$edit.data.table) + expect_identical(test_expr$N, 9) + expect_identical(test_expr$expr, quote(rnorm(N))) +})