In Yu-Group/simChef: Intensive Computational Experiments Made Easy

knitr::opts_chunk$set(
  echo = FALSE,
  warning = FALSE,
  message = FALSE,
  cache = FALSE,
  fig.align = "center",
  fig.pos = "H",
  fig.height = 12,
  fig.width = 10
)

options(
  width = 10000,
  knitr.kable.NA = 'NA'
)

library(simChef)

local({
  hook_output <- knitr::knit_hooks$get("output")
  knitr::knit_hooks$set(
    # scrollable text output
    output = function(x, options) {
      if (!is.null(options$max.height)) {
        options$attr.output <- c(
          options$attr.output,
          sprintf('style="max-height: %s;"', options$max.height)
        )
      }
      hook_output(x, options)
    },
    # add panel around figures
    add.panel = function(before, options, envir) {
      if (before) {
        HTML("<div class='panel panel-default padded-panel'>")
      } else {
        HTML("</div>")
      }
    }
  )
})

#' Get all experiments under a given directory name.
#'
#' @param dir_name Name of directory.
#' @return List of named experiments.
get_descendants <- function(dir_name) {
  experiments <- list()
  for (d in list.dirs(dir_name)) {
    if (file.exists(file.path(d, "experiment.rds"))) {
      if (identical(d, params$sim_path)) {
        exp_name <- "Base"
      } else {
        exp_name <- stringr::str_replace_all(
          stringr::str_remove(d, paste0(params$sim_path, "/")),
          "/", " - "
        )
      }
      experiments[[exp_name]] <- readRDS(file.path(d, "experiment.rds"))
    }
  }
  return(experiments)
}

#' Reads in file if it exists and returns NULL if the file does not exist
#' 
#' @description If filetype is ".rds", the file is read in using readRDS(). 
#'   Otherwise, the file is read in using data.table::fread().
#'
#' @param filename name of file (with file extension) to try reading in
#' @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 {
    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)
}

#' Reads in list of image result files
#' 
#' @param filenames vector of filenames (without file extension) to read in
#' @param filetype file extension
#' @return list of image results, wrapped as knitr::include_graphics() objects
get_image_results <- function(filenames, filetype) {
  purrr::map(
    filenames,
    function(f) {
      if (file.exists(sprintf("%s%s", f, filetype))) {
        return(knitr::include_graphics(sprintf("%s%s", f, filetype)))
      } else {
        return(NULL)
      }
    }
  ) |> 
    setNames(basename(filenames)) |> 
    purrr::compact()
}

#' Get results from experiment
#' 
#' @param dir_name name of directory
#' @param show_eval logical; whether or not to show evaluators
#' @param show_viz logical; whether or not to show visualizers
#' @param eval_cache file extension for cached evaluator results to read in.
#'   Typically ".rds" or "none", but can be any file extension where
#'   evaluator results are stored as `eval_results.ext` and can be read in
#'   using `data.table::fread(eval_results.ext)`. If "none", evaluator results
#'   are computed using the experiment via `evaluate_experiment()`.
#' @param viz_cache file extension for cached visualizer results to read in.
#'   Typically ".rds" or "none", but can be any (image) file extension 
#'   (e.g., "png", "jpg") where the visualizer results have been previously 
#'   stored as separate `{visualizer_name}.ext` images (e.g., using
#'   `export_visualizers()`). If "none", visualizer results are computed using
#'   the experiment via `visualize_experiment()`.
get_exp_results <- function(dir_name, 
                            show_eval = TRUE, show_viz = TRUE,
                            eval_cache = ".rds", viz_cache = ".rds") {

  exp_fname <- file.path(dir_name, "experiment.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))

  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(
        filename = eval_fname, 
        filetype = eval_cache, 
        experiment = exp, 
        experiment_save_dir = dir_name,
        field_name = "evaluator"
      )
    }
    if (show_viz) {
      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 <- 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(
          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(
          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 <- 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 <- suppressMessages(get_cached_results(exp, "eval"))
          if (is.null(eval_results)) {
            eval_results <- evaluate_experiment(exp, fit_results)
          }
        }
        viz_results <- visualize_experiment(exp, fit_results, eval_results)
      } else {
        viz_results <- get_image_results(
          file.path(dir_name, names(exp$get_visualizers())), viz_cache
        )
      }
    }
  }
  results <- list(
    exp = exp,
    eval_results = eval_results,
    viz_results = viz_results
  )
  return(results)
}

