R/render_page.R

In pbreheny/html: Functions for creating HTML reports

#' Render an rmd file built within the html package template
#' 
#' @param f        File to render (character)
#' @param purl     Creates .r file if set to `"basic"` or `"fancy"`. (default: `"none"`)
#' @param quiet    As in `rmarkdown::render()`. (default: `FALSE`)
#' @param force    By default, `render_page()` requires the folders `docs` or `web` to exist if multiple `.html` files are present. To override this behavior and force rendering, set `force=TRUE`.
#' 
#' @export

render_page <- function(f, purl=c('none', 'basic', 'fancy'), quiet=FALSE, force=FALSE) {
  purl <- match.arg(purl)

  # Process input file location
  if (!file.exists(f)) stop("file '", f, "' does not exist!")
  ext <- tools::file_ext(f)
  base_dir <- dirname(f)
  handle <- tools::file_path_sans_ext(basename(f))
  
  # Decide on output file location
  if (base_dir == 'web') {
    out_dir <- paste0(base_dir, '/_site')
    if (!dir.exists(out_dir)) dir.create(out_dir)
  } else if (dir.exists(paste0(base_dir, '/_site'))) {
    out_dir <- paste0(base_dir, '/_site')
  } else if (dir.exists(paste0(base_dir, '/docs'))) {
    out_dir <- paste0(base_dir, '/docs')
  } else if (length(list.files(base_dir, '*.rmd', ignore.case=TRUE)) > 1 && force == FALSE) {
    stop('Multiple rmd files present and no output directory specified.\nRun with force=TRUE if this is intentional.', call. = FALSE)
  } else {
    out_dir <- base_dir
  }

  # Purl
  knitr::opts_knit$set(root.dir = getwd())
  if (purl != 'none') {
    
    # Set destination
    if (out_dir == base_dir) {
      Rfile <- paste0(base_dir, '/', handle, '.r')
    } else {
      Rdir <- paste0(base_dir, '/_r')
      Rfile <- paste0(Rdir, '/', handle, '.r')
      if (!dir.exists(Rdir)) dir.create(Rdir)
    }
    
    # Purl
    if (file.exists(Rfile)) file.remove(Rfile)
    knitr::purl(f, documentation=1L, output=Rfile, quiet=quiet)

    # Restyle R comments
    rlines <- readLines(Rfile)
    ind <- grep("## ----", rlines)
    if (purl == 'fancy') {
      x <- rlines[ind]
      x <- gsub("## ----", "# ", x, fixed=TRUE)
      x <- gsub("\\,.*", "", x)
      x <- gsub("___", ": ", x)
      x <- gsub("__", ", ", x)
      x <- gsub("_", " ", x)
      x <- gsub("-+-", "", x)
      x <- gsub("#  ", "# ", x, fixed=TRUE)
      rlines[ind] <- x
      topline <- paste0('THIS FILE WAS GENERATED BY ', f, ': DO NOT EDIT BY HAND')
      x <- c(topline, '', rlines)
    } else {
      x <- rlines[-ind]
    }

    # Remove excessive newlines and write
    while (x[length(x)] == '') x <- x[-length(x)]
    redundant <- c(FALSE, x[-length(x)] == x[-1] & x[-length(x)] == '')
    cat(x[!redundant], file=Rfile, sep='\n')
  } else {
    tmp <- tempfile()
    knitr::purl(f, output=tmp, quiet=TRUE)
    rlines <- readLines(tmp)
  }

  # Warn if browser() code is present
  if (any(stringr::str_detect(rlines, 'browser\\(\\)'))) {
    warning('Call to browser() detected in code; may cause rendering problems.', call.=FALSE)
  }
  
  # update footer if applicable
  if (file.exists('web/_include/footer.html') & file.exists('web/_site.yml')) {
    update_footer('web/_include/footer.html', 'web/_site.yml')
  }

  # Render
  out <- catchWarning(rmarkdown::render(f, output_dir=out_dir, knit_root_dir=getwd(), quiet=quiet, envir=new.env(parent=.GlobalEnv)))
  skip <- stringr::str_detect(as.character(out$warning), "MathJax doesn't work with self_contained")
  if (length(out$warning[!skip])) warning(out$warning[!skip])
  if (inherits(out$value, 'error')) stop(out$value$message)
  
  # Return output location invisible
  invisible(paste0(out_dir, '/', handle, '.html'))
}