shiny - 将shinyWidgets添加到R中的数据表中

Question

我目前正在尝试将来自 shinyWidgets 的漂亮用户输入添加到 DT 数据表中。

我试图按照 DT github 中的示例使用 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, ]
  )
}
datatable(m, escape = FALSE, options = list(dom = 't', paging = FALSE, ordering = FALSE))

我现在想有一个李克特量表的第六列，就像这里介绍的那样：http: //shinyapps.dreamrs.fr/shinyWidgets/

在 R 控制台中执行命令时会给出 div 信息。所以我尝试像 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))

不幸的是，这显然没有提供来自 shinyWidgets 的输入。

任何想法 ？

Answer 1

这是一个例子。

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)