pattern for including htmlwidgets in datatable

[timelyportfolio]

The examples for including sparkline and d3horizonR htmlwidgets in DT datatables received enough attention to motivate me to settle on a pattern for including nearly any htmlwidget in a datatable. I will start by doing all in one pipeline and then break the steps down into functions with discussion below.

mtcars %>%
  group_by(cyl) %>%
  # step 1 summarise and convert htmlwidget to as character
  summarise(
    spk_line = HTML(
      as.character(
        as.tags(
          sparkline(hp, type = "bar")
        )
      )
    )
  ) %>%
  datatable(
    # step 2 make sure escape = FALSE
    escape = FALSE,
    # step 3 add code to render htmlwidget
    options = list(
      fnDrawCallback = htmlwidgets::JS('
function(){
  HTMLWidgets.staticRender();
}
')
    )
  ) %>%
  # step 4 add html dependencies for the htmlwidget
  tagList(
    htmlwidgets::getDependency("sparkline", "sparkline")
  ) %>%
  browsable()

Step 1 - convert htmlwidget into character version

Hopefully, this piece will be eased with an official as.character.htmlwidget function in htmwidgets.

as.character.htmlwidget <- function(x, ...) {
  htmltools::HTML(
    htmltools:::as.character.shiny.tag.list(
      htmlwidgets:::as.tags.htmlwidget(
        x
      ),
      ...
    )
  )
}

Step 2 - make sure escape = FALSE

datatable( ..., escape = FALSE )

Step 3 - add static render callback

add_datatable_render_code <- function(dtbl) {
  render_js_code = htmlwidgets::JS('function(){HTMLWidgets.staticRender();}')

  dtbl$x$options$fnDrawCallback <- render_js_code
  return(dtbl)
}

Step 4 - add dependencies for the htmlwidget being used

add_deps <- function(dtbl, name, pkg = name) {
  tagList(
    dtbl,
    htmlwidgets::getDependency(name, pkg)
  )
}

Altogether now

library(htmltools)
library(htmlwidgets)
library(DT)
library(sparkline)
library(dplyr)

mtcars %>%
  group_by(cyl) %>%
  summarise(
    spk_line = as.character(
      sparkline(hp, type = "bar")
    )
  ) %>%
  datatable(escape=FALSE) %>%
  add_datatable_render_code() %>%
  add_deps("sparkline", "sparkline") %>%
  browsable()

[timelyportfolio]

I guess if https://github.com/ramnathv/htmlwidgets/issues/268 is a no go, we could include an as.character conversion within DT for htmlwidgets.

[timelyportfolio]

One more example with leaflet

library(htmltools)
library(htmlwidgets)
library(DT)
library(leaflet)
library(dplyr)

data.frame(
  state = state.abb[1:3],
  x = state.center$x[1:3],
  y = state.center$y[1:3],
  stringsAsFactors = FALSE
) %>%
  group_by(state) %>%
  summarise(
    leaf_map = as.character(
      setView(
        addTiles(
          leaflet(height = 200, width = 200)
        ),
        x,
        y,
        zoom = 4
      )
    )
  ) %>%
  datatable(escape = FALSE) %>%
  add_datatable_render_code() %>%
  add_deps("leaflet", "leaflet") %>%
  browsable()

[timelyportfolio]

and datatable in datatable

library(DT)
library(dplyr)
library(htmltools)
library(htmlwidgets)

mtcars %>%
  group_by(cyl) %>%
  summarise(detail_tbl = as.character(datatable(data.frame(hp,mpg)))) %>%
  datatable(escape = FALSE) %>%
  add_datatable_render_code()

[timelyportfolio]

And just to insure that I overdo this...

datatable with sparkline within datatable with sparkline

library(DT)
library(sparkline)
library(dplyr)
library(htmltools)
library(htmlwidgets)

mtcars %>%
  group_by(cyl) %>%
  summarise(
    spk = as.character(sparkline(hp, type="bar")),
    detail_tbl = as.character(
      datatable(
        data.frame(
          hp = hp,
          mpg = mpg,
          spk = rep(as.character(sparkline(1:10, type="line")), length(hp))
        ),
        escape = FALSE
      ) %>% add_datatable_render_code()
    )
  ) %>%
  datatable(escape = FALSE) %>%
  add_datatable_render_code() %>%
  add_deps("sparkline", "sparkline") %>%
  browsable()

[ramnathv]

This is cool! I realized that this could be simplified considerably. See code below

# Load Libraries ----
library(DT)
library(htmltools)
library(dplyr)
library(sparkline)
library(leaflet)

# Helper functions (I think should be added to HTMLWidgets) ----
as.character.htmlwidget <- function(x){
  as.character(htmlwidgets:::toHTML(x))
}

staticRenderJS <- htmlwidgets::JS('function(){
    HTMLWidgets.staticRender()                                    
}')

# Helper function (I think should be added to DT)
widgetTable <- function(data, options = list(), deps = list(), ...){
  options$fnDrawCallback = staticRenderJS
  dt <- DT::datatable(data, options = options, escape = F, ...)
  dt %>% tagList(deps) %>% browsable
}

# Example 1: Sparkline
mtcars %>%
  group_by(cyl) %>%
  summarise(
    spk_line = as.character(sparkline(hp, type = 'bar'))
  ) %>%
  widgetTable(deps = htmlwidgets::getDependency("sparkline", "sparkline"))

# Example 2: Leaflet
myMap <- function(data = NULL, lng, lat){
  leaflet(data = data, height = 200, width = 200) %>%
    addTiles() %>%
    setView(lng = lng, lat = lat, zoom = 4)
}

data.frame(
  state = state.abb[1:3],
  lng = state.center$x[1:3],
  lat = state.center$y[1:3],
  stringsAsFactors = FALSE
) %>%
  group_by(state) %>%
  summarise(
    leaf_map = as.character(myMap(lng = lng, lat = lat))
  ) %>%
  widgetTable(deps = htmlwidgets::getDependency("leaflet", "leaflet"))

This idea can be abstracted one step further to easily support widget in widgets that @timelyportfolio indicated. I will post another example shortly.

[timelyportfolio]

Completely missed toHTML. That is far more pleasant. I like your widgetTable idea, since it does overcome some of the complications that arise from my breaking down into steps approach. Looking forward to the further abstraction, since that is far more interesting to me :) The as.character seems to be the key to all of this. Of course, staticRender() and adding dependencies also important.

