autobenchR: Automated code benchmarking

#' Run a set of benchmarks.
#'
#' Must be run after [autobenchR::begin()], and before [autobenchR::end()].
#'
#' @param name Name representing this set of benchmarks.
#' @param ... Named expressions to benchmark.
#'
#' @return `FALSE` if an error occurred (and `stop.on.fail = FALSE`), `TRUE` if
#'    run instance was successful, and `NULL` if skipped.
#'
#' @section Note:
#'    All warnings and messages generated by benchmarked expressions are
#'    suppresssed.
#'
#' @author Benjamin Jean-Marie Tremblay
#' @export
run <- function(name = NULL, ...) {

  exprs <- get_exprs(...)

  ## load autobenchR::begin() settings
  missing.settings <- paste0("Could not find benchmark settings, make sure to",
                             " call autobenchR::begin() first")
  run.settings <- .autobenchR_env$begin
  if (run.settings$invalid) stop(missing.settings)

  run.settings$counter <- run.settings$counter + 1
  .autobenchR_env$begin$counter <- run.settings$counter

  v <- !run.settings$quiet
  out.format <- run.settings$format

  if (v) {
    v.r <- paste0("\n* Running benchmark ", run.settings$counter)
    if (!is.null(name)) v.r <- paste0(v.r, ": ", name)
    cat(v.r)
  }

  ## check for autobenchR::skip()
  skip <- .autobenchR_env$skip
  if (skip) {
    .autobenchR_env$skip <- c(skip = FALSE)
    skip.msg <- paste0(ifelse(out.format == "md", "## Benchmark ", ">>> Benchmark "),
                       run.settings$counter, ":",
                       ifelse(is.null(name), "", paste0(" ", name)), " [SKIPPED]")
    cat("", skip.msg, sep = "\n", file = run.settings$file, append = TRUE)
    if (v) cat(" [SKIPPED]")
    return(invisible(NULL))
  }

  ## check for autobenchR::update() settings
  updated.settings <- .autobenchR_env$update
  updated.note <- list(permanent = updated.settings$permanent)
  if (!is.null(updated.settings$max.reps)) {
    updated.note <- c(updated.note, list(max.reps = updated.settings$max.reps))
    run.settings$max.reps <- updated.settings$max.reps
  }
  if (!is.null(updated.settings$min.reps)) {
    updated.note <- c(updated.note, list(min.reps = updated.settings$min.reps))
    run.settings$min.reps <- updated.settings$min.reps
  }
  if (!is.null(updated.settings$min.time)) {
    updated.note <- c(updated.note, list(min.time = updated.settings$min.time))
    run.settings$min.time <- updated.settings$min.time
  }
  if (!is.null(updated.settings$unit)) {
    updated.note <- c(updated.note, list(unit = updated.settings$unit))
    run.settings$unit <- updated.settings$unit
  }
  if (!is.null(updated.settings$tool)) {
    updated.note <- c(updated.note, list(tool = updated.settings$tool))
    run.settings$tool <- updated.settings$tool
  }
  if (!is.null(updated.settings$stop.on.fail)) {
    updated.note <- c(updated.note, list(stop.on.fail = updated.settings$stop.on.fail))
    run.settings$stop.on.fail <- updated.settings$stop.on.fail
  }
  if (!is.null(updated.settings$check)) {
    updated.note <- c(updated.note, list(check = updated.settings$check))
    run.settings$check <- updated.settings$check
  }
  if (length(updated.note) > 1) {
    updated.note <- updated.note[-1]
    u.n.cat <- paste0(names(updated.note), ":")
    u.n.cat <- mapply(paste, u.n.cat, updated.note)
    if (out.format == "md")
      u.n.cat <- c("### Updated benchmark settings", paste0("  * ", u.n.cat))
    else
      u.n.cat <- c("Updated benchmark settings", paste0("  * ", u.n.cat))
  } else u.n.cat <- character(0)

  ## run benchmark
  tic()
  res <- switch(run.settings$tool,
                  "bench" = {
                    b <- run_bench(exprs, run.settings$max.reps, run.settings$min.time,
                                   run.settings$check, run.settings$min.reps)
                    if (is(b, "autobenchR_error")) b else list(b = b)
                  },
                  "microbenchmark" = {
                    b <- run_microbenchmark(exprs, run.settings$max.reps,
                                            run.settings$check)
                    if (is(b, "autobenchR_error")) {
                      b
                    } else {
                      m <- numeric(length(exprs))
                      for (i in seq_along(m)) m[i] <- get_mem_allocs(exprs[[i]])
                      m <- m[seq_along(exprs)]
                      list(b = b, m = m)
                    }
                  },
                  "rbenchmark" = {
                    b <- run_rbenchmark(exprs, run.settings$max.reps)
                    if (is(b, "autobenchR_error")) {
                      b
                    } else {
                      m <- numeric(length(exprs))
                      for (i in seq_along(m)) m[i] <- get_mem_allocs(exprs[[i]])
                      m <- m[seq_along(exprs)]
                      list(b = b, m = m)
                    }
                  },
                  stop("tool must be one of bench, microbenchmark, rbenchmark")
                )
  bench.toc <- toc(quiet = TRUE)

  ## deal with benchmark output
  if (is(res, "autobenchR_error")) {
    fail.msg <- c(paste0(ifelse(out.format == "md", "## Benchmark ", ">>> Benchmark "),
                         run.settings$counter, ":",
                         ifelse(is.null(name), "", paste0(" ", name)), " [ERROR]"),
                  "", paste("Error:", as.character(res)))
    cat("", fail.msg, sep = "\n", file = run.settings$file, append = TRUE)
    if (run.settings$stop.on.fail) {
      if (v) cat(" [ERROR]\n")
      stop.msg <- ifelse(out.format == "md", "## Stopping [stop.on.fail = TRUE]",
                         "Stopping [stop.on.fail = TRUE]")
      cat("", stop.msg, sep = "\n", file = run.settings$file,
          append = TRUE)
      stop(paste("Benchmark:",
                 ifelse(is.null(name), run.settings$counter, name),
                 "failed with the following error: "),
           as.character(res))
    } else {
      if (v) cat(" [ERROR]")
    }
    return(invisible(FALSE))
  } else {
    if (v) {
      cat.toc <- bench.toc$toc - bench.toc$tic
      if (cat.toc > 3600) {
        cat.toc <- round(cat.toc / 3600, 1)
        cat.toc <- paste0(cat.toc, " hours")
      } else if (cat.toc > 60) {
        cat.toc <- round(cat.toc / 60, 1)
        cat.toc <- paste0(" [", cat.toc, " m]")
      } else {
        cat.toc <- paste0(" [", round(cat.toc, 1), " s]")
      }
      cat(cat.toc)
    }
    exprs.parsed <- parse_exprs(exprs)
    out <- switch(run.settings$tool,
                   "bench" = {
                     parse_bench(res, out.format)
                   },
                   "microbenchmark" = {
                     parse_microbenchmark(res, run.settings$unit, out.format)
                   },
                   "rbenchmark" = {
                     parse_rbenchmark(res, run.settings$unit, out.format)
                   }
                 )
  }

  ## write to file
  write_bench(out, exprs.parsed, run.settings$file, name, run.settings$counter,
              u.n.cat, bench.toc, out.format)

  ## change settings if needed
  if (isFALSE(updated.settings$permanent)) {
    updated.settings <- list(quiet = NULL, max.reps = NULL, min.time = NULL,
                             check = NULL,
                             unit = NULL, stop.on.fail = NULL, permanent = FALSE)
    .autobenchR_env$update <- updated.settings
  }

  ## exit
  invisible(TRUE)

}

