add shinyWidgets into datatable in R

Question

I am currently trying to add nice user input from shinyWidgets into a DT datatable.

I tried to follow the example from DT github with the radioButtons, which is working fine :

library(DT)
library(shinyWidgets)

m = data.frame(matrix(
  as.character(1:5), nrow = 12, ncol = 5, byrow = TRUE,
  dimnames = list(month.abb, LETTERS[1:5])
), stringsAsFactors = F)
for (i in seq_len(nrow(m))) {
  m[i, ] = sprintf(
    '<input type="radio" name="%s" value="%s"/>',
    month.abb[i], m[i, ]
  )
}
datatable(m, escape = FALSE, options = list(dom = 't', paging = FALSE, ordering = FALSE))

I would like now to have a sixth column with a likert scale, just like presented here : http://shinyapps.dreamrs.fr/shinyWidgets/

The div information is given when the command is executed in the R console. So I tried to add it just like the radioButtons :

library(DT)
library(shinyWidgets)

m = data.frame(matrix(
  as.character(1:5), nrow = 12, ncol = 5, byrow = TRUE,
  dimnames = list(month.abb, LETTERS[1:5])
), stringsAsFactors = F)
for (i in seq_len(nrow(m))) {
  m[i, ] = sprintf(
    '<input type="radio" name="%s" value="%s"/>',
    month.abb[i], m[i, ]
  )
}
m$new_input <- NA
for (i in seq_len(nrow(m))) {
  m[i, 6] = sprintf(
    '<div class="form-group shiny-input-container">
  <label class="control-label" for="Id102">Your choice:</label>
    <input class="js-range-slider sw-slider-text" data-data-type="text" data-force-edges="true" data-from="0" data-from-fixed="false" data-from-shadow="false" data-grid="true" data-hide-min-max="false" data-keyboard="true" data-prettify-enabled="false" data-swvalues="[&quot;Strongly disagree&quot;,&quot;Disagree&quot;,&quot;Neither agree nor disagree&quot;,&quot;Agree&quot;,&quot;Strongly agree&quot;]" data-to-fixed="false" data-to-shadow="false" id="%s"/>
    </div>',
    paste("slider",month.abb[i], sep = "_")
  )
}

datatable(m, escape = FALSE, options = list(dom = 't', paging = FALSE, ordering = FALSE))

Unfortunately, this is clearly not giving the input from shinyWidgets.

Any idea ?

Answer 1

Here is an example.

library(shiny)
library(shinyWidgets)
library(DT)

ui <- fluidPage(
  br(),
  DTOutput("dt"), 
  br(),
  tags$label("Slider1:"),
  verbatimTextOutput("choice1"),
  tags$label("Slider2:"),
  verbatimTextOutput("choice2")
)

sti <- function(id){
  as.character(sliderTextInput(
    inputId = id,
    label = "Your choice:",
    grid = TRUE,
    force_edges = TRUE,
    choices = c("Disagree", "Agree"))
  )
}

js <- c(
  "function(settings){",
  "  $('[id^=slider]').each(function(){",
  "   $(this).ionRangeSlider({values: $(this).data('swvalues')});",
  "  });",
  "}"
)


server <- function(input, output){

  dat <- data.frame(
    word = c("hello", "goodbye"),
    status = c(sti("slider1"), sti("slider2"))
  )

  output[["dt"]] <- renderDT({
    dtable <- datatable(dat, escape = FALSE, 
                        callback = JS(c('Shiny.unbindAll(table.table().node());',
                                        'Shiny.bindAll(table.table().node());')),
                        options = list(
                          initComplete = JS(js)
                        ))
    dep1 <- htmltools::htmlDependency(
      "ionrangeslider", "2.1.6",
      src = "www/shared/ionrangeslider",
      script = "js/ion.rangeSlider.min.js",
      stylesheet = c("css/ion.rangeSlider.css", "css/ion.rangeSlider.skinShiny.css"),
      package = "shiny")
    dep2 <- htmltools::htmlDependency(
      "strftime", "0.9.2",
      src = "www/shared/strftime",
      script = "strftime-min.js",
      package = "shiny")
    dep3 <- htmltools::htmlDependency(
      "shinyWidgets", "0.4.5",
      src = "www",
      script = "shinyWidgets-bindings.min.js",
      stylesheet = "shinyWidgets.css",
      package = "shinyWidgets")
    dtable$dependencies <- c(dtable$dependencies, list(dep1,dep2,dep3))
    dtable
  }, server = FALSE)

  output[["choice1"]] <- renderPrint(input[["slider1"]])
  output[["choice2"]] <- renderPrint(input[["slider2"]])

}

shinyApp(ui, server)