tejer DT:: datatable sin pandoc

datatables knitr

Question

Estoy tratando de usar DT::datatable para generar una tabla interactiva con buen formato en R.

... el único problema es que quiero un trabajo heroku para tejer el documento para mí, y he aprendido que RStudio y rmarkdown::render() usan pandoc debajo del capó, pero Pandoc no se envía en el desmantelado R Buildpack para heroku.

¿Hay alguna manera de obtener el motor de knitr:knit2html ( knitr:knit2html o markdown:markdownToHTML ) para pasar el javascript que datatable través de datatable ? ¿O para ser más precisos, generar la siguiente tabla de muestra sin usar pandoc?

Aquí hay un ejemplo mínimo:

testing.Rmd

---
title: "testing"
output: html_document
---

this is a datatable table
```{r test2, echo=FALSE}
library(DT)
DT::datatable(
  iris, 
  rownames = FALSE,
  options = list(pageLength = 12, dom = ''tip'')
)
```

this is regular R output
```{r}
head(iris)

```

knit_test.R

require(knitr)
knitr::knit2html(''testing.Rmd'')

genera:

this is a datatable table <!–html_preserve–>

<!–/html_preserve–>
this is regular R output

head(iris)
##   Sepal.Length Sepal.Width Petal.Length Petal.Width Species
## 1          5.1         3.5          1.4         0.2  setosa
## 2          4.9         3.0          1.4         0.2  setosa
## 3          4.7         3.2          1.3         0.2  setosa
## 4          4.6         3.1          1.5         0.2  setosa
## 5          5.0         3.6          1.4         0.2  setosa
## 6          5.4         3.9          1.7         0.4  setosa

Comportamiento deseado: hacer que mi datatable llegue (no <!–html_preserve–> )

lo que probé , miré htmltools y htmlPreserve pero no pude encontrar la forma de aplicarlo aquí. Hizo algunas cosas locas con saveWidget que no fue exitoso y no se repite.

¡Gracias!

Answer 1

Aquí hay una solución que usa los paquetes knitr , markdown , base64enc y htmltools . Se basa en lo que sucede internamente en rmarkdown::render , pero no tiene dependencias en pandoc . Genera un archivo HTML autónomo de forma predeterminada u opcionalmente copia todas las dependencias en una carpeta. Con este último, se supone que todos los archivos CSS y JS de los que depende tienen un nombre único (es decir, no se importarán ambos si dos htmlwidgets deciden llamar a su archivo css style.css).

library("knitr")
library("htmltools")
library("base64enc")
library("markdown")
render_with_widgets <- function(input_file,
                                output_file = sub("//.Rmd$", ".html", input_file, ignore.case = TRUE),
                                self_contained = TRUE,
                                deps_path = file.path(dirname(output_file), "deps")) {

  # Read input and convert to Markdown
  input <- readLines(input_file)
  md <- knit(text = input)
  # Get dependencies from knitr
  deps <- knit_meta()

  # Convert script dependencies into data URIs, and stylesheet
  # dependencies into inline stylesheets

  dep_scripts <-
    lapply(deps, function(x) {
      lapply(x$script, function(script) file.path(x$src$file, script))})
  dep_stylesheets <- 
    lapply(deps, function(x) {
      lapply(x$stylesheet, function(stylesheet) file.path(x$src$file, stylesheet))})
  dep_scripts <- unique(unlist(dep_scripts))
  dep_stylesheets <- unique(unlist(dep_stylesheets))
  if (self_contained) {
    dep_html <- c(
      sapply(dep_scripts, function(script) {
        sprintf(''<script type="text/javascript" src="%s"></script>'',
                dataURI(file = script))
      }),
      sapply(dep_stylesheets, function(sheet) {
        sprintf(''<style>%s</style>'',
                paste(readLines(sheet), collapse = "/n"))
      })
    )
  } else {
    if (!dir.exists(deps_path)) {
      dir.create(deps_path)
    }
    for (fil in c(dep_scripts, dep_stylesheets)) {
      file.copy(fil, file.path(deps_path, basename(fil)))
    }
    dep_html <- c(
        sprintf(''<script type="text/javascript" src="%s"></script>'',
                file.path(deps_path, basename(dep_scripts))),
        sprintf(''<link href="%s" type="text/css" rel="stylesheet">'',
                file.path(deps_path, basename(dep_stylesheets)))
    )
  }

  # Extract the <!--html_preserve--> bits
  preserved <- extractPreserveChunks(md)

  # Render the HTML, and then restore the preserved chunks
  html <- markdownToHTML(text = preserved$value, header = dep_html)
  html <- restorePreserveChunks(html, preserved$chunks)

  # Write the output
  writeLines(html, output_file)
}

