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"
)

# scrollable text output
local({
  hook_output <- knitr::knit_hooks$get("output")
  knitr::knit_hooks$set(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)
  })
})

chunk_idx <- 1
doc_dir <- file.path(params$sim_path, "docs")
write_filename <- params$write_filename

#' Wrap text/code in knitr code chunk string
#'
#' @param code String of code to wrap in knitr code chunk
#' @param chunk_args String of arguments to place in the knitr code chunk header
#' @return String of code, wrapped inside the knitr code chunk ``` markers
write_code_chunk <- function(code = "", chunk_args = "") {
  sprintf("\n```r\n%s\n```\n", chunk_args, code)
}

#' Write text to vector (write_flag = TRUE) or to console (write_flag = FALSE)
#'
#' @param ... Text to write to vector or to console
#' @param old_text Previous text to append to when writing to a vector
#' @param write_flag Boolean indicating whether to write text to a vector
#'   (write_flag = TRUE) or to console (write_flag = FALSE)
#' @return If write_flag = TRUE, returns vector of text. Otherwise, text is
#'   written to console via `cat()`.
write <- function(..., old_text = NULL, write_flag) {
  if (write_flag) {
    return(c(old_text, ...))
  } else {
    dots_list <- list(...) %>%
      purrr::map(
        function(x) {
          if (stringr::str_detect(x, "`r .*`")) {
            # run r code before printing results in cat()
            out <- stringr::str_replace(
              x, "`r .*`",
              eval(parse(text = stringr::str_extract(x, "(?<=`r )(.*?)(?=`)")))
            )
          } else {
            out <- x
          }
          return(out)
        }
      )
    do.call(cat, args = c(dots_list, list(sep = "")))
  }
}

#' Write text to file
#'
#' @param path Path to output file
#' @param ... Text to output to file
write_to_file <- function(path, ...) {
  storelines <- readLines(path)
  storelines <- c(storelines, ...)
  writeLines(storelines, path)
}

#' Get order of objects to display
#'
#' @param obj_names Vector of all object names that need to be displayed.
#' @param obj_order Vector of object names in the desired appearance order.
#' @return Vector of object names in the order in which they will be displayed.
get_object_order <- function(obj_names, obj_order = NULL) {
  if (is.null(obj_order)) {
    return(obj_names)
  } else {
    return(intersect(obj_order, obj_names))
  }
}

#' 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)
}

#' Check if experiment exists
#'
#' @param dir_name name of directory or vector thereof
#' @param recursive logical; if TRUE, checks if experiment exists under the
#'   given directory(s); if FALSE, checks if any experiment exists under the
#'   directory(s) and its descendants
#' @return TRUE if experiment exists and FALSE otherwise
experiment_exists <- function(dir_name, recursive = FALSE) {
  res <- purrr::map_lgl(
    dir_name,
    function(d) {
      if (!recursive) {
        exp_fname <- file.path(d, "experiment.rds")
        return(file.exists(exp_fname))
      } else {
        descendants <- get_descendants(d)
        return(length(descendants) > 0)
      }
    }
  )
  return(any(res))
}

