From 5f7844b8f96a4d0b289cd9fe2ea538823d526dd9 Mon Sep 17 00:00:00 2001 From: Tiffany Tang Date: Mon, 6 Jan 2025 12:05:26 -0600 Subject: [PATCH] Fix render_docs when save_in_bulk = FALSE (#200) * add `get_save_in_bulk()` method to `Experiment` class * update render_docs to work when `save_in_bulk = FALSE` --- R/experiment.R | 18 +++- inst/rmd/results.Rmd | 120 +++++++++++++++++++++++---- inst/rmd/results_header_template.Rmd | 118 ++++++++++++++++++++++---- man/Experiment.Rd | 14 ++++ tests/testthat/test-docs.R | 3 +- 5 files changed, 235 insertions(+), 38 deletions(-) diff --git a/R/experiment.R b/R/experiment.R index 18cd186..5c0cf9f 100644 --- a/R/experiment.R +++ b/R/experiment.R @@ -1121,8 +1121,10 @@ Experiment <- R6::R6Class( } else { save_dir <- private$.get_vary_across_dir() } - if (!dir.exists(file.path(save_dir, "fit_results"))) { - dir.create(file.path(save_dir, "fit_results"), recursive = TRUE) + if (!save_in_bulk) { + if (!dir.exists(file.path(save_dir, "fit_results"))) { + dir.create(file.path(save_dir, "fit_results"), recursive = TRUE) + } } dgp_list <- private$.get_obj_list("dgp") @@ -2271,6 +2273,18 @@ Experiment <- R6::R6Class( invisible(self) }, + #' @description Get the `save_in_bulk` parameter for the `Experiment`. + #' + #' @return Logical, indicating whether the results are saved in bulk or not. + get_save_in_bulk = function() { + save_in_bulk <- private$.save_in_bulk + if (is.null(save_in_bulk)) { + # for experiments created before save_in_bulk was introduced + save_in_bulk <- c(fit = TRUE, eval = TRUE, viz = TRUE) + } + return(save_in_bulk) + }, + #' @description Export all cached `Visualizer` results from an #' `Experiment` to images in the `viz_results/` directory under the #' `Experiment`'s results directory (see [get_save_dir()]). diff --git a/inst/rmd/results.Rmd b/inst/rmd/results.Rmd index 2a56679..eca3207 100644 --- a/inst/rmd/results.Rmd +++ b/inst/rmd/results.Rmd @@ -541,17 +541,63 @@ show_recipe <- function(field_name = c( #' Otherwise, the file is read in using data.table::fread(). #' #' @param filename name of file (with file extension) to try reading in -#' @return output of filename if the file exists and NULL otherwise -get_results <- function(filename, filetype = ".rds") { - if (file.exists(filename)) { - if (filetype == ".rds") { - results <- readRDS(filename) - } else { - results <- data.table::fread(results) +#' @param filetype file extension +#' @param experiment experiment object +#' @param experiment_save_dir directory where experiment results are saved +#' @param field_name one of "evaluator" or "visualizer" +#' @return output of experiment results if the file exists and NULL otherwise +get_results <- function(filename, filetype = ".rds", + experiment, experiment_save_dir = NULL, + field_name = c("evaluator", "visualizer")) { + field_name <- match.arg(field_name) + if (field_name == "evaluator") { + save_in_bulk <- experiment$get_save_in_bulk()[["eval"]] + } else if (field_name == "visualizer") { + save_in_bulk <- experiment$get_save_in_bulk()[["viz"]] + } + results <- NULL + if (save_in_bulk) { + if (file.exists(filename)) { + if (filetype == ".rds") { + results <- readRDS(filename) + } else { + results <- data.table::fread(results) + } } } else { - results <- NULL + if (is.null(experiment_save_dir)) { + stop("experiment_save_dir must be provided if save_in_bulk is FALSE") + } + if (field_name == "evaluator") { + obj_names <- names(experiment$get_evaluators()) + obj_dirname <- file.path(experiment_save_dir, "eval_results") + } else if (field_name == "visualizer") { + obj_names <- names(experiment$get_visualizers()) + obj_dirname <- file.path(experiment_save_dir, "viz_results") + } + if (length(obj_names) == 0) { + return(NULL) + } + names(obj_names) <- obj_names + results <- purrr::map( + obj_names, + function(obj_name) { + obj_fname <- file.path(obj_dirname, sprintf("%s%s", obj_name, filetype)) + if (file.exists(obj_fname)) { + if (filetype == ".rds") { + results <- readRDS(obj_fname) + } else { + results <- data.table::fread(obj_fname) + } + } else { + results <- NULL + } + return(results) + } + ) |> + purrr::compact() } + return(results) } @@ -596,39 +642,77 @@ get_exp_results <- function(dir_name, eval_cache = ".rds", viz_cache = ".rds") { exp_fname <- file.path(dir_name, "experiment.rds") - fit_fname <- file.path(dir_name, "fit_results.rds") eval_fname <- file.path(dir_name, sprintf("eval_results%s", eval_cache)) viz_fname <- file.path(dir_name, sprintf("viz_results%s", viz_cache)) - exp <- get_results(exp_fname) + if (file.exists(exp_fname)) { + exp <- readRDS(exp_fname) + } else { + results <- list( + exp = NULL, + eval_results = NULL, + viz_results = NULL + ) + return(results) + } fit_results <- NULL eval_results <- NULL viz_results <- NULL if ((eval_cache != "none") && (viz_cache == ".rds")) { if (show_eval) { - eval_results <- get_results(eval_fname, eval_cache) + eval_results <- get_results( + filename = eval_fname, + filetype = eval_cache, + experiment = exp, + experiment_save_dir = dir_name, + field_name = "evaluator" + ) } if (show_viz) { - viz_results <- get_results(viz_fname, viz_cache) + viz_results <- get_results( + filename = viz_fname, + filetype = viz_cache, + experiment = exp, + experiment_save_dir = dir_name, + field_name = "visualizer" + ) } } else { if (show_eval) { if (eval_cache == "none") { - fit_results <- get_results(fit_fname) + fit_results <- suppressMessages(get_cached_results(exp, "fit")) + if (is.null(fit_results)) { + stop("Cannot set eval_cache = 'none' since no cached fit results found. Perhaps try setting eval_cache = '.rds' instead.") + } eval_results <- evaluate_experiment(exp, fit_results) } else { - eval_results <- get_results(eval_fname, eval_cache) + eval_results <- get_results( + filename = eval_fname, + filetype = eval_cache, + experiment = exp, + experiment_save_dir = dir_name, + field_name = "evaluator" + ) } } if (show_viz) { if (viz_cache == ".rds") { - viz_results <- get_results(viz_fname, viz_cache) + viz_results <- get_results( + filename = viz_fname, + filetype = viz_cache, + experiment = exp, + experiment_save_dir = dir_name, + field_name = "visualizer" + ) } else if (viz_cache == "none") { if (is.null(fit_results)) { - fit_results <- get_results(fit_fname) + fit_results <- suppressMessages(get_cached_results(exp, "fit")) + if (is.null(fit_results)) { + stop("Cannot set viz_cache = 'none' since no cached fit results found. Perhaps try setting viz_cache = '.rds' instead.") + } } if (is.null(eval_results)) { - eval_results <- get_results(eval_fname) + eval_results <- suppressMessages(get_cached_results(exp, "eval")) if (is.null(eval_results)) { eval_results <- evaluate_experiment(exp, fit_results) } @@ -1044,7 +1128,7 @@ if (params$write) { ```{r evaluators, results = "asis"} eval_recipe <- show_recipe(field_name = "evaluator", write_flag = params$write) if (params$write) { - write_to_file(path = write_filename, "\n\n### Evaluation\n\n", eval_recipe) + write_to_file(path = write_filename, "\n\n## Evaluation\n\n", eval_recipe) } ``` diff --git a/inst/rmd/results_header_template.Rmd b/inst/rmd/results_header_template.Rmd index b0cf388..9460b85 100644 --- a/inst/rmd/results_header_template.Rmd +++ b/inst/rmd/results_header_template.Rmd @@ -77,17 +77,63 @@ get_descendants <- function(dir_name) { #' Otherwise, the file is read in using data.table::fread(). #' #' @param filename name of file (with file extension) to try reading in -#' @return output of filename if the file exists and NULL otherwise -get_results <- function(filename, filetype = ".rds") { - if (file.exists(filename)) { - if (filetype == ".rds") { - results <- readRDS(filename) - } else { - results <- data.table::fread(results) +#' @param filetype file extension +#' @param experiment experiment object +#' @param experiment_save_dir directory where experiment results are saved +#' @param field_name one of "evaluator" or "visualizer" +#' @return output of experiment results if the file exists and NULL otherwise +get_results <- function(filename, filetype = ".rds", + experiment, experiment_save_dir = NULL, + field_name = c("evaluator", "visualizer")) { + field_name <- match.arg(field_name) + if (field_name == "evaluator") { + save_in_bulk <- experiment$get_save_in_bulk()[["eval"]] + } else if (field_name == "visualizer") { + save_in_bulk <- experiment$get_save_in_bulk()[["viz"]] + } + results <- NULL + if (save_in_bulk) { + if (file.exists(filename)) { + if (filetype == ".rds") { + results <- readRDS(filename) + } else { + results <- data.table::fread(results) + } } } else { - results <- NULL + if (is.null(experiment_save_dir)) { + stop("experiment_save_dir must be provided if save_in_bulk is FALSE") + } + if (field_name == "evaluator") { + obj_names <- names(experiment$get_evaluators()) + obj_dirname <- file.path(experiment_save_dir, "eval_results") + } else if (field_name == "visualizer") { + obj_names <- names(experiment$get_visualizers()) + obj_dirname <- file.path(experiment_save_dir, "viz_results") + } + if (length(obj_names) == 0) { + return(NULL) + } + names(obj_names) <- obj_names + results <- purrr::map( + obj_names, + function(obj_name) { + obj_fname <- file.path(obj_dirname, sprintf("%s%s", obj_name, filetype)) + if (file.exists(obj_fname)) { + if (filetype == ".rds") { + results <- readRDS(obj_fname) + } else { + results <- data.table::fread(obj_fname) + } + } else { + results <- NULL + } + return(results) + } + ) |> + purrr::compact() } + return(results) } @@ -132,39 +178,77 @@ get_exp_results <- function(dir_name, eval_cache = ".rds", viz_cache = ".rds") { exp_fname <- file.path(dir_name, "experiment.rds") - fit_fname <- file.path(dir_name, "fit_results.rds") eval_fname <- file.path(dir_name, sprintf("eval_results%s", eval_cache)) viz_fname <- file.path(dir_name, sprintf("viz_results%s", viz_cache)) - exp <- get_results(exp_fname) + if (file.exists(exp_fname)) { + exp <- readRDS(exp_fname) + } else { + results <- list( + exp = NULL, + eval_results = NULL, + viz_results = NULL + ) + return(results) + } fit_results <- NULL eval_results <- NULL viz_results <- NULL if ((eval_cache != "none") && (viz_cache == ".rds")) { if (show_eval) { - eval_results <- get_results(eval_fname, eval_cache) + eval_results <- get_results( + filename = eval_fname, + filetype = eval_cache, + experiment = exp, + experiment_save_dir = dir_name, + field_name = "evaluator" + ) } if (show_viz) { - viz_results <- get_results(viz_fname, viz_cache) + viz_results <- get_results( + filename = viz_fname, + filetype = viz_cache, + experiment = exp, + experiment_save_dir = dir_name, + field_name = "visualizer" + ) } } else { if (show_eval) { if (eval_cache == "none") { - fit_results <- get_results(fit_fname) + fit_results <- suppressMessages(get_cached_results(exp, "fit")) + if (is.null(fit_results)) { + stop("Cannot set eval_cache = 'none' since no cached fit results found. Perhaps try setting eval_cache = '.rds' instead.") + } eval_results <- evaluate_experiment(exp, fit_results) } else { - eval_results <- get_results(eval_fname, eval_cache) + eval_results <- get_results( + filename = eval_fname, + filetype = eval_cache, + experiment = exp, + experiment_save_dir = dir_name, + field_name = "evaluator" + ) } } if (show_viz) { if (viz_cache == ".rds") { - viz_results <- get_results(viz_fname, viz_cache) + viz_results <- get_results( + filename = viz_fname, + filetype = viz_cache, + experiment = exp, + experiment_save_dir = dir_name, + field_name = "visualizer" + ) } else if (viz_cache == "none") { if (is.null(fit_results)) { - fit_results <- get_results(fit_fname) + fit_results <- suppressMessages(get_cached_results(exp, "fit")) + if (is.null(fit_results)) { + stop("Cannot set viz_cache = 'none' since no cached fit results found. Perhaps try setting viz_cache = '.rds' instead.") + } } if (is.null(eval_results)) { - eval_results <- get_results(eval_fname) + eval_results <- suppressMessages(get_cached_results(exp, "eval")) if (is.null(eval_results)) { eval_results <- evaluate_experiment(exp, fit_results) } diff --git a/man/Experiment.Rd b/man/Experiment.Rd index 8685149..2d2fa13 100644 --- a/man/Experiment.Rd +++ b/man/Experiment.Rd @@ -69,6 +69,7 @@ first argument: \code{\link[=create_experiment]{create_experiment()}}, \code{\li \item \href{#method-Experiment-get_save_dir}{\code{Experiment$get_save_dir()}} \item \href{#method-Experiment-set_save_dir}{\code{Experiment$set_save_dir()}} \item \href{#method-Experiment-save}{\code{Experiment$save()}} +\item \href{#method-Experiment-get_save_in_bulk}{\code{Experiment$get_save_in_bulk()}} \item \href{#method-Experiment-export_visualizers}{\code{Experiment$export_visualizers()}} \item \href{#method-Experiment-print}{\code{Experiment$print()}} \item \href{#method-Experiment-clone}{\code{Experiment$clone()}} @@ -1055,6 +1056,19 @@ The \code{Experiment} object, invisibly. } } \if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Experiment-get_save_in_bulk}{}}} +\subsection{Method \code{get_save_in_bulk()}}{ +Get the \code{save_in_bulk} parameter for the \code{Experiment}. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Experiment$get_save_in_bulk()}\if{html}{\out{
}} +} + +\subsection{Returns}{ +Logical, indicating whether the results are saved in bulk or not. +} +} +\if{html}{\out{
}} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Experiment-export_visualizers}{}}} \subsection{Method \code{export_visualizers()}}{ diff --git a/tests/testthat/test-docs.R b/tests/testthat/test-docs.R index 64a7532..8521a21 100644 --- a/tests/testthat/test-docs.R +++ b/tests/testthat/test-docs.R @@ -73,7 +73,8 @@ withr::with_tempdir(pattern = "simChef-test-checkpointing-temp", code = { greatgrandchild2 <- create_experiment( name = "greatgrandchild2", clone_from = grandchild2, - save_dir = file.path(grandchild2$get_save_dir(), "greatgrandchild2") + save_dir = file.path(grandchild2$get_save_dir(), "greatgrandchild2"), + save_in_bulk = FALSE ) results <- greatgrandchild2$run(save = TRUE, verbose = 0) export_visualizers(greatgrandchild2)