R/chunk-writer.r

In listdown: Create R Markdown from Lists

#' @title Create a listdown Object
#'
#' @description A listdown object provides information for how a presentation
#' list should be used to create an R Markdown document. It requires an
#' unquoted expression indicating how the presentation list will be loaded.
#' In addition, libraries required by the outputted document and other
#' parameters can be specified.
#' @param package a quoted list of package required by the outputted document.
#' @param decorator a named list mapping the potential types of list elements
#' to a decorator function.
#' @param decorator_chunk_opts a named list mapping the potential types of list
#' elements to chunk options that should be included for those types.
#' @param default_decorator the decorator to use for list elements whose type
#' is not inherited from the decorator list. If NULL then the those
#' elements will not be included when the chunks are written. By default
#' this is identity, meaning that the elements will be passed directly
#' (through the identity() function).
#' @param setup_expr an expression that is added before package are 
#' loaded. The expression is put into a chunk named `setup` with option
#' `include = FALSE` and is intended for initializing the document. For
#' example the expression `knitr::opts_chunk$set(echo = FALSE)` could be
#' used to turn echo'ing off for the entire document.
#' @param init_expr an initial expression that will be added to the outputted
#' document after the libraries have been called. This expression appears
#' after packages are loaded and before data is read.
#' @param load_cc_expr either an unquoted expression or a character string
#' that will be turned into an unquoted expression via str2lang to load the 
#' presentation list.
#' @param ... default options sent to the chunks of the outputted document.
#' @param chunk_opts a named list of options sent to the chunks of outputted
#' documents. Note: takes priority over argument provided to ...
#' @return An S3 object of type `listdown`
#' \itemize{
#'   \item load_cc_expr - the R expression to load computational components.
#'   \item decorator - the list element decorators.
#'   \item package - package dependencies for the document.
#'   \item init_expr - the R expression to run initially.
#'   \item setup_expr - the R expression to run on setup.
#'   \item decorator_chunk_options - the R Markdown chunk options.
#'   \item default_decorator - the set of default decorators.
#'   \item chunk_opts - the default R Markdown chunk options.
#' }
#' @examples
#' library(ggplot2)
#' cc <- list(
#'     iris = iris,
#'      Sepal.Length = list(
#'        Sepal.Width = ggplot(iris, aes(x = Sepal.Length, y = Sepal.Width)) +
#'             geom_point(),
#'        Petal.Length = ggplot(iris, aes(x = Sepal.Length, y = Sepal.Width)) +
#'             geom_point(),
#'      Colored = list(
#'           Sepal.Width = ggplot(iris, aes(x = Sepal.Length, y = Sepal.Width,
#'             color = Species)) + geom_point(),
#'           Petal.Length = ggplot(iris, aes(x = Sepal.Length, y = Petal.Length,
#'             color = Species)) + geom_point())))
#' 
#' header <- ld_rmarkdown_header("Test header", author = "Some Dude",
#'                               date = "2020")
#' 
#' ld <- listdown(package = "ggplot2")
#' 
#' ld_bundle_doc(cc, header, ld)
#' @export
listdown <- function(package = NULL,
                     decorator = list(),
                     decorator_chunk_opts = list(),
                     default_decorator = identity,
                     setup_expr = NULL,
                     init_expr = NULL,
                     load_cc_expr = NULL,
                     ...,
                     chunk_opts = NULL) {

  if ( !("default_decorator" %in% names(as.list(match.call))) ) {
    default_decorator <- as.symbol("identity")
  } else {
    default_decorator <- as.list(match.call()$default_decorator)
  }

  if (is.null(chunk_opts)) {
    chunk_opts <- list(...)
  }

  not_r_chunk_opts <- not_r_chunk_opts(names(chunk_opts))
  if (length(not_r_chunk_opts) > 0) {
    stop("Unrecognized options:\n\t",
         paste(not_r_chunk_opts, collapse = "\n\t"),
         "\n", sep = "")
  }

  # Check the chunk options of decorator_chunk_opts.
  for (i in seq_along(decorator_chunk_opts)) {
    not_r_chunk_opts <- not_r_chunk_opts(names(decorator_chunk_opts[[i]]))
    if (length(not_r_chunk_opts) > 0) {
      stop("Unrecognized options for element type",
           names(decorator_chunk_opts)[i], ":\n\t",
           paste(not_r_chunk_opts, collapse = "\n\t"),
           "\n", sep = "")
    }
  }
  if ( !("decorator" %in% names(match.call())) ) {
    decorator <- NULL
  } else {
    if (as.character(as.list(match.call()$decorator)[[1]]) == "list") {
      decorator <- as.list(match.call()$decorator)[-1]
    } else {
      decorator <- eval(match.call()$decorator)
    }
    if ("list" %in% names(decorator)) {
      stop("You may not decorate a list. Consider making a list element you ",
           "would\nlike to present a class instance and define a decorator.")
    }
  }
  if (!is.null(load_cc_expr)) {
    load_cc_expr <- create_load_cc_expr(match.call()$load_cc_expr)
  }
  ret <- list(load_cc_expr = load_cc_expr,
              decorator = decorator,
              package = package,
              init_expr = match.call()$init_expr,
              setup_expr = match.call()$setup_expr,
              decorator_chunk_opts = decorator_chunk_opts,
              default_decorator = default_decorator,
              chunk_opts = chunk_opts)

  class(ret) <- "listdown"
  ret
}