#' Displays content for specified part of recipe
#'
#' @param field_name part of recipe to show; must be one of "dgp", "method",
#'   "evaluator", or "visualizer"
#' @param write_flag Boolean indicating whether to write text to a vector
#'   (write_flag = TRUE) or to console (write_flag = FALSE)
#' @return content for recipe
show_recipe <- function(field_name = c(
                          "dgp", "method", "evaluator", "visualizer"
                        ),
                        write_flag = FALSE) {
  field_name <- match.arg(field_name)
  func_name <- dplyr::case_when(
    field_name == "evaluator" ~ "eval",
    field_name == "visualizer" ~ "viz",
    TRUE ~ field_name
  )
  descendants <- get_descendants(dir_name = params$sim_path)
  objs <- purrr::map(descendants, ~ .x[[paste0("get_", field_name, "s")]]())
  obj_names <- unique(purrr::reduce(sapply(objs, names), c))

  if (field_name %in% c("method", "evaluator")) {
    obj_header <- "\n\n#### %s {.tabset .tabset-pills .tabset-circle .tabset-recipe}\n\n"
    showtype_header <- "\n\n##### %s {.tabset .tabset-pills}\n\n"
    exp_header <- "\n\n###### %s \n\n"
  } else {
    obj_header <- "\n\n### %s {.tabset .tabset-pills .tabset-circle .tabset-recipe}\n\n"
    showtype_header <- "\n\n#### %s {.tabset .tabset-pills}\n\n"
    exp_header <- "\n\n##### %s \n\n"
  }

  if (params$use_icons) {
    if (params$use_vmodern) {
      description_label <- "`r fontawesome::fa('readme', fill = 'white')`"
      code_label <- "`r fontawesome::fa('code', fill = 'white')`"
    } else {
      description_label <- "`r fontawesome::fa('readme')`"
      code_label <- "`r fontawesome::fa('code')`"
    }
  } else {
    description_label <- "Description"
    code_label <- "Code"
  }

  if (all(sapply(objs, length) == 0)) {
    if (write_flag) {
      return("N/A")
    } else {
      return(cat("N/A"))
    }
  }

  recipe <- c()
  for (idx in 1:length(obj_names)) {
    obj_name <- obj_names[idx]
    description_fpath <- file.path(
      doc_dir, paste0(field_name, "s"), paste0(obj_name, ".md")
    )

    if (params$use_vmodern) {
      recipe <- write(
        "\n\n<div class='panel panel-default padded-panel'>\n\n",
        old_text = recipe, write_flag = write_flag
      )
    }

    recipe <- write(
      sprintf(obj_header, obj_name),
      sprintf(showtype_header, description_label),
      pasteMd(description_fpath),
      old_text = recipe, write_flag = write_flag
    )

    if (params$show_code) {
      recipe <- write(
        sprintf(showtype_header, code_label),
        old_text = recipe, write_flag = write_flag
      )

      keep_objs <- purrr::compact(purrr::map(objs, obj_name))
      is_identical <- all(
        purrr::map_lgl(keep_objs, ~ isTRUE(check_equal(.x, keep_objs[[1]])))
      )
      for (exp in names(keep_objs)) {
        obj <- keep_objs[[exp]]
        if (!is_identical) {
          recipe <- write(
            sprintf(exp_header, exp),
            old_text = recipe, write_flag = write_flag
          )
        }

        recipe <- write(
          "\n\n**Function**\n\n",
          old_text = recipe, write_flag = write_flag
        )
        if (write_flag) {
          recipe <- sprintf(
            "show_recipe(%s_objs, '%s', '%s', what = 'function')",
            func_name, obj_name, exp
          ) %>%
            write_code_chunk(chunk_args = "max.height='200px'") %>%
            write(old_text = recipe, write_flag = write_flag)
        } else {
          vthemes::subchunkify(
            obj[[paste0(func_name, "_fun")]], chunk_idx,
            other_args = "max.height='200px'"
          )
          chunk_idx <<- chunk_idx + 1
        }

        recipe <- write(
          "\n\n**Input Parameters**\n\n",
          old_text = recipe, write_flag = write_flag
        )
        if (write_flag) {
          recipe <- sprintf(
            "show_recipe(%s_objs, '%s', '%s', what = 'parameters')",
            func_name, obj_name, exp
          ) %>%
            write_code_chunk(chunk_args = "max.height='200px'") %>%
            write(old_text = recipe, write_flag = write_flag)
        } else {
          vthemes::subchunkify(
            obj[[paste0(func_name, "_params")]], chunk_idx,
            other_args = "max.height='200px'"
          )
          chunk_idx <<- chunk_idx + 1
        }

        if (is_identical) {
          break
        }
      }
    }

    if (params$use_vmodern) {
      recipe <- write(
        "\n\n</div>\n\n", old_text = recipe, write_flag = write_flag
      )
    }
  }

  return(recipe)
}

#' Reads in file if it exists and returns NULL if the file does not exist
#'
#' @param filename name of .rds file to try reading in
#' @return output of filename.rds if the file exists and NULL otherwise
get_results <- function(filename) {
  if (file.exists(filename)) {
    results <- readRDS(filename)
  } else {
    results <- NULL
  }
  return(results)
}