[carlganz]

This is neat. Just a thought from my experience having difficulty including Shiny inputs inside datatables, do you have to bind/unbind the HTMLwidgets manually a la this each time you rerender the table?

[timelyportfolio]

I believe this bind/unbind will still be necessary unless the htmlwidget uses Shiny.onInputChange directly which will not require an official binding.

[ramnathv]

Here is the more generic patter for a widget in widget. At the heart of it is a addWidget S3 method that will belong to htmlwidgets. It will allow widget dependencies to be added and rendered after the parent widget is rendered using onStaticRenderComplete. This code is not yet optimized since it leads to a static re render of all widgets on the page.

pkgs <- c('htmlwidgets', 'htmltools', 'sparkline', 'leaflet', 'DT', 'plotly', 'dplyr')
for (pkg in pkgs) library(pkg, character.only = TRUE)

# Helper functions (to be added to HTMLWidgets) ----
as.character.htmlwidget <- function(x){
  as.character(htmlwidgets:::toHTML(x))
}

staticRenderJS <- htmlwidgets::JS('function(){
    HTMLWidgets.staticRender()                                    
}')

#' Add a widget to a htmlwidget
addWidget <- function(x, widget, package = widget, ...){
  UseMethod('addWidget')
}

#' The default method simply attaches the widget dependencies and
#' rerenders all widgets on the page. The code can be cleaned up
#' to only render the widget in question
addWidget.default <- function(x, widget, package = widget){
  x %>% tagList(
    htmlwidgets::getDependency(widget, package),
    onStaticRenderComplete(
      "HTMLWidgets.staticRender()"
    )
  ) %>%
    browsable
}

#' DT can add its own S3 method for addWidget that allows a callback code to 
#' be run right after the table is rendered. We take advantage of that here
addWidget.DT <- function(x, widget, package = widget, ...){
  x$x$options$fnDrawCallback = staticRenderJS
  x %>% tagList(deps) %>% browsable
}

#' Example 1: Plotly in Leaflet
my_plot <- plot_ly(economics, x = ~ pop, height = 200, width = 300)
leaflet() %>% addTiles() %>%
  addPopups(-122.327298, 47.597131, as.character(my_plot),
    options = popupOptions(closeButton = FALSE)
  ) %>%
  addWidget('plotly')

