在数据表的单元格中显示多个字符串，可以通过单击将其删除

编程问答 2022-05-30

问题描述

我在下面有一个闪亮的应用程序，我将 d 数据框转换为一个数据框，其中唯一的 items 将根据 name 进行汇总，并添加一个新列与他们的count。然后我使用 DT 包来显示这个数据框。我想知道是否可以使用 DT 或 shinywidgets 或其他方法来显示如下屏幕截图中的表格，其中用户将能够在 {{1} } 列作为分隔词，他将能够删除。这是第二列中的示例。

enter image description here

items

解决方法

我们可以用 selectizeInput 做到这一点：

enter image description here

library(shiny)
library(DT)

js <- c(
  "function(settings){","  $('#mselect').selectize();","}"
)

ui <- fluidPage(
  br(),DTOutput("table"),div(
    style = "display: none;",selectInput("id","label",c("x","y"))
  )
)

server <- function(input,output,session) {
  
  output[["table"]] <- renderDT({
    dat <- data.frame(
      FOO = "bar",BAZ = '<select id="mselect" class="form-control" multiple="multiple">
                       <option value=""></option>
                       <option value="A">Apple</option>
                       <option value="B">Banana</option>
                       <option value="C">Lemon</option>
                       </select>',stringsAsFactors = FALSE)
    
    datatable(
      data = dat,selection = "none",escape = FALSE,rownames = FALSE,options = list(
        initComplete = JS(js)
      )
    )
  })
  
}

shinyApp(ui,server)

编辑

library(shiny)
library(DT)

selector <- function(id,values,items = values){
  options <- HTML(paste0(mapply(
    function(value,item){
      as.character(tags$option(value = value,item))
    },c("",values),items)
  ),collapse = ""))
  as.character(
    tags$select(
      id = id,class = "form-control",multiple = "multiple",options
    )
  )
}

words1 <- c("apple","banana")
words2 <- c("olive","tomato")

js <- c(
  "function(settings) {",sprintf("var words1 = [%s];",toString(shQuote(words1))),sprintf("var words2 = [%s];",toString(shQuote(words2))),"  $('#slct1').selectize({items: words1});","  $('#slct2').selectize({items: words2});","  Shiny.setInputValue('slct1',words1);","  Shiny.setInputValue('slct2',words2);",verbatimTextOutput("words1"),div( # this is a hidden selectize input whose role is to make
       # available 'selectize.js'
    style = "display: none;",session) {

  output[["table"]] <- renderDT({
    dat <- data.frame(
      FOO = c("bar","baz"),Words = c(
        selector("slct1",words1),selector("slct2",words2)
      ),stringsAsFactors = FALSE
    )

    datatable(
      data = dat,options = list(
        initComplete = JS(js),preDrawCallback = JS(
          'function() { Shiny.unbindAll(this.api().table().node()); }'
        ),drawCallback = JS(
          'function() { Shiny.bindAll(this.api().table().node()); }'
        )
      )
    )
  },server = FALSE)

  output[["words1"]] <- renderPrint({
    input[["slct1"]]
  })
}

shinyApp(ui,server)

编辑

计数：

library(shiny)
library(DT)

selector <- function(id,"  var table = this.api().table();","  $('#slct1').selectize({","    items: words1,","    onChange: function(value) {","      var count = value.length;","      table.cell(0,2).data(count);","    }","  });","  $('#slct2').selectize({","    items: words2,"      table.cell(1,Count = c(length(words1),length(words2)),server)

enter image description here

编辑

对于任意数量的行：

library(shiny)
library(DT)
library(jsonlite)

selector <- function(id,options
    )
  )
}

words <- list(
  c("apple","banana"),c("olive","tomato")
)

nrows <- length(words)

js <- c(
  "function(settings) {",sprintf("var nrows = %d;",nrows),sprintf("var words = %s;",toJSON(words)),"  function selectize(i) {","    $('#slct' + i).selectize({","      items: words[i-1],"      onChange: function(value) {","        table.cell(i-1,2).data(value.length);","      }","    });","  }","  for(var i = 1; i <= nrows; i++) {","    selectize(i);","    Shiny.setInputValue('slct' + i,words[i-1]);",Words = vapply(
        1:nrows,function(i){
          selector(paste0("slct",i),words[[i]])
        },character(1)
      ),Count = lengths(words),server)
,

这是另一个版本。它使用 JavaScript 库 select2 而不是 selectize。我发现这个更方便删除选定的选项：它们在点击时被删除，而 selectize 需要键盘来删除一个选项。

enter image description here

library(shiny)
library(DT)

selector <- function(id,selected = "selected",items
  ),"tomato")
)
nrows <- length(words)

js <- c(
  "function(settings) {","    var $slct = $('#slct' + i);","    $slct.select2({","      width: '100%',"      closeOnSelect: false","    $slct.on('change',function(e) {","      table.cell(i-1,2).data($slct.val().length);","}"
)

ui <- fluidPage(
  tags$head(
    tags$link(rel = "stylesheet",href = "https://cdnjs.cloudflare.com/ajax/libs/select2/4.0.13/css/select2.min.css"),tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/select2/4.0.13/js/select2.min.js")
  ),br(),DTOutput("table")
)

server <- function(input,server)
dtrrshinyshinywidgets