rmd.R

# rmarkdown.R
# Copyright (C) 2020-2022 Posit Software, PBC

# main
.main <- function() {
  # execute knitr::spin
  spin <- function(input) {
    if (utils::packageVersion("knitr") < "1.44") {
      stop(
        "knitr >= 1.44 is required for rendering with Quarto from `.R` files. ",
        "Please update knitr.",
        call. = FALSE
      )
    }

    # read file
    text <- xfun::read_utf8(input)

    # spin and return
    knitr::spin(text = text, knit = FALSE, format = "qmd")
  }

  # dependencies (convert knit_meta to includes)
  dependencies <- function(
    input,
    format,
    output,
    tempDir,
    libDir,
    data,
    quiet
  ) {
    # unserialize knit_meta
    knit_meta <- lapply(data, jsonlite::unserializeJSON)

    # determine files_dir
    files_dir <- if (!is.null(libDir)) {
      libDir
    } else {
      rmarkdown:::knitr_files_dir(output)
    }

    # yield pandoc format
    list(
      includes = pandoc_includes(
        input,
        format,
        output,
        files_dir,
        knit_meta,
        tempDir
      )
    )
  }

  # postprocess (restore preserved)
  postprocess <- function(input, format, output, preserved_chunks) {
    # check for html output
    isHTML <- knitr::is_html_output(
      format$pandoc$to,
      c("markdown", "epub", "gfm", "commonmark", "commonmark_x", "markua")
    )

    # bail if we don't have any perserved chunks and aren't doing code linking
    code_link <- isHTML && isTRUE(format$render$`code-link`)
    if (length(preserved_chunks) == 0 && code_link == FALSE) {
      return()
    }

    # change to input dir and make input relative
    oldwd <- setwd(dirname(rmarkdown:::abs_path(input)))
    on.exit(setwd(oldwd), add = TRUE)
    input <- basename(input)

    # apply r-options (if any)
    r_options <- format$metadata$`r-options`
    if (!is.null(r_options)) {
      do.call(options, r_options)
    }

    # read output and initialize output_res to no-op
    output_str <- xfun::read_utf8(output)
    output_res <- output_str

    # perform code linking if requested
    if (isTRUE(code_link)) {
      has_annotations <- function(input) {
        # Check to see if there are annotations in the file
        inputLines <- readLines(input)
        chunkStarts <- grep(knitr::all_patterns$md$chunk.begin, inputLines)
        chunkEnds <- grep(knitr::all_patterns$md$chunk.end, inputLines)
        annotations <- grep(".*\\Q#\\E\\s*<[0-9]+>\\s*", inputLines)
        hasAnnotations <- FALSE
        if (length(chunkStarts) > 0 && length(annotations) > 0) {
          lastLine <- max(max(chunkEnds), max(chunkStarts), max(annotations))

          # the chunk is a vector with a position for each line, indicating
          # whether that line is within a code chunk
          chunkMap <- rep(FALSE, lastLine)

          # Update the chunk mapt to mark lines that are
          # within a code chunk
          for (x in seq_along(chunkStarts)) {
            start <- chunkStarts[x]
            # Ensure end is greater than start
            end <- start
            for (e in chunkEnds) {
              if (e > start) {
                end <- e
                break
              }
            }
            for (y in start:end) {
              if (y > start && y < end) {
                chunkMap[y] <- TRUE
              }
            }
          }

          # look for at least one annotations that is in a code chunk
          for (a in annotations) {
            if (chunkMap[a] == TRUE) {
              hasAnnotations <- TRUE
              break
            }
          }
        }
        hasAnnotations
      }

      if (!has_annotations(input)) {
        if (
          requireNamespace("downlit", quietly = TRUE) &&
            requireNamespace("xml2", quietly = TRUE)
        ) {
          # run downlit
          downlit::downlit_html_path(output, output)

          # fix xml2 induced whitespace problems that break revealjs columns
          # (b/c they depend on inline-block behavior) then reset output_res
          downlit_output <- paste(xfun::read_utf8(output), collapse = "\n")
          downlit_output <- gsub(
            '(</div>)\n(<div class="column")',
            "\\1\\2",
            downlit_output
          )
          output_res <- strsplit(downlit_output, "\n", fixed = TRUE)[[1]]
        } else {
          warning(
            "The downlit and xml2 packages are required for code linking",
            call. = FALSE
          )
        }
      } else {
        warning(
          "Since code annotations are present, code-linking has been disabled",
          call. = FALSE
        )
      }
    }

    # restore preserved chunks if requested
    if (length(preserved_chunks) > 0) {
      # convert preserved chunks to named character vector
      names <- names(preserved_chunks)
      preserved_chunks <- as.character(preserved_chunks)
      names(preserved_chunks) <- names

      if (isHTML) {
        # Pandoc adds an empty <p></p> around the IDs of preserved chunks, and we
        # need to remove these empty tags, otherwise we may have invalid HTML like
        # <p><div>...</div></p>. For the reason of the second gsub(), see
        # https://github.com/rstudio/rmarkdown/issues/133.
        for (i in names(preserved_chunks)) {
          output_res <- gsub(
            paste0("<p>", i, "</p>"),
            i,
            output_res,
            fixed = TRUE,
            useBytes = TRUE
          )
          output_res <- gsub(
            paste0(' id="[^"]*?', i, '[^"]*?" '),
            ' ',
            output_res,
            useBytes = TRUE
          )
        }
        output_res <- htmltools::restorePreserveChunks(
          output_res,
          preserved_chunks
        )
      } else {
        output_res <- knitr::restore_raw_output(output_str, preserved_chunks)
      }
    }

    # re-write output if necessary
    if (!identical(output_str, output_res)) {
      xfun::write_utf8(output_res, output)
    }
  }

  run <- function(input, port, host) {
    shiny_args <- list()
    if (!is.null(port)) {
      shiny_args$port <- port
    }
    if (!is.null(host)) {
      shiny_args$host <- host
    }

    # we already ran quarto render before the call to run
    Sys.setenv(RMARKDOWN_RUN_PRERENDER = "0")

    # run the doc
    rmarkdown::run(input, shiny_args = shiny_args)
  }

  # read request from stdin
  stdin <- file("stdin", "r", encoding = "")
  input <- readLines(stdin, warn = FALSE, encoding = "UTF-8")
  close(stdin)

  # parse request and params
  request <- jsonlite::parse_json(input, simplifyVector = TRUE)
  params <- request$params

  # Ensuring expected working dir for Quarto
  # R process workding may be changed by some workflows (in  ~/.Rprofile)
  # https://github.com/quarto-dev/quarto-cli/issues/2646
  setwd(request$wd) # no need to reset it as R process is closed by R

  # source in helper functions if we have a resourceDir
  if (!is.null(params$resourceDir)) {
    res_dir <- file.path(params$resourceDir, "rmd")
    source(file.path(res_dir, "patch.R"), local = TRUE)
    source(file.path(res_dir, "execute.R"), local = TRUE)
    source(file.path(res_dir, "hooks.R"), local = TRUE)
  }

  # print execute-debug message ("spin" and "run" don't pass format option)
  debug <- (!request$action %in% c("spin", "run")) &&
    isTRUE(params$format$execute[["debug"]])
  if (debug) {
    message("[knitr engine]: ", request$action)
  }

  # dispatch request
  if (request$action == "spin") {
    result <- spin(params$input)
    result <- paste(result, collapse = '\n')
  } else if (request$action == "execute") {
    result <- execute(
      params$input,
      params$format,
      params$tempDir,
      params$libDir,
      params$dependencies,
      params$cwd,
      params$params,
      params$resourceDir,
      params$handledLanguages,
      params$markdown
    )
  } else if (request$action == "dependencies") {
    result <- dependencies(
      params$input,
      params$format,
      params$output,
      params$tempDir,
      params$libDir,
      params$dependencies,
      params$quiet
    )
  } else if (request$action == "postprocess") {
    result <- postprocess(
      params$input,
      params$format,
      params$output,
      params$preserve
    )
  } else if (request$action == "run") {
    result <- run(params$input, params$port, params$host)
  }

  # write results
  if (debug) {
    message("[knitr engine]: writing results")
  }
  resultJson <- jsonlite::toJSON(auto_unbox = TRUE, result)
  xfun:::write_utf8(paste(resultJson, collapse = "\n"), request[["results"]])
  if (debug) message("[knitr engine]: exiting")
}

if (!rmarkdown::pandoc_available(error = FALSE)) {
  # When FALSE, this means no Pandoc is found by rmarkdown, not even on PATH
  # In that case we configure rmarkdown to use Quarto bundled version
  quarto_bin_path <- Sys.getenv("QUARTO_BIN_PATH", NA_character_)
  # Checking env var to be safe, but should always set by Quarto
  if (!is.na(quarto_bin_path)) {
    pandoc_dir <- normalizePath(file.path(quarto_bin_path, "tools"))
    invisible(rmarkdown::find_pandoc(dir = pandoc_dir))
  }
}

# run main
.main()