get_exprs <- function(...) substitute(...())

parse_exprs <- function(exprs) paste(names(exprs), as.character(exprs), sep = " = ")

run_bench <- function(exprs, max_iterations, min_time, check, min_iterations) {
  if (requireNamespace("bench", quietly = TRUE)) {
    b <- capture.output(
      a <- tryCatch(suppressMessages(suppressWarnings(do.call(bench::mark,
                                        c(exprs, check = check,
                                          max_iterations = max_iterations,
                                          min_time = min_time,
                                          min_iterations = min_iterations)))),
               error = function(e) structure(conditionMessage(e),
                                           class = "autobenchR_error"))
         )
    a
  } else
    stop("Please install the bench package for tool = \"bench\"")
}

run_microbenchmark <- function(exprs, times, check) {
  if (isFALSE(check)) check <- NULL
  if (requireNamespace("microbenchmark", quietly = TRUE)) {
    b <- capture.output(
      a <- tryCatch(suppressMessages(suppressWarnings(do.call(microbenchmark::microbenchmark,
                       c(as.list(exprs), list(times = times), list(check = check))))),
               error = function(e) structure(conditionMessage(e),
                                           class = "autobenchR_error"))
         )
    a
  } else
    stop("Please install the microbenchmark package for tool = \"microbenchmark\"")
}