Esto se puede llamar así:

render_with_widgets("testing.Rmd")

Esto debería funcionar para cualquier htmlwidgets, incluso en combinación. Ejemplo:

TestWidgets.Rmd

---
title: "TestWidgets"
author: "Nick Kennedy"
date: "5 August 2015"
output: html_document
---

First test a dygraph
```{r}
library(dygraphs)
dygraph(nhtemp, main = "New Haven Temperatures") %>% 
  dyRangeSelector(dateWindow = c("1920-01-01", "1960-01-01"))
```

Now a datatable
```{r}
library(DT)
datatable(iris, options = list(pageLength = 5))
```

```{r}
library(d3heatmap)
d3heatmap(mtcars, scale="column", colors="Blues")
```

Y luego desde R

render_with_widgets("TestWidgets.Rmd")

Answer 2

Un poco de una categoría algunas cosas locas con saveWidget pero si puedes usar el paquete XML (necesitarás cedro-14 para eso) algo como lo siguiente debería hacer el truco:

#'' http://.com/q/31645528/1560062
#''
#'' @param dt datatables object as returned from DT::datatable
#'' @param rmd_path character path to the rmd template
#'' @param libdir path to the directory with datatable static files
#'' @param output_path where to write output file
#''
process <- function(dt, rmd_path, libdir, output_path) {

    widget_path <- tempfile()
    template_path <- tempfile()

    # Save widget and process Rmd template
    DT::saveWidget(dt, widget_path, selfcontained=FALSE)
    knitr::knit2html(input=rmd_path, output=template_path)

    # Parse html files
    widget <- XML::htmlParse(widget_path)
    template <- XML::htmlParse(paste0(template_path, ".html"))

    # Extract elements from the body of widget file
    widget_container <- XML::getNodeSet(
        widget, "/html/body/div[@id = ''htmlwidget_container'']")
    body_scripts <- XML::getNodeSet(widget, "/html/body/script")

    # Make sure we point to the correct static dir
    # Using lapply purely for side effect is kind of
    # wrong but it is cheaper than a for loop if we use ::
    correct_libdir <- function(nodeset, attr_name) {
        lapply(nodeset, function(el) {
            src <- XML::xmlAttrs(el)[[attr_name]]
            XML::xmlAttrs(el)[[attr_name]] <- file.path(
                libdir, sub("^.*?/", "", src))
        })
        nodeset
    }

    # Extract script and link tags, correct paths
    head_scripts <- correct_libdir(
        XML::getNodeSet(widget, "/html/head/script"), "src")

    head_links <- correct_libdir(
        XML::getNodeSet(widget, "/html/head/link"), "href")

    # Get template root    
    root <- XML::xmlRoot(template)

    # Append above in the right place
    root[[2]] <- XML::addChildren(root[[2]], widget_container)
    root[[2]] <- XML::addChildren(root[[2]], body_scripts)
    root[[1]] <- XML::addChildren(root[[1]], head_scripts)
    root[[1]] <- XML::addChildren(root[[1]], head_links)

    # Write output
    XML::saveXML(template, output_path)
}