Merge branch 'main' into rc-0.1.0

Author: lorenzwalthert

R/analyze.R

@@ -95,7 +95,7 @@ benchmark_verbalize <- function(benchmark, timings, refs, ci) {
   confint <- confint_relative_get(timings, refs, tbl$mean[1], ci = ci)
 
   text <- glue::glue(
-    "* {benchmark}: {tbl$mean[1]}s -> {tbl$mean[2]}s {confint}"
+    "* {confint$emoji}{benchmark}: {tbl$mean[1]}s -> {tbl$mean[2]}s {confint$string}"
   )
   cat(
     text,
@@ -110,6 +110,10 @@ set_sign <- function(x) {
 }
 
 confint_relative_get <- function(timings, refs, reference, ci) {
+  no_change <- "&nbsp;&nbsp;:ballot_box_with_check:"
+  slower <- ":exclamation::snail:"
+  faster <- "&nbsp;&nbsp;:rocket:"
+
   timings_with_factors <- timings %>%
     dplyr::mutate(
       block = factor(.data$block), ref = factor(.data$ref, levels = refs)
@@ -118,7 +122,22 @@ confint_relative_get <- function(timings, refs, reference, ci) {
   fit <- stats::aov(elapsed ~ ref, data = timings_with_factors)
   var <- paste0("ref", refs[2])
   confint <- confint(fit, var, level = ci)
-  paste0("[", paste0(set_sign(round(100 * confint / reference, 2)), collapse = "%, "), "%]")
+  confint <- round(100 * confint / reference, 2)
+  emoji <- confint %>%
+    purrr::when(
+      all(. < 0) ~ faster,
+      all(. > 0) ~ slower,
+      ~ no_change
+    )
+
+  list(
+    string = paste0(
+      "[",
+      paste0(set_sign(confint), collapse = "%, "),
+      "%]"
+    ),
+    emoji = emoji
+  )
 }
 
 
@@ -134,4 +153,4 @@ benchmark_plot <- function(benchmark, timings) {
   fs::path(dir_touchstone(), "plots", benchmark) %>%
     fs::path_ext_set("png") %>%
     ggplot2::ggsave()
-}
+}

R/core.R

@@ -1,51 +1,50 @@
 #' Run a benchmark iteration
 #' @param expr_before_benchmark Character vector with code to run before
 #'   the benchmark is ran, will be evaluated with [exprs_eval()].
-#' @param ... Named character vector of length one with code to benchmark, will
-#'   be evaluated with [exprs_eval()].
 #' @param n Number of iterations to run a benchmark within an iteration.
+#' @param dots list of quoted expressions (length 1).
 #' @inheritParams benchmark_write
 #' @return
 #' A tibble with the benchmarks.
 #' @importFrom tibble lst tibble
 #' @keywords internal
 benchmark_run_iteration <- function(expr_before_benchmark,
-                                    ...,
+                                    dots,
                                     ref,
                                     block,
                                     n = getOption("touchstone.n_iterations", 1)) {
   if (rlang::is_missing(expr_before_benchmark)) {
     expr_before_benchmark <- ""
   }
-  if (length(rlang::list2(...)) > 1) {
-    rlang::abort("Can only pass one expression to benchmark")
-  }
+
   args <- rlang::list2(
     expr_before_benchmark = expr_before_benchmark,
-    ...,
+    dots = dots,
     ref = ref,
     block = block
   )
   for (iteration in seq_len(n)) { # iterations
     callr::r(
-      function(expr_before_benchmark, ..., ref, block, iteration) {
+      function(expr_before_benchmark, dots, ref, block, iteration) {
         new_name <- "masked_touchstone"
         attach(loadNamespace("touchstone"), name = new_name)
         on.exit(detach(new_name, character.only = TRUE), add = TRUE)
-        exprs_eval(expr_before_benchmark)
-        benchmark <- bench::mark(exprs_eval(...), memory = FALSE, iterations = 1)
-        benchmark_write(benchmark, names(rlang::list2(...)), ref = ref, block = block, iteration = iteration)
+        exprs_eval(!!expr_before_benchmark)
+        benchmark <- bench::mark(exprs_eval(!!dots[[1]]), memory = FALSE, iterations = 1)
+        benchmark_write(benchmark, names(dots), ref = ref, block = block, iteration = iteration)
       },
       args = append(args, lst(iteration)),
       libpath = c(libpath_touchstone(ref), .libPaths())
     )
   }
   usethis::ui_done("Ran {n} iterations of ref `{ref}`.")
-  benchmark_read(names(rlang::list2(...)), ref)
+  benchmark_read(names(dots), ref)
 }
 
 #' Run a benchmark for git refs
 #'
+#' @param ... Named expression or named character vector of length one with code to benchmark, will
+#'   be evaluated with [exprs_eval()].
 #' @param refs Character vector with branch names to benchmark. The package
 #'   must be built for each benchmarked branch beforehand with [refs_install()].
 #'   The base ref is the target branch of the pull request in a workflow run,
@@ -78,14 +77,20 @@ benchmark_run_ref <- function(expr_before_benchmark,
                               n = 100,
                               path_pkg = ".") {
   force(refs)
+  expr_before_benchmark <- rlang::enexpr(expr_before_benchmark)
+  dots <- rlang::enexprs(...)
+
+  if (length(dots) > 1) {
+    rlang::abort("Can only pass one expression to benchmark")
+  }
   # touchstone libraries must be removed from the path temporarily
   # and the one to benchmark will be added in benchmark_run_ref_impl()
   local_without_touchstone_lib()
   # libpaths <- refs_install(refs, path_pkg, install_dependencies) # potentially not needed anymroe
   refs <- ref_upsample(refs, n = n)
   out_list <- purrr::pmap(refs, benchmark_run_ref_impl,
     expr_before_benchmark = expr_before_benchmark,
-    ...,
+    dots = dots,
     path_pkg = path_pkg
   )
   vctrs::vec_rbind(!!!out_list)
@@ -101,12 +106,12 @@ benchmark_run_ref <- function(expr_before_benchmark,
 benchmark_run_ref_impl <- function(ref,
                                    block,
                                    expr_before_benchmark,
-                                   ...,
+                                   dots,
                                    path_pkg) {
   local_git_checkout(ref, path_pkg)
   benchmark_run_iteration(
     expr_before_benchmark = expr_before_benchmark,
-    ...,
+    dots = dots,
     ref = ref,
     block = block
   )

R/prepare.R

@@ -8,7 +8,7 @@
 #' @return
 #' A character vector with library paths.
 #' @keywords internal
-ref_install <- function(ref = "master",
+ref_install <- function(ref = "main",
                         path_pkg = ".",
                         install_dependencies = FALSE) {
   local_git_checkout(ref, path_pkg)
@@ -23,10 +23,13 @@ ref_install <- function(ref = "master",
       .libPaths()
     )
     withr::local_libpaths(libpath)
+    withr::local_options(warn = 2)
     remotes::install_local(path_pkg,
       upgrade = "never", quiet = TRUE,
-      dependencies = install_dependencies
+      dependencies = install_dependencies,
+      force = !cache_up_to_date(ref, path_pkg)
     )
+    cache_update(ref, path_pkg)
     usethis::ui_done("Installed branch {ref} into {libpath[1]}.")
     libpath
   }
@@ -69,3 +72,49 @@ refs_install <- function(refs = c(
 libpath_touchstone <- function(ref) {
   fs::path(dir_touchstone(), "lib", ref)
 }
+
+#' When did the package sources change last?
+#' @inheritParams ref_install
+#' @keywords internal
+hash_pkg <- function(path_pkg) {
+  withr::local_dir(path_pkg)
+  list(
+    tools::md5sum(c(
+      if (fs::dir_exists("R")) fs::dir_ls("R"),
+      if (fs::file_exists("DESCRIPTION")) "DESCRIPTION",
+      if (fs::dir_exists("scr")) fs::dir_info("scr")
+    ))
+  )
+}
+
+#' Cache package sources within a session
+#'
+#' This is required to make sure [remotes::install_local()] installs again
+#' when source code changed.
+#' @inheritParams ref_install
+#' @keywords internal
+cache_up_to_date <- function(ref, path_pkg) {
+  md5_hashes <- hash_pkg(path_pkg)
+  cache <- cache_get()
+  identical(md5_hashes, cache$md5_hashes[cache$ref == ref & cache$path_pkg == path_pkg])
+}
+
+#' @rdname cache_up_to_date
+#' @keywords internal
+cache_update <- function(ref, path_pkg) {
+  md5_hashes <- hash_pkg(path_pkg)
+  cache <- cache_get()
+  stopifnot(sum(cache$ref[cache$path_pkg == path_pkg] == ref) <= 1)
+  cache <- cache[(!(cache$ref == ref) & (cache$path_pkg == path_pkg)), ]
+  cache <- vctrs::vec_rbind(
+    cache, tibble::tibble(ref, md5_hashes, path_pkg)
+  )
+  options("touchstone.hash_source_package" = cache)
+}
+
+
+#' @rdname cache_up_to_date
+#' @keywords internal
+cache_get <- function() {
+  getOption("touchstone.hash_source_package")
+}

R/source.R

@@ -37,8 +37,8 @@
 #' @export
 #' @examples
 #' \dontrun{
-#' # assuming you want to compare the branch master with the branch devel
-#' if (requireNamespace("withr")) {
+#' # assuming you want to compare the branch main with the branch devel
+#' if (rlang::is_installed("withr")) {
 #'   withr::with_envvar(
 #'     c("GITHUB_BASE_REF" = "main", "GITHUB_HEAD_REF" = "devel"),
 #'     run_script("touchstone/script.R")

R/testing.R

@@ -43,7 +43,10 @@ local_package <- function(pkg_name = fs::path_file(tempfile("pkg")),
   withr::local_options(
     usethis.quiet = TRUE,
     touchstone.n_iterations = 2,
-    .local_envir = envir
+    .local_envir = envir,
+    touchstone.hash_source_package = tibble::tibble(
+      ref = character(), md5_hashes = list(), path_pkg = character()
+    )
   )
   usethis::create_package(path, open = FALSE)
   withr::local_dir(path, .local_envir = if (setwd) envir else rlang::current_env())
@@ -54,6 +57,9 @@ local_package <- function(pkg_name = fs::path_file(tempfile("pkg")),
   writeLines(if (is.null(r_sample)) "" else r_sample, fs::path("R", "sample.R"))
   gert::git_add("R/")
   gert::git_commit("[init]")
+  branches <- gert::git_branch_list() %>%
+    dplyr::pull(name) %>%
+    dplyr::setdiff(branches, .)
   purrr::walk(branches, gert::git_branch_create)
   withr::defer(unlink(path), envir = envir)
   install_check <- is_installed(path)

R/utils.R

@@ -52,14 +52,32 @@ touchstone_clear <- function(all = FALSE) {
   fs::dir_delete(paths)
 }
 
-#' Evaluate an expression
+#' Evaluate an expression for sideeffects
 #'
-#' @param text Character vector with code to evaluate.
-#' @return
-#' The input, parsed and evaluated.
+#'
+#' @param ... Character vector  of length 1 or expression with code to evaluate. This will be quoted using
+#' [rlang::enexprs()], so you can use `!!`.
+#' @param env Environment in which the expression will be evaluated.
+#' @return The quoted input (invisibly).
 #' @keywords internal
-exprs_eval <- function(...) {
-  eval(parse(text = unlist(rlang::list2(...))))
+exprs_eval <- function(..., env = parent.frame()) {
+  expr <- rlang::enexprs(...)[[1]]
+
+  if (is.symbol(expr)) {
+    expr <- rlang::eval_tidy(expr, env = env)
+  }
+
+  if (is.character(expr)) {
+    expr <- rlang::parse_exprs(expr)
+  }
+
+  if (is.list(expr)) {
+    purrr::map(expr, eval, envir = env)
+  } else {
+    eval(expr, envir = env)
+  }
+
+  invisible(expr)
 }
 
 #' Samples `ref`

R/zzz.R

@@ -1,10 +1,14 @@
 .onLoad <- function(libname, pkgname) {
   op <- options()
+  cache <- tibble::tibble(
+    ref = character(), md5_hashes = list(), path_pkg = character()
+  )
   op.touchstone <- list(
     "touchstone.skip_install" = FALSE,
     "touchstone.dir" = "touchstone",
     # how many times should inner loop be ran in benchmark_run_iteration
-    "touchstone.n_iterations" = 1
+    "touchstone.n_iterations" = 1,
+    "touchstone.hash_source_package" = cache
   )
   toset <- !(names(op.touchstone) %in% names(op))
   if (any(toset)) options(op.touchstone[toset])

README.Rmd

@@ -128,7 +128,7 @@ touchstone::refs_install() # installs branches to benchmark
 
 # benchmark a function call from your package (two calls per branch)
 touchstone::benchmark_run_ref(
-  random_test = "yourpkg::fun()",
+  random_test = yourpkg::fun(),
   n = 2
 )