#' Displays output (both from evaluate() and visualize()) from saved results under
#' a specified directory
#'
#' @param dir_name name of directory
#' @param depth integer; depth of directory from parent/base experiment's folder
#' @param base logical; whether or not this is a base experiment
#' @param show_header logical; whether or not to show section header
#' @param verbose integer; 0 = no messages; 1 = print out directory name only;
#'   2 = print out directory name and name of evaluators/visualizers
#' @param write_flag Boolean indicating whether to write text to a vector
#'   (write_flag = TRUE) or to console (write_flag = FALSE)
#' @return content results from evaluate() and visualize() from the experiment
show_results <- function(dir_name, depth, base = FALSE, show_header = TRUE,
                         verbose = 1, write_flag = FALSE) {
  if (verbose >= 1) {
    inform(paste0(paste(rep("*", depth), collapse = ""), basename(dir_name)))
  }

  if (depth == 1) {
    header_template <- "\n\n%s %s {.tabset .tabset-pills .tabset-vmodern}\n\n"
  } else {
    if (base || !experiment_exists(dir_name)) {
      header_template <- "\n\n%s %s {.tabset .tabset-pills}\n\n"
    } else {
      header_template <- "\n\n%s %s {.tabset .tabset-pills .tabset-circle}\n\n"
    }
  }

  results <- c()
  if (show_header) {
    results <- sprintf(
      header_template,
      paste(rep("#", depth), collapse = ""),
      basename(dir_name)
    ) %>%
      write(old_text = results, write_flag = write_flag)
  }

  if (base) {
    results <- sprintf(
      "\n\n%s Base - %s {.tabset .tabset-pills .tabset-circle}\n\n",
      paste(rep("#", depth + 1), collapse = ""),
      basename(dir_name)
    ) %>%
      write(old_text = results, write_flag = write_flag)
    depth <- depth + 1
  }

  showtype_template <- paste0(
    "\n\n", paste(rep("#", depth + 1), collapse = ""), " %s\n\n"
  )
  figname_template <- paste0(
    "\n\n", paste(rep("#", depth + 2), collapse = ""), " %s\n\n"
  )
  invisible_header <- paste0(
    "\n\n", paste(rep("#", depth + 3), collapse = ""),
    " {.tabset .tabset-pills}\n\n"
  )
  plt_template <- paste0(
    "\n\n", paste(rep("#", depth + 4), collapse = ""), " %s\n\n"
  )

  if (params$use_icons) {
    if (params$use_vmodern) {
      evaluator_label <- "`r fontawesome::fa('table', fill = 'white')`"
      visualizer_label <- "`r fontawesome::fa('chart-bar', fill = 'white')`"
      code_label <- "`r fontawesome::fa('code', fill = 'white')`"
    } else {
      evaluator_label <- "`r fontawesome::fa('table')`"
      visualizer_label <- "`r fontawesome::fa('chart-bar')`"
      code_label <- "`r fontawesome::fa('code')`"
    }
  } else {
    evaluator_label <- "Evaluators"
    visualizer_label <- "Visualizers"
    code_label <- "Varying Parameters"
  }

  exp_fname <- file.path(dir_name, "experiment.rds")
  eval_fname <- file.path(dir_name, "eval_results.rds")
  viz_fname <- file.path(dir_name, "viz_results.rds")

  exp <- get_results(exp_fname)
  eval_results <- get_results(eval_fname)
  viz_results <- get_results(viz_fname)

  if (!is.null(eval_results) && params$show_eval) {
    results <- write(
      sprintf(showtype_template, evaluator_label),
      old_text = results, write_flag = write_flag
    )

    eval_names <- get_object_order(names(eval_results), params$eval_order)
    for (eval_name in eval_names) {
      evaluator <- exp$get_evaluators()[[eval_name]]
      if (evaluator$doc_show) {
        if (verbose >= 1) {
          inform(paste0(paste(rep(" ", depth + 1), collapse = ""), eval_name))
        }
        results <- write(
          sprintf(figname_template, eval_name),
          old_text = results, write_flag = write_flag
        )
        if (is.null(evaluator$doc_nrows)) {
          eval_results_show <- eval_results[[eval_name]]
        } else {
          keep_rows <- 1:min(evaluator$doc_nrows, nrow(eval_results[[eval_name]]))
          eval_results_show <- eval_results[[eval_name]][keep_rows, ]
          if (nrow(eval_results[[eval_name]]) > evaluator$doc_nrows) {
            omitted_nrows <- nrow(eval_results[[eval_name]]) - evaluator$doc_nrows
            results <- write(
              sprintf(
                "Showing preview of %s results. %s rows have been omitted.\n\n",
                eval_name, omitted_nrows
              ),
              old_text = results, write_flag = write_flag
            )
          }
        }
        if (write_flag) {
          results <- sprintf(
            "show_results('%s', '%s', 'evaluator')", dir_name, eval_name
          ) %>%
            write_code_chunk(chunk_args = "results = 'asis'") %>%
            write(old_text = results, write_flag = write_flag)
        } else {
          do.call(
            vthemes::pretty_DT,
            c(list(eval_results_show), evaluator$doc_options)
          ) %>%
            vthemes::subchunkify(i = chunk_idx)
          chunk_idx <<- chunk_idx + 1
        }
      }
    }
  }

  if (!is.null(viz_results) && params$show_viz) {
    results <- write(
      sprintf(showtype_template, visualizer_label),
      old_text = results, write_flag = write_flag
    )

    viz_names <- get_object_order(names(viz_results), params$viz_order)
    for (viz_name in viz_names) {
      visualizer <- exp$get_visualizers()[[viz_name]]
      if (visualizer$doc_show) {
        if (verbose >= 1) {
          inform(paste0(paste(rep(" ", depth + 1), collapse = ""), viz_name))
        }
        results <- write(
          sprintf(figname_template, viz_name),
          invisible_header,
          old_text = results, write_flag = write_flag
        )
        plts <- viz_results[[viz_name]]
        if (!inherits(plts, "list")) {
          plts <- list(plt = plts)
        }
        if (is.null(names(plts))) {
          names(plts) <- 1:length(plts)
        }
        for (plt_name in names(plts)) {
          if (length(plts) != 1) {
            results <- write(
              sprintf(plt_template, plt_name),
              old_text = results, write_flag = write_flag
            )
          }
          plt <- plts[[plt_name]]
          is_plot <- inherits(plt, "plotly") || 
            inherits(plt, "gg") || 
            inherits(plt, "ggplot")

          if (params$use_vmodern && is_plot) {
            chunk_args <- "fig.height = %s, fig.width = %s, out.width = '100%%', add.panel = TRUE"
            add_class <- "panel panel-default padded-panel"
          } else {
            chunk_args <- "fig.height = %s, fig.width = %s, out.width = '100%%'"
            add_class <- NULL
          }

          if (write_flag) {
            results <- sprintf(
              "show_results('%s', '%s', 'visualizer')", dir_name, viz_name
            ) %>%
              write_code_chunk(
                chunk_args = sprintf(
                  chunk_args,
                  visualizer$doc_options$height, visualizer$doc_options$width
                )
              ) %>%
              write(old_text = results, write_flag = write_flag)
          } else {
            vthemes::subchunkify(plt,
              i = chunk_idx,
              fig_height = visualizer$doc_options$height,
              fig_width = visualizer$doc_options$width,
              other_args = "out.width = '100%'", 
              add_class = add_class
            )
            chunk_idx <<- chunk_idx + 1
          }
        }
      }
    }
  }

  if (!is.null(exp) && params$show_code) {
    if ((length(exp$get_vary_across()$dgp) != 0) ||
        (length(exp$get_vary_across()$method) != 0)) {
      results <- write(
        sprintf(showtype_template, code_label),
        "\n\n**Parameter Values**\n\n",
        old_text = results, write_flag = write_flag
      )
      if (write_flag) {
        results <- sprintf(
          "show_results('%s', NULL, 'vary_params')", dir_name
        ) %>%
          write_code_chunk(chunk_args = "max.height='200px'") %>%
          write(old_text = results, write_flag = write_flag)
      } else {
        vthemes::subchunkify(exp$get_vary_across(),
          chunk_idx,
          other_args = "max.height='200px'"
        )
        chunk_idx <<- chunk_idx + 1
      }
    }
  }

  return(results)
}