#' @export
print.listdown <- function(x, ...) {
  cat("\nListdown object description\n")
  cat("\n")
  if ("package" %in% names(x)) {
    cat("    Package(s) imported:\n")
    for (package in x$package) {
      cat("\t", package, "\n", sep = "")
    }
  } else {
    warning("No packages imported.")
  }
  if ("setup_expr" %in% names(x)) {
    cat("\n")
    cat("    Setup expression(s) (run before packages are loaded):\n")
    cat("\t")
    if (length(x$setup_expr) == 0) {
      cat("(none)\n")
    } else {
      cat(deparse(x$setup_expr), sep = "\n\t")
    }
  }
  if ("init_expr" %in% names(x)) {
    cat("\n")
    cat("    Initial expression(s) (run after packages are loaded):\n")
    cat("\t")
    if (length(x$init_expr) == 0) {
      cat("(none)\n")
    } else {
      cat(deparse(x$init_expr), sep = "\n\t")
    }
  }
  if ("load_cc_expr" %in% names(x)) {
    cat("\n")
    cat("    Expression to read data:\n")
    cat("\t", deparse(x$load_cc_expr), "\n", sep = "")
  } else {
    warning("No load_cc expression provided.")
  }
  if ("decorator" %in% names(x)) {
    cat("\n")
    cat("    Decorator(s):\n")
    if (length(x$decorator) == 0) {
      cat("\t(none)\n")
    } else {
      ns <- format(c("Type", names(x$decorator)))
      cv <- c("Method", as.vector(unlist(sapply(x$decorator, deparse))))
      for (i in seq_along(ns)) {
        if (i == 1) {
          cat("\t", ns[i], "\t", cv[i], "\n", sep = "")
        } else {
          cat("\t", ns[i], "\t", cv[i], "\n", sep = "")
        }
      }
    }
  }
  if ("default_decorator" %in% names(x)) {
    cat("\n")
    cat("    Default decorator:\n")
    cat("\t", deparse(x$default_decorator), "\n", sep = "")
  }
  if ("chunk_opts" %in% names(x)) { 
    cat("\n")
    cat("    Chunk option(s):\n")
    if (length(x$chunk_opts) == 0) {
      cat("\t(none)\n")
    } else {
      for (i in seq_along(x$chunk_opts)) {
        cat("\t", names(x$chunk_opts)[i], " = ", 
            deparse(x$chunk_opts[[i]]), "\n",
            sep = "")
      }
    }
  }
  if ("decorator_chunk_opts" %in% names(x)) {
    cat("\n")
    cat("    Decorator chunk option(s):\n")
    if (length(x$decorator_chunk_opts) == 0) {
      cat("\t(none)\n")
    } else {
      for (i in seq_along(x$decorator_chunk_opts)) {
        cat("\t", "Type: ", names(x$decorator_chunk_opts)[i], ":", 
            sep = "")
        ns <- names(x$decorator_chunk_opts[[i]])
        ns[ns == ''] <- "(chunk name)"
        ns <- c("Option", ns)
        ns <- format(ns)
        cv <- unlist(x$decorator_chunk_opts[[i]])
        cv <- c("Value", cv)
        for (j in seq_along(ns)) {
          if (j == 1) {
            cat("\n\t\t", ns[j], " ", cv[j])
          } else {
            cat("\n\t\t", ns[j], " ", cv[j])
          }
        }
        cat("\n")
      }
    }
  }
  cat("\n")
  invisible(x)
}

#' @title Write a listdown Object to a String
#'
#' @description After a presentation list and listdown object have been
#' constructed the chunks can be rendered to a string, which can be appended
#' to a file, with appropriate headers, resulting in a compilable R Markdown
#' document.
#' @param ld the listdown object that provides
#' information on how a presentation object should be displayed in the
#' output.
#' @param rmd_dir the R Markdown directory.
#' @return The string containing the R Markdown content.
#' @seealso \code{\link{listdown}}
#' @export
ld_make_chunks <- function(ld, rmd_dir) {
  UseMethod("ld_make_chunks", ld)
}


ld_make_chunks.default <- function(ld, rmd_dir) {
  stop("Don't know how to render an object of class ",
       paste(class(ld), collapse = ":"), ".", sep = "")
}

expr_to_string <- function(expr) {
  if (deparse(expr[[1]]) == "{") {
    unlist(lapply(expr[-1], function(x) c(deparse(x))))
  } else {
    deparse(expr)
  }
}

#' @export
ld_make_chunks.listdown <- function(ld, rmd_dir = ".") {
  if (is.null(ld$load_cc_expr)) {
    stop("The load_cc_expr needs to be specified. ",
         "Use `create_load_cc_expr()` to set it.")
  }

  wd <- getwd()
  make_dirs_as_needed(path_abs(rmd_dir))
  on.exit(setwd(wd))
  cc_list <- tryCatch(
    {
      setwd(rmd_dir)
      ret <- eval(ld$load_cc_expr)
      ret
    },
    error = function(e) {
      stop("Can't evaluate ", expr_to_string(ld$load_cc_expr), 
           " from directory ", rmd_dir)
    })
  
  ret_string <- ""
  if (length(ld$setup_expr)) {
    ret_string <- c(ret_string, 
      "```{r setup, include = FALSE}",
      expr_to_string(ld$setup_expr),
      "```",
      "")
  }
  ret_string <-
    c(ret_string,
      sprintf("```{r%s}", make_chunk_option_string(ld$chunk_opts)))
  if (length(ld$package) > 0) {
    ret_string <-
      c(ret_string,
        as.character(vapply(eval(ld$package),
                     function(x) sprintf("library(%s)", as.character(x)),
                     NA_character_)),
        "")
  }
  if (length(ld$init_expr)) {
    ret_string <-
      c(ret_string,
        expr_to_string(ld$init_expr),
        "")
  }
  c(ret_string, 
    sprintf("cc_list <- %s", paste(deparse(ld$load_cc_expr), collapse = "\n")),
    "```",
    depth_first_concat(cc_list, ld))
}