#' Print renv lockfile info
#' 
#' @param renv_lockfile renv lockfile object from [renv::lockfile_read()]
#' @param what part of renv lockfile to print; must be one of "R" or "packages"
#' @param print_table logical; whether to print as a nice table (TRUE) or 
#'   simply using the `print` method.
#' @return renv lockfile info
print_renv <- function(renv_lockfile, 
                       what = c("R", "Packages"),
                       print_table = FALSE) {
  what <- match.arg(what)
  if (what == "R") {
    if (print_table) {
      tab <- tibble::tibble(
        `R Version` = renv_lockfile$R$Version, 
        Repositories = paste(
          names(renv_lockfile$R$Repositories), 
          " (", renv_lockfile$R$Repositories, ")", 
          sep = "", collapse = "<br>"
        )
      ) |> 
        vthemes::pretty_DT(
          rownames = FALSE, options = list(dom = "t", ordering = FALSE)
        )
      return(tab)
    } else {
      return(renv_lockfile$R)
    }
  } else {
    if (print_table) {
      tab <- tibble::tibble(
        `Package Name` = purrr::map_chr(
          renv_lockfile$Packages, 
          function(.x) if (!is.null(.x$Package)) .x$Package else "N/A"
        ),
        `Version` = purrr::map_chr(
          renv_lockfile$Packages,
          function(.x) if (!is.null(.x$Version)) .x$Version else "N/A"
        ),
        `Source` = purrr::map_chr(
          renv_lockfile$Packages,
          function(.x) if (!is.null(.x$Source)) .x$Source else "N/A"
        ),
        `Repository` = purrr::map_chr(
          renv_lockfile$Packages,
          function(.x) {
            if (!is.null(.x$Repository)) {
              .x$Repository
            } else if (!is.null(.x$RemoteUrl)) {
              .x$RemoteUrl
            } else if (.x$Source == "GitHub") {
              sprintf("https://github.com/%s/%s", .x$RemoteUsername, .x$RemoteRepo)
            } else {
              "N/A"
            }
          }
        ),
        `Requirements` = purrr::map_chr(
          renv_lockfile$Packages, ~ paste(.x$Requirements, collapse = ", ")
        )
      ) |> 
        vthemes::pretty_DT(rownames = FALSE)
      return(tab)
    } else {
      return(renv_lockfile$Packages)
    }
  }
}

#' Show recipe content.
#' 
#' @param objs List of DGP/Method/Evaluator/Visualizer objects. Should be one of
#'   `dgp_objs`, `method_objs`, `eval_objs`, or `viz_objs` defined below.
#' @param name Name of DGP/Method/Evaluator/Visualizer.
#' @param experiment_name Name of the Experiment.
#' @param what Either "function" or "parameters", indicating whether to return 
#'   the function code or parameters.
show_recipe <- function(objs, name, experiment_name,
                        what = c("function", "parameters")) {
  what <- match.arg(what)
  obj <- objs[[experiment_name]][[name]]
  field_name <- tolower(class(obj)[1])
  func_name <- dplyr::case_when(
    field_name == "evaluator" ~ "eval",
    field_name == "visualizer" ~ "viz",
    TRUE ~ field_name
  )
  if (identical(what, "function")) {
    return(obj[[paste0(func_name, "_fun")]])
  } else if (identical(what, "parameters")) {
    return(obj[[paste0(func_name, "_params")]])
  }
}

#' Show results of Evaluator, Visualizer, or Varying Across Parameters.
#' 
#' @param dir_name Name of directory of Experiment.
#' @param name Name of Evaluator/Visualizer.
#' @param field_name One of "evaluator", "visualizer", or "vary_params", 
#'   indicating whether to return the results of an Evaluator, Visualizer, or
#'   the varying across parameters of the Experiment, respectively.
show_results <- function(results, name,
                         field_name = c("evaluator", "visualizer", "vary_params")) {
  field_name <- match.arg(field_name)
  exp <- results$exp
  eval_results <- results$eval_results
  viz_results <- results$viz_results

  if (field_name == "evaluator") {
    doc_nrows <- exp$get_evaluators()[[name]]$doc_nrows
    if (is.null(doc_nrows)) {
      eval_results_show <- eval_results[[name]]
    } else {
      keep_rows <- 1:min(doc_nrows, nrow(eval_results[[name]]))
      eval_results_show <- eval_results[[name]][keep_rows, ]
    }
    do.call(vthemes::pretty_DT,
            c(list(eval_results_show),
              exp$get_evaluators()[[name]]$doc_options))
  } else if (field_name == "visualizer") {
    viz_results[[name]]
  } else if (field_name == "vary_params") {
    exp$get_vary_across()
  }
}

Simulation Experiment Recipe {.tabset .tabset-vmodern}

descendants <- get_descendants(dir_name = params$sim_path)
dgp_objs <- purrr::map(descendants, ~.x$get_dgps())
method_objs <- purrr::map(descendants, ~.x$get_methods())
eval_objs <- purrr::map(descendants, ~.x$get_evaluators())
viz_objs <- purrr::map(descendants, ~.x$get_visualizers())