#' Example 2: Dygraphs in Leaflet
library(dygraphs)
my_plot <- dygraphs::dygraph(ldeaths, width = 300, height = 200)
leaflet() %>% addTiles() %>%
  addPopups(-122.327298, 47.597131, as.character(my_plot),
      options = popupOptions(closeButton = FALSE)
  ) %>%
  addWidget('dygraphs')

#' Example 3: Sparkling in DT
mtcars %>%
  group_by(cyl) %>%
  summarise(
    spk_line = as.character(sparkline(hp, type = 'bar'))
  ) %>%
  datatable(escape = FALSE) %>%
  addWidget('sparkline')

#' Example 4: Leaflet in DT
myMap <- function(data = NULL, lng, lat){
  leaflet(data = data, height = 200, width = 200) %>%
    addTiles() %>%
    setView(lng = lng, lat = lat, zoom = 4)
}

data.frame(
  state = state.abb[1:3],
  lng = state.center$x[1:3],
  lat = state.center$y[1:3],
  stringsAsFactors = FALSE
) %>%
  group_by(state) %>%
  summarise(
    leaf_map = as.character(myMap(lng = lng, lat = lat))
  ) %>%
  datatable(escape = FALSE) %>%
  addWidget('leaflet')

[timelyportfolio]

@ramnathv, very nice but one correction (unless I misunderstand), HTMLWidgets.staticRender() will not rerender based on lines.

        if (hasClass(el, "html-widget-static-bound"))
          return;

This is a very nice feature especially in the context of DT. In effect cells are memoized.

[ramnathv]

I might abstract away the as.character call to something like embedWidget so we can keep its implementation internal. For the end user, the message is use embedWidget to embed your widget inside another widget.

@yihui @jcheng5 @jjallaire would love to get your thoughts on this. I think this would be a very powerful feature to support.

[jcheng5]

Focusing on this part:

... %>%
  summarise(
    leaf_map = as.character(myMap(lng = lng, lat = lat))
  ) %>%
  datatable(escape = FALSE) %>%
  addWidget('leaflet')

I don't like the flattening of myMap here (whether using as.character or embedWidget as the name), and then the adding of widget-oriented stuff in addWidget. I'd prefer to be able to do

... %>%
  summarise(
    leaf_map = myMap(lng = lng, lat = lat)
  ) %>%
  datatable()

This would require special handling by DT, but once implemented, it's a mechanism that actually could be fairly generic (as in, any htmltools tag objects, or things that are coercible to htmltools tag objects using as.tags, could be supported--and htmlwidgets are just one special case of these).