run_rbenchmark <- function(exprs, replications) {
  b <- capture.output(
    a <- tryCatch(suppressMessages(suppressWarnings(do.call(rbenchmark::benchmark,
                     c(exprs, replications = replications)))),
             error = function(e) structure(conditionMessage(e),
                                           class = "autobenchR_error"))
       )
  a
}

get_mem_allocs <- function(e, env = parent.frame()) {

  if (!capabilities("profmem")) {

    if (requireNamespace("pryr", quietly = TRUE)) {
      a <- capture.output(res <- suppressMessages(suppressWarnings(pryr::mem_change(e))))
      memory <- as.numeric(res)
    } else {
      stop("The pryr package is not installed")
    }

  } else {

    f <- tempfile()
    on.exit(unlink(f))

    Rprofmem(f, threshold = 1)
    a <- capture.output(res <- suppressMessages(suppressWarnings(eval(e, env))))
    Rprofmem(NULL)

    if (!file.exists(f)) return(0)

    memory <- readRprofmem(f)

    memory <- sum(memory$bytes, na.rm = TRUE)

    if (length(memory) > 1) stop("something went wrong with getting memory allocations for: ",
                                 as.character(e))

  }

  memory

}

parse_bench <- function(res, out.format) {

  bench <- res$b[, 1:9]

  bench.rel <- bench
  min.i <- which.min(bench$median)
  bench.rel$min <- as.numeric(bench$min) / as.numeric(bench$min[min.i])
  bench.rel$median <- as.numeric(bench$median) / as.numeric(bench$median[min.i])
  bench.rel$mem_alloc <- as.numeric(bench$mem_alloc) / as.numeric(bench$mem_alloc[min.i])
  bench.rel$total_time <- as.numeric(bench$total_time) / as.numeric(bench$total_time[min.i])

  if (nrow(bench) == 1) do.rel <- FALSE else do.rel <- TRUE
  if (out.format == "md") {
    table.format <- "markdown"
    bench$expression <- paste0("`", bench$expression, "`")
    bench.rel$expression <- paste0("`", bench.rel$expression, "`")
  } else {
    table.format <- "pandoc"
  }

  bench <- kable(bench, table.format, padding = 0)
  bench <- as.character(bench)

  bench.rel <- bench.rel[, c(1:3, 5, 9)]
  bench.rel <- kable(bench.rel, table.format, padding = 0)
  bench.rel <- as.character(bench.rel)

  if (do.rel)
    c(ifelse(out.format == "md", "### Absolute:", "Absolute:"),
      bench, "",
      ifelse(out.format == "md", "### Relative:", "Relative:"),
      bench.rel)
  else
    bench

}