#' Displays output of experiment for all of its (saved) descendants
#'
#' @param dir_name name of parent experiment directory
#' @param depth placeholder for recursion; should not be messed with
#' @param write_flag Boolean indicating whether to write text to a file
#'   (write_flag = TRUE) or to console (write_flag = FALSE)
#' @param write_filename Name of file to write to if write_flag = TRUE
#' @param ... other arguments to pass into show_results()
show_descendant_results <- function(dir_name, depth = 1, write_flag = FALSE,
                                    write_filename = NULL, ...) {
  children <- list.dirs(dir_name, recursive = FALSE)
  if (length(children) == 0) {
    return()
  }
  for (child_idx in 1:length(children)) {
    child <- children[child_idx]
    if (!experiment_exists(child, recursive = TRUE)) {
      next
    }
    if (experiment_exists(child, recursive = FALSE) &&
      (experiment_exists(list.dirs(child, recursive = TRUE)[-1]) ||
        (depth == 1))) {
      base <- TRUE
    } else {
      base <- FALSE
    }
    results <- show_results(child, depth, base, write_flag = write_flag, ...)
    if (write_flag) {
      write_to_file(path = write_filename, results)
    }
    show_descendant_results(child, depth + 1, write_flag, write_filename, ...)
  }
}

#' Clean output file (e.g., remove excessive blank lines)
#'
#' @param path Path to output file
clean_file <- function(path) {
  storelines <- readLines(path)
  rle_out <- rle(storelines == "")
  line_ids <- which((rle_out$lengths > 2) & rle_out$values)
  keep_lines <- rep(TRUE, length(storelines))
  for (line_id in line_ids) {
    num_blank <- rle_out$lengths[line_id]
    line_ptr <- sum(rle_out$lengths[1:line_id])
    # only allow for max of two consecutive blank lines
    keep_lines[(line_ptr - num_blank + 3):line_ptr] <- FALSE
  }
  writeLines(storelines[keep_lines], path)
}

