Search code examples
rshinyknitr

How to use rmarkdown::render like knitr:html2html in a shiny app?

I have an app that uses knitr::knit2html which works well (except for some glitches where upon clicking, the code is executed later).

I would like to use the rmarkdown::render function instead of knitr::knit2html

Code

library(shinyAce)
library(shinyjs)
library(shiny)

codeUI <- function(id) {
  ns <- NS(id)
  tagList(htmlOutput(ns("output")))
}

codeSE <- function(id, active_id, code, env) {
  moduleServer(id,
               function(input, output, session) {
                 
                 output$output <- renderUI({
                   req(id == active_id(), cancelOutput = TRUE)
                   eval_code <- paste0("\n```{r echo = TRUE, comment = NA}\n", code, "\n```\n")
                   HTML(knitr::knit2html(text = eval_code, fragment.only = TRUE, quiet = TRUE, envir = env))
                 })
               })
}

ui <- fluidPage(
  useShinyjs(),
  
  tags$style(type = "text/css", "
      .foot{
      position:fixed;
      bottom:0;
      right:0;
      left:0;
   /*   background:#00adfc; */
        padding:10px;
      box-sizing:border-box;
    }
    "),
  div(id = "add_here"),
  div(id = "end", " "),
  div(style = "height: 80vh;"),
  
  div(class = "foot", 
      aceEditor("code", mode = "r", height = "50px",
                highlightActiveLine = FALSE,
                fontSize = 16,
                showLineNumbers = FALSE),
      actionButton("eval", "Run"))
  
)


env <- environment()
server <- function(input, output, session) {
  
  counter <- 1
  active_id <- reactiveVal()
  observeEvent(input$eval, {
    req(code)
    current_id <- paste0("out_", counter)
    active_id(current_id)
    codeSE(id = current_id, active_id = active_id, code = input$code, env = env)
    insertUI(selector = "#add_here",ui = codeUI(current_id))
    counter <<- counter + 1
    runjs('
      document.getElementById("end").scrollIntoView();
    ')
  })   } 
shinyApp(ui, server)

I would like to use rmarkdown::render to overcome the drawback of unstyled knitr::kable tables.

enter image description here

Solution

  • Here's a solution using whisker templates.

    in globals.R

    output_rmd <-  function(code_chunk) {
  render_dir <- fs::path_temp(round(runif(1, 100000, 1000000), 0))
  rmd_path <- file.path(render_dir, "input.Rmd")
  final_path <- file.path(render_dir, "body_snippet.html")
  fs::dir_create(render_dir, recurse = TRUE)
  
  # read in template for rmarkdown
  whisker_template <- readr::read_lines("input.template")
  
  # render template with input code chunk
  rendered_temp <- whisker::whisker.render(whisker_template,
                                           data = list(code_chunk = code_chunk))
  
  # save out rendered template as .Rmd to temp dir
  readr::write_lines(rendered_temp, path = rmd_path)
  
  # render the temp .Rmd file as html
  out_path <- rmarkdown::render(rmd_path)
  
  # read in the html, select the body portion only, save that out to temp
  xml2::write_html(rvest::html_node(xml2::read_html(out_path), "body"), file = final_path)
  
  # read in the html body portion
  lines <- readr::read_lines(final_path)
  
  # add table table-condensed class to all tables so they render in snippet like they would in full html
  lines <- gsub("<table>", '<table class="table table-condensed">', lines, fixed = TRUE)
  
  # save out the final html snippet
  readr::write_lines(lines, final_path)
  return(final_path)
}

    This function reads in input.template, appends the code you want to run to the template, saves out the finished .Rmd file to a temp directory, renders it using rmarkdown::render in that temp directory, and then returns the file path to the final html rendered output.

    input.template

    ---
title: "Shiny Run Code"
output: html_document
---

```{r echo = TRUE, comment = NA}
{{{ code_chunk }}}
```

    Then in app.R you just call rmd_file <- output_rmd(code) and includeHTML(rmd_file) where you were previously calling HTML and the knit2html

    library(shinyAce)
library(shinyjs)
library(shiny)
source('globals.R')  #changed typo 

codeUI <- function(id) {
  ns <- NS(id)
  tagList(htmlOutput(ns("output")))
}

codeSE <- function(id, active_id, code, env) {
  moduleServer(id,
               function(input, output, session) {
                 
                 output$output <- renderUI({
                   req(id == active_id(), cancelOutput = TRUE)
                   rmd_file <- output_rmd(code)
                   includeHTML(rmd_file)
                 })
               })
}

ui <- fluidPage(
  useShinyjs(),
  
  tags$style(type = "text/css", "
      .foot{
      position:fixed;
      bottom:0;
      right:0;
      left:0;
   /*   background:#00adfc; */
        padding:10px;
      box-sizing:border-box;
    }
    "),
  div(id = "add_here"),
  div(id = "end", " "),
  div(style = "height: 80vh;"),
  
  div(class = "foot", 
      aceEditor("code", mode = "r", height = "50px",
                highlightActiveLine = FALSE,
                fontSize = 16,
                showLineNumbers = FALSE),
      actionButton("eval", "Run"))
  
)


env <- environment()
server <- function(input, output, session) {
  
  observeEvent(input$code, {
    if(input$code == ''){
      shinyjs::disable("eval")
    } else {
      shinyjs::enable("eval")
    }
  })
  
  counter <- 1
  active_id <- reactiveVal()
  observeEvent(input$eval, {
    req(code)
    current_id <- paste0("out_", counter)
    active_id(current_id)
    codeSE(id = current_id, active_id = active_id, code = input$code, env = env)
    insertUI(selector = "#add_here",ui = codeUI(current_id))
    counter <<- counter + 1
    runjs('
      document.getElementById("end").scrollIntoView();
    ')
  })   } 
shinyApp(ui, server)

    Lastly, I added the shinyjs::disable/enable in the observer to fix that bug issue you had with the glitches on clicking.

    Your file structure should look like:

    - myapp
 - app.R
 - globals.R
 - input.template

    And here's what your above code would look like under this implementation: enter image description here