R/build_pages.R

In hafen/datasummary: Create A Summary Report for a Collection of Data Sets

#' Build summary pages for a set of data sets with an optional index page
#'
#' @param di_list a list of objects returned from \code{\link{get_data_info}} or named list of data frames
#' @param title page title
#' @param author name of author
#' @param output_dir directory where output html files should be placed
#' @param index should an index page be built as well?
#' @param idx_intro_rmd passed on to \code{\link{build_index_page}}
#' @param data_intro_rmd vector of R Markdown strings or paths to .Rmd files passed on to \code{\link{build_data_page}} for each entry in \code{di_list}
#' @param view should the index page be opened in a browser after it is rendered?
#'
#' @export
build_pages <- function(di_list, title = "", author = "", output_dir,
  index = TRUE, idx_intro_rmd = "", data_intro_rmd = rep("", length(di_list)),
  view = FALSE) {

  output_dir <- check_output(output_dir)

  di_list <- check_di_list(di_list)

  ids <- unname(unlist(lapply(di_list, function(x) x$id)))

  for (ii in seq_along(di_list)) {
    message("* building ", di_list[[ii]]$id)
    title1 <- paste0(title, ": ", di_list[[ii]]$id)
    build_data_page(di_list[[ii]], title = title1, author = author,
      output_dir = output_dir, ids = ids, intro_rmd = data_intro_rmd[i])
  }
  if (index)
    build_index_page(di_list, title = title, author = author,
      output_dir = output_dir, intro_rmd = data_intro_rmd)

  mfpath <- file.path(system.file(package = "datasummary"),
    "templates/menu-fix.css")
  file.copy(mfpath, file.path(output_dir, "assets/"), overwrite = TRUE)

  ff <- file.path(output_dir, paste0("index.html"))
  if (view && file.exists(ff))
    browseURL(ff)

  invisible(TRUE)
}

#' Build a summary page for a data set
#'
#' @param di an object returned from \code{\link{get_data_info}} or data frame
#' @param title page title
#' @param author name of author
#' @param output_dir directory where output html file should be placed
#' @param ids an optional list of ids to be used to generate links to pages for other data sets
#' @param view should the page be opened in a browser after it is rendered?
#' @param intro_rmd optional R markdown string or file path that will be placed at beginning of the page
#' @param post_rmd optional R markdown string or file path that will be placed at end of the page
#'
#' @export
#' @importFrom whisker whisker.render
#' @importFrom rmarkdown render
#' @importFrom packagedocs package_docs
build_data_page <- function(di, title = "", author = "", output_dir,
  ids = NULL, view = FALSE, intro_rmd = "", post_rmd = "") {

  if (is.data.frame(di))
    di <- get_data_info(di)

  output_dir <- check_output(output_dir)

  navpills <- get_navpills(ids, cur_id = di$id)

  ff <- tempfile()
  save(di, file = ff)

  if (file.exists(intro_rmd))
    intro_rmd <- paste0(readLines(intro_rmd), collapse = "\n")

  if (file.exists(post_rmd))
    post_rmd <- paste0(readLines(post_rmd), collapse = "\n")

  tmpldat <- list(
    title = title,
    author = author,
    navpills = navpills,
    di_path = ff,
    var_summaries = get_var_summary_sections(di),
    intro_rmd = intro_rmd,
    post_rmd = post_rmd
  )

  tmpl_path <- file.path(system.file(package = "datasummary"),
    "templates/data_template.Rmd")
  tmpl <- readLines(tmpl_path)
  page <- whisker::whisker.render(tmpl, tmpldat)

  ff <- paste0(di$id, ".Rmd")
  cat(page, file = file.path(output_dir, ff))

  rmarkdown::render(file.path(output_dir, ff),
    output_format = packagedocs::package_docs(lib_dir = file.path(output_dir, "assets"),
      css = "assets/menu-fix.css", toc_collapse = TRUE),
    output_dir = output_dir)

  mfpath <- file.path(system.file(package = "datasummary"),
    "templates/menu-fix.css")
  file.copy(mfpath, file.path(output_dir, "assets/"), overwrite = TRUE)

  if (view)
    browseURL(file.path(output_dir, paste0(di$id, ".html")))

  invisible(TRUE)
}