(Granted, the approach you all sketched out above does have the advantage that the outer widget need not know much of anything--other than embedding raw HTML strings--and that's certainly a significant plus.)

[ramnathv]

@jcheng5 That is perfect and was the idea I had initially. However, it required hacking at the internals of each widget and so I settled for this approach. I think we can allow for a two pronged approach:

1. Widgets can implement their own mechanisms to handle embedded widgets, like you outlined in your code. Ideally all widgets should do this if they want to entertain the possibility of embedding other widgets.

2. Widgets can also embed other widgets using the mechanism outlined earlier. This is not ideal, but would extend the embedding capabilities to the entire widget ecosystem.

Let me know what you think.

[clarencejychan]

I've copied some of this code and am trying to render the DataTable inside Shiny, but am running into errors.

Warning: Error in <Anonymous>: 'data' must be 2-dimensional (e.g. data frame or matrix)
  105: stop
  104: <Anonymous>
  102: processWidget
  101: widgetFunc
  100: func
   87: origRenderFunc
   86: renderFunc
   82: origRenderFunc
   81: output$output_table
    1: runApp

Does this pattern not play nice with Shiny? It seems to be erroring out with the add_deps function.

If I end up adding browsable, renderDT doesn't like it since I'm not giving it a datatable back. I also tried removing browsable and then having add_deps return the datatable so renderDT is happy, but then the widgets don't show up. How could I fix this?

For reference, the widget I'm trying to use is listviewer. I can get the widget embedded and rendered if not using Shiny, but once I use renderDT it fails with the above reasoning.

[ramnathv]

@clarencejychan There is a workaround for this issue. I am a little tied up currently but will post an example next week.

[jcheng5]

@clarencejychan A reprex might also be helpful.

[clarencejychan]

@jcheng5 i'll try to see if I can get one by Monday. and thank you @ramnathv, that would be a life saver.

[timelyportfolio]

Is this a crosspost of the issue https://stackoverflow.com/questions/61826479/embedding-html5-widgets-in-datatables-in-r-shiny? Want to make sure that we tie the two together if so.

[timelyportfolio]

If uiOutput/renderUI is a workable option, then a potential solution would be:

# Helper functions (to be added to HTMLWidgets) ----
as.character.htmlwidget <- function(x){
  as.character(htmlwidgets:::toHTML(x))
}

staticRenderJS <- htmlwidgets::JS('function(){
    HTMLWidgets.staticRender()                                    
}')

#' Add a widget to a htmlwidget
addWidget <- function(x, widget, package = widget, ...){
  UseMethod('addWidget')
}

#' The default method simply attaches the widget dependencies and
#' rerenders all widgets on the page. The code can be cleaned up
#' to only render the widget in question
addWidget.default <- function(x, widget, package = widget){
  x %>% tagList(
    htmlwidgets::getDependency(widget, package),
    onStaticRenderComplete(
      "HTMLWidgets.staticRender()"
    )
  ) %>%
    browsable
}

#' DT can add its own S3 method for addWidget that allows a callback code to 
#' be run right after the table is rendered. We take advantage of that here
addWidget.DT <- function(x, widget, package = widget, ...){
  x$x$options$fnDrawCallback = staticRenderJS
  x %>% tagList(deps) %>% browsable
}

library(shiny)
library(htmltools)
library(htmlwidgets)
library(DT)
library(listviewer)

dt <- datatable(
  data.frame(
    x = 1:2,
    widget = as.character.htmlwidget(jsonedit(list(data = 1:3),height=200)),
    stringsAsFactors = FALSE
  ),
  escape = FALSE
)%>%
  {
    # ugly hack since DT will only add selection property if it thinks it is in Shiny
    .$x$selection = list(mode = "none")
    .
  } %>%
  addWidget('jsonedit', 'listviewer')

shinyApp(
  uiOutput('dt'),
  function(input, output, session) {
    output$dt <- renderUI({dt})
  }
)

[clarencejychan]

hi @timelyportfolio , it is indeed a cross post. I was trying to reach a broader audience as it seems this issue/feature isn't commonly requested (and I'm just a beginner in using R and Shiny). Let me give your update a try and I'll keep everyone on this thread updated. It seems like this could be a really useful feature to put into DT one day.

[ramnathv]

@clarencejychan I am wrapping some functionality I built for this into a dtplus package, that will let you do this out of the box. I will put it on GitHub this week.

[clarencejychan]

@ramnathv, and @timelyportfolio looks like the above example worked completely fine! Thanks both for your help in this issue as it helps me out tremendously. @ramnathv, whenever you get that out of the box I'll transition to that. Once again, appreciate it lots.

[markschat]

I just read through this interesting discussion and try to use the shiny-solution provided by @timelyportfolio with plotly.

The table shows up with no error, unfortunately no plots are rendered (only whitespace). Here´s a short example:

# Helper functions (to be added to HTMLWidgets) ----

as.character.htmlwidget <- function(x){
  as.character(htmlwidgets:::toHTML(x))
}

staticRenderJS <- htmlwidgets::JS('function(){
    HTMLWidgets.staticRender()                                    
}')

addWidget <- function(x, widget, package = widget, ...){
  UseMethod('addWidget')
}

addWidget.default <- function(x, widget, package = widget){
  x %>% tagList(
    htmlwidgets::getDependency(widget, package),
    onStaticRenderComplete(
      "HTMLWidgets.staticRender()"
    )
  ) %>%
    browsable
}

addWidget.DT <- function(x, widget, package = widget, ...){
  x$x$options$fnDrawCallback = staticRenderJS
  x %>% tagList(deps) %>% browsable
}

library(shiny)
library(htmltools)
library(htmlwidgets)
library(DT)
library(plotly)

fig <- plot_ly(
  iris,
  x = ~Sepal.Length,
  y = ~Petal.Length,
  height = 150
)

dt <- datatable(
  data.frame(
    x = 1:4,
    widget = as.character.htmlwidget(fig),
    stringsAsFactors = FALSE
  ),
  escape = FALSE
) %>%
  {
    # ugly hack since DT will only add selection property if it thinks it is in Shiny
    .$x$selection = list(mode = "none")
    .
  } %>%
  addWidget('plot_ly', 'plotly')