parse_microbenchmark <- function(res, unit, out.format) {

  bench <- res$b
  m <- res$m

  df_abs <- summary(bench, unit = unit)
  df_rel <- summary(bench, unit = "relative")
  abs_unit <- attributes(df_abs)$unit
  df_abs$mem <- vapply(m, auto_mem_unit, character(1))
  df_rel$mem <- m / m[which.min(df_rel$median)]

  if (nrow(df_abs) == 1) do.rel <- FALSE else do.rel <- TRUE
  if (out.format == "md") {
    table.format <- "markdown"
    df_abs$expr <- paste0("`", df_abs$expr, "`")
    df_rel$expr <- paste0("`", df_rel$expr, "`")
  } else {
    table.format <- "pandoc"
  }

  df_abs <- df_abs[, -c(3, 6)]
  df_abs <- kable(df_abs, table.format, padding = 0,
                  align = c("l", rep("r", 7), "l", "r"))
  df_abs <- as.character(df_abs)

  df_rel <- df_rel[, -c(3, 6)]
  df_rel <- kable(df_rel, table.format, padding = 0,
                  align = c("l", rep("r", 7), "l", "r"))
  df_rel <- as.character(df_rel)

  if (do.rel) {
    if (out.format == "md") 
      c(paste("### Units:", abs_unit), df_abs, "", "### Units: relative", df_rel)
    else
      c(paste("Units:", abs_unit), df_abs, "", "Units: relative", df_rel)
  } else {
    if (out.format == "md")
      c(paste("### Units:", abs_unit), df_abs)
    else
      c(paste("Units:", abs_unit), df_abs)
  }

}

parse_rbenchmark <- function(res, unit, out.format) {

  b.cols <- c("test", "elapsed", "relative", "replications")
  bench <- res$b[, b.cols]
  m <- res$m

  bench$elapsed <- fix_unit(bench$elapsed, unit)
  unit <- switch(unit,
                 "ns"  = "nanoseconds",
                 "us"  = "microseconds",
                 "ms"  = "milliseconds",
                 "s"   = "seconds",
                 "min" = "minutes",
                         "seconds")

  bench$per.rep <- bench$elapsed / bench$replications
  bench$mem <- m
  bench$mem <- vapply(m, auto_mem_unit, character(1))
  bench$rel.mem <- m / m[which.min(bench$elapsed)]

  if (out.format == "md") {
    table.format <- "markdown"
    bench$test <- paste0("`", bench$test, "`")
  } else {
    table.format <- "pandoc"
  }

  bench <- kable(bench, table.format, padding = 0, align = c("l", rep("r", 6)))
  bench <- as.character(bench)

  # need to add unit conversion
  if (out.format == "md") c(paste("### Units:", unit), bench)
  else c(paste("Units:", unit), bench)

}

auto_mem_unit <- function(m) {
  class(m) <- "object_size"
  format(m, units = "auto")
}

fix_unit <- function(elapsed, unit) {
  switch(unit,
    "ns"  = elapsed * 1e9,
    "us"  = elapsed * 1e6,
    "ms"  = elapsed * 1e3,
    "s"   = elapsed,
    "min" = elapsed / 60,
            elapsed
  )
}

write_bench <- function(out, exprs.parsed, file, name, counter, new.settings,
                        bench.toc, out.format) {
  if (length(new.settings) > 0) n.s <- c("", new.settings, "")
  else n.s <- ""
  cat.toc <- bench.toc$toc - bench.toc$tic
  if (cat.toc > 3600) {
    cat.toc <- round(cat.toc / 3600, 1)
    cat.toc <- paste0(cat.toc, " hours")
  } else if (cat.toc > 60) {
    cat.toc <- round(cat.toc / 60, 1)
    cat.toc <- paste0(cat.toc, " minutes")
  } else {
    cat.toc <- paste0(round(cat.toc, 1), " seconds")
  }
  bench.toc <- paste("Benchmark runtime:", cat.toc)
  if (out.format == "md")  exprs.parsed <- c("```r", exprs.parsed, "```")
  out <- c(
     "",
     paste0(ifelse(out.format == "md", "## Benchmark ", ">>> Benchmark "),
            counter, ": ", ifelse(is.null(name), "", name)),
     "",
     ifelse(out.format == "md", paste0("* ", bench.toc), bench.toc),
     n.s,
     exprs.parsed,
     "",
     out
   )
  cat(out, sep = "\n", file = file, append = TRUE)
}