#' Build index pages for a set of data sets
#'
#' @param di_list a list of objects returned from \code{\link{get_data_info}} or named list of data frames
#' @param title page title
#' @param author name of author
#' @param output_dir directory where output html files should be placed
#' @param intro_rmd optional R markdown string or file path that will be placed at beginning of the page
#' @param \ldots data to be saved and loaded in to the document's knitr environment
#'
#' @export
build_index_page <- function(di_list, title = "", author = "", output_dir, intro_rmd = "", ...) {

  di_list <- check_di_list(di_list)

  ids <- unname(unlist(lapply(di_list, function(x) x$id)))

  output_dir <- check_output(output_dir)

  navpills <- get_navpills(ids)

  ff <- tempfile()
  save(di_list, file = ff)

  eff <- tempfile()
  dots <- list(...)
  save(dots, file = eff)

  if (file.exists(intro_rmd))
    intro_rmd <- paste0(readLines(intro_rmd), collapse = "\n")

  tmpldat <- list(
    title = title,
    author = author,
    navpills = navpills,
    di_list_path = ff,
    extra_path = eff,
    intro_rmd = intro_rmd
  )

  tmpl_path <- file.path(system.file(package = "datasummary"),
    "templates/index_template.Rmd")
  tmpl <- readLines(tmpl_path)
  page <- whisker::whisker.render(tmpl, tmpldat)

  pf <- file.path(output_dir, "index.Rmd")
  cat(page, file = pf)

  rmarkdown::render(pf,
    output_format = packagedocs::package_docs(lib_dir = file.path(output_dir, "assets"),
      css = "assets/menu-fix.css", toc_collapse = TRUE),
    output_dir = output_dir)

  mfpath <- file.path(system.file(package = "datasummary"),
    "templates/menu-fix.css")
  file.copy(mfpath, file.path(output_dir, "assets/"), overwrite = TRUE)

  invisible(TRUE)
}

## internal
##---------------------------------------------------------

check_output <- function(output_dir) {
  output_dir <- normalizePath(output_dir)
  assets_dir <- file.path(output_dir, "assets")
  if (!file.exists(output_dir))
    dir.create(output_dir)
  if (!file.exists(assets_dir))
    dir.create(assets_dir)

  output_dir
}

check_di_list <- function(di_list) {
  if (!inherits(di_list, "data_info") && is.list(di_list) && all(sapply(di_list, is.data.frame))) {
    if (is.null(names(di_list)))
      stop("di_list must either be a named list of data frames or ",
        "a list of objects from get_data_info()", call. = FALSE)

    return(lapply(names(di_list), function(nm) {
      get_data_info(di_list[[nm]], id = nm)
    }))
  } else {
    return(di_list)
  }
}

get_navpills <- function(ids, cur_id = NULL) {
  if (is.null(ids))
    return("")

  if (is.null(cur_id)) {
    cur_id <- "*&^%%#&^%*()(*&%$%#@)"
    pid <- ""
    pactive <- "active"
  } else {
    pid <- paste0("(", cur_id, ")")
    pactive <- ""
  }

  tmpldat <- list(
    id = pid,
    active = pactive,
    dd_active = ifelse(pactive == "", "active", ""),
    navpills = lapply(ids, function(id) {
      list(id = id,
        active = ifelse(cur_id == id, "active", ""))
    }))

  tmpl_path <- system.file(package = "datasummary",
    "templates/navpills_template.yaml")
  tmpl <- readLines(tmpl_path)
  paste0("\n", whisker::whisker.render(tmpl, tmpldat))
}

get_var_summary_sections <- function(di) {
  # make a variables section for each group
  gps <- unlist(lapply(di$var_summ, function(x) {
    ifelse(is.null(x$group), "", x$group)
  }))
  ugps <- unique(gps)
  a <- unlist(lapply(ugps, function(x) {
    a <- sapply(di$var_summ[gps == x], get_var_summary_section)
    lbl <- ifelse(x == "", "# Variables", paste0("# Variables: ", x))
    paste(c(lbl, "", a, collapse = "\n"))
  }))

  paste(a, collapse = "\n")
}

get_var_summary_section <- function(vr) {
  if (vr$type == "character") {
    header <- paste0("### Distribution",
      ifelse(vr$truncated, " of top 50 variables", ""), " ###")
    txt <- c(header, "",
      ifelse(vr$log,
        paste0("Due to high skewness, the plot below is shown with the ",
          "variable transformed to the log scale.",
          ifelse(vr$n0 > 0,
            paste0("There were ", vr$n0,
              " zeros removed prior to transformation."), "")), ""),
      paste0("```{r var_", vr$name,
        ", echo=FALSE, message=FALSE, results='asis', lazy=TRUE}"), ##lazy
      paste0("vr <- di$var_summ[[\"", vr$name, "\"]]"),
      "vr$artifacts$fg", "```", "")

    header <- paste0("### Frequency table",
      ifelse(vr$truncated, " of top 100 variables", ""), " ###")
    txt <- c(txt, header, "",
      "```{r, echo=FALSE, message=FALSE, results='asis'}",
      "vr$artifacts$tb",
      "```", "")
  } else if (vr$type == "numeric") {
    txt <- c("### Distribution ###", "",
      "```{r, echo=FALSE, message=FALSE, results='asis', lazy=TRUE}", ##lazy
      paste0("vr <- di$var_summ[[\"", vr$name, "\"]]"),
      "vr$artifacts$fg", "```", "")

    txt <- c(txt, "### Summary statistics ###", "",
      "```{r, echo=FALSE, message=FALSE, results='asis'}",
      "vr$artifacts$tb",
      "```", "")
  } else {
    txt <- ""
  }
  if (length(txt) > 1) {
    txt <- c(paste("##", vr$name, "##"), "",
      ifelse(!is.null(vr$label), vr$label, ""), "", txt)
  }

  paste(txt, collapse = "\n")
}