R/blade_runr.R

In datr-studio/bladerunr: bladerunr: incisive model runs across a grid of parameters

#' Execute your test functions smoothly with control
#'
#' `blade_runr()` sets your tests in motion. After setting them up with
#' `blade_setup()`, this function takes a grid of parameters generated by
#' `blade_params()` and iterates over it, executing your functions for each
#' individual test case.
#'
#' @param grid A grid of test parameters, ideally generated by `blade_params()`.
#' @param force If TRUE, blade_runr() will overwrite any files in the output dir without confirmation. Defaults to FALSE.

#'
#' @importFrom vroom vroom_write
#' @importFrom stringr str_detect str_pad
#'
#' @export
#'
#' @return The value of the post_runr function, as specified in `blade_setup()`
#' @examples
#' blade_setup(
#'   run_name = "test_run",
#'   runr = function() 1,
#' )
#' params <- list(
#'   a = seq(1:3),
#'   b = 2
#' )
#' grid <- blade_params(params)
#' blade_runr(grid)
blade_runr <- function(grid, force = FALSE) {
  # Arg Checking
  check_args("blade_runr requires a dataframe grid to run.", any(class(grid) == "data.frame"))
  if (class(grid)[[1]] != "tbl_df") {
    grid <- as_tibble(grid)
  }
  if (is.null(get_config("runr"))) {
    cli::cli_abort("`blade_setup` must be called first to setup your runrs")
  }

  # Create output dir
  output_dir <- get_config("output_dir")
  if (!is.null(output_dir)) {
    run_name <- get_config("run_name")
    output_dir <- file.path(output_dir, safeguard_run_name(run_name))
    set_config(output_dir = output_dir)
    prepare_dir(output_dir, force)
    save_grid(grid, output_dir)
  } else {
    set_config(output_dir = ".")
    output_dir <- "."
  }

  # prepare context
  context <- get_context()
  max_attempts <- get_config("max_attempts")

  # Execute Search
  opening_logo()
  options("cli.progress_show_after" = 0)
  reset_log()
  total <- nrow(grid)
  test_start_time <- Sys.time()
  cli_progress_bar("  Overall Progress", total = total)
  for (i in seq_len(total)) {
    show_test_update(i, test_start_time)
    context$test <- i
    context$attempt <- 0

    while (context$attempt < max_attempts) {
      success <- run_test(grid[i, ], context)
      if (success) break
      context$attempt <- context$attempt + 1
    }
    if (context$attempt == max_attempts) skip_msg(i) else success_msg(i)
    cli_progress_update()
  }
  # Final Code
  final_run_msg(total, test_start_time)
  save_log(grid, output_dir)
}

prepare_dir <- function(path) {
  if (!dir.exists(path)) {
    dir.create(path, recursive = TRUE)
  } else {
    if (confirm_dir_overwrite(path)) {
      purrr::walk(list.files(path, full.names = T), unlink)
    }
  }
}

save_grid <- function(grid, output_dir) {
  vroom::vroom_write(grid, file.path(output_dir, "grid.tsv"))
}

save_log <- function(grid, output_dir) {
  log <- get_log()
  if (nrow(log) > 0) {
    output <- log %>%
      dplyr::left_join(grid, by = "test")

    if (!is.null(output_dir)) {
      vroom::vroom_write(output, file.path(output_dir, "skipped_tests.csv"))
    } else {
      vroom::vroom_write(output, "skipped_tests.csv")
    }
  }
}


#' Test your Runr
#'
#' `test_runr()` enables you to test your runr setup before committing to a full run.
#' Bladerunr will take the first row of your grid and call your runr with the full
#' params and context that would be expected for each iteration.
#'
#' @export
#'
test_runr <- function() {
  # Arg Checking
  check_args("blade_runr requires a dataframe grid to run.", any(class(grid) == "data.frame"))
  if (class(grid)[[1]] != "tbl_df") {
    grid <- as_tibble(grid)
  }
  if (is.null(get_config("runr"))) {
    cli::cli_abort("`blade_setup` must be called first to setup your runr")
  }

  # Create output dir
  output_dir <- get_config("output_dir")
  if (!is.null(output_dir)) {
    run_name <- get_config("run_name")
    output_dir <- file.path(output_dir, safeguard_run_name(run_name))
    set_config(output_dir = output_dir)
    prepare_dir(output_dir, force = FALSE)
    save_grid(grid, output_dir)
  } else {
    set_config(output_dir = ".")
    output_dir <- "."
  }

  cli::cli_alert_info("Beginning runr test.")
  # prepare context
  context <- get_context()


  context$test <- 1
  success <- run_test(grid[1, ], context)
  if (success) {
    cli::cli_alert_success("Runr did not cause any errors or timeouts.")
  } else {
    cli::cli_alert_danger("Runr was not able to complete successfully.")
  }
}

prepare_dir <- function(path, force) {
  if (!dir.exists(path)) {
    dir.create(path, recursive = TRUE)
  } else {
    if (force) {
      purrr::walk(list.files(path, full.names = T), unlink)
    } else if (confirm_dir_overwrite(path)) {
      purrr::walk(list.files(path, full.names = T), unlink)
    }
  }
}

save_grid <- function(grid, output_dir) {
  vroom::vroom_write(grid, file.path(output_dir, "grid.tsv"))
}

save_log <- function(grid, output_dir) {
  log <- get_log()
  if (nrow(log) > 0) {
    output <- log %>%
      dplyr::left_join(grid, by = "test")

    if (!is.null(output_dir)) {
      vroom::vroom_write(output, file.path(output_dir, "skipped_tests.csv"))
    } else {
      vroom::vroom_write(output, "skipped_tests.csv")
    }
  }
}