shinyApp(
  uiOutput('dt'),
  function(input, output, session) {
    output$dt <- renderUI(dt)
  }
)

The HTML-Structure seems fine - I think there is a problem with the dependencies. htmlwidgets::getDependency("plot_ly", "plotly") gives me 1 dependency:

• htmlwidgets

while htmltools::findDependencies(fig) gives me 7:

• htmlwidgets
• plotly-binding
• typedarray
• jquery
• crosstalk
• plotly-htmlwidgets-css
• plotly-main

If I replace getDependency with the result of findDependencies a plot shows up but only the first one in the table, the rest remains unrendered.

Any idea on how to use the combination of shiny, DT and plotly?

[stla]

That's because your four plotly graphics have the same id, this is not allowed in HTML. You can proceed like this:

addWidget.default <- function(x, widget, package = widget){
  x %>% tagList(
    htmltools::findDependencies(figs[[1]]),
    onStaticRenderComplete(
      "HTMLWidgets.staticRender()"
    )
  ) %>%
    browsable
}

figs <- replicate(4, plot_ly(
  iris,
  x = ~Sepal.Length,
  y = ~Petal.Length,
  height = 150
), simplify = FALSE)

dt <- datatable(
  data.frame(
    x = 1:4,
    widget = vapply(figs, as.character.htmlwidget, character(1L)),
    stringsAsFactors = FALSE
  ),
  escape = FALSE
) %>%

[markschat]

That's because your four plotly graphics have the same id, this is not allowed in HTML.

Thanks! Your answer brings the plotly-charts to live 🙌. I still have one pain point where I´m stuck:

I would like to use server-side processing as my table is large. DT::renderDT gives me an option for this - the proposed solution uses shiny::renderUI instead. This leads to client-side processing, if I´m not mistaken. @ramnathv mentioned a solution that would support DT::renderDT. I think, this would be a great improvement as performance is often an issue when using many widgets.

One sidenote: I had to add this option to DT::datatable as only the plots on the first page where visible without it (#26).

  options = list(
    fnDrawCallback = htmlwidgets::JS('function(){
    HTMLWidgets.staticRender();
    }'
    )
  )

[stla]

Here is another way:

library(DT)
library(htmltools)
library(plotly)

js <- c(
  "function(){",
  "  var $plot = $('#figdiv');",
  "  var $td = $('#target');",
  "  $td.append($plot);",
  "}"
)

fig <- plot_ly(
  iris,
  x = ~Sepal.Length,
  y = ~Petal.Length,
  height = 150,
  width = 300
)

dat <- cars[1:2,]
dat$test <- c("a", '<div id="target"></div>')
dtable <- datatable(
  dat,
  escape = FALSE, 
  options = list(initComplete = JS(js))
)

browsable(
  tagList(
    tags$div(fig, id = "figdiv"),
    dtable
  )
)

[markschat]

@stla thank you for your hints! Finally I have found a (simple) way to use plotly::plot_ly with the regular DT::renderDT/ DT::DTOutput functions 🎉

The server-side rendering (DT default) paired with the option deferRender = TRUE brings massive performance improvements. A 1000 row table with pageLength 10 renders in no time (compared to the previous solutions).

One last thing bothers me, the plotly-widget in the first row doesn´t auto-adjust it´s width to the available table space. All other widgets do. How to fix this behaviour?

Implementation using DT render function:

library(shiny)
library(htmltools)
library(htmlwidgets)
library(DT)
library(plotly)

# helper function to attach dependencies ----

attachPlotlyDeps <- function(tbl) {
  old_deps <- tbl$dependencies
  tbl$dependencies <- resolveDependencies(
    c(old_deps, findDependencies(plot_ly()))
  )
  tbl
}

data <- data.frame(
  x = 1:2,
  widget = replicate(
    2, 
    as.character(htmlwidgets:::toHTML(plot_ly(x = runif(5), y = runif(5))))
  )
)

dt <- datatable(
  data,
  options = list(
    fnDrawCallback = JS('function(){ HTMLWidgets.staticRender(); }'),
    deferRender = TRUE
  ),
  escape = FALSE
) |> 
  attachPlotlyDeps()

shinyApp(
  DTOutput('dt'),
  function(input, output, session) {
    output$dt <- renderDT(dt)
  }
)