#' Insert lines to add extra resources (css/js) for simChef R Markdown theme
#' 
#' @param path Path to output file
insert_simChef_resources <- function(path) {
  storelines <- readLines(path)
  pattern <- "<Insert extra simChef resources here>"
  replace <- sprintf(
    '<script src="%s"></script>\n\n<link rel="stylesheet" href="%s">', 
    system.file("rmd", "js", "simchefNavClass.js",
                package = utils::packageName()),
    system.file("rmd", "css", "simchef.css",
                package = utils::packageName())
  ) 
  storelines[storelines == pattern] <- replace
  writeLines(storelines, path)
}

#' Remove lines with simChef R Markdown theme-specific code
#' 
#' @param path Path to output file
remove_simChef_resources <- function(path) {
  storelines <- readLines(path)

  pattern <- "add.panel = function"
  line_id <- which(stringr::str_detect(storelines, pattern))
  remove_lines <- (line_id - 2):(line_id + 5)
  storelines <- storelines[-remove_lines]

  pattern <- "<Insert extra simChef resources here>"
  remove_lines <- which(stringr::str_detect(storelines, pattern))
  storelines <- storelines[-remove_lines]

  writeLines(storelines, path)
}

if (params$write) {
  if (params$use_vmodern) {
    insert_simChef_resources(write_filename)
  } else {
    remove_simChef_resources(write_filename)
  }
} else {
  if (params$use_vmodern) {
    htmltools::HTML('<script src="js/simchefNavClass.js"></script>\n\n<link rel="stylesheet" href="css/simchef.css">')
  }
}

Simulation Experiment Recipe {.tabset .tabset-vmodern}

Objectives

if (params$use_vmodern) {
  objectives <- write(
    "\n\n<div class='panel panel-default padded-panel'>\n\n",
    pasteMd(file.path(doc_dir, "objectives.md")),
    "\n\n</div>\n\n",
    write_flag = params$write
  )
} else {
  objectives <- write(
    pasteMd(file.path(doc_dir, "objectives.md")),
    write_flag = params$write
  )
}
if (params$write) {
  write_to_file(path = write_filename, "\n\n## Objectives\n\n", objectives)
}

Data Generation

dgp_recipe <- show_recipe(field_name = "dgp", write_flag = params$write)
if (params$write) {
  write_to_file(path = write_filename, "\n\n## Data Generation\n\n", dgp_recipe)
}

Methods and Evaluation

Methods

method_recipe <- show_recipe(field_name = "method", write_flag = params$write)
if (params$write) {
  write_to_file(
    path = write_filename,
    "\n\n## Methods and Evaluation\n\n", "\n\n### Methods\n\n",
    method_recipe
  )
}

Evaluation

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)
}

Visualizations

viz_recipe <- show_recipe(field_name = "visualizer", write_flag = params$write)
if (params$write) {
  write_to_file(path = write_filename, "\n\n## Visualizations\n\n", viz_recipe)
}

if (params$verbose > 0) {
  inform(sprintf("Creating R Markdown report for %s...", params$sim_name))
}

# show results
if (experiment_exists(params$sim_path)) {
  base_header <- write(
    sprintf("\n\n# Base %s \n\n", params$sim_name),
    "\n\n## {.tabset .tabset-pills .tabset-circle}\n\n",
    write_flag = params$write
  )
  base_results <- show_results(
    params$sim_path,
    depth = 2, base = FALSE, show_header = FALSE,
    verbose = params$verbose, write_flag = params$write
  )

  if (params$write) {
    write_to_file(path = write_filename, base_header, base_results)
  }
}

show_descendant_results(
  params$sim_path,
  verbose = params$verbose,
  write_flag = params$write, 
  write_filename = write_filename
)

if (params$write) {
  clean_file(path = write_filename)
}

Yu-Group/simChef documentation built on March 25, 2024, 3:22 a.m.