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

Question

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

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

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

name<-c("Jack","Bob","Jack","Bob")
item<-c("apple","olive","banana","tomato")
d<-data.frame(name,item)

words<-tapply(d$item, d$name, I)


nrows <- length(words)

js <- c(
  "function(settings) {",
  sprintf("var nrows = %d;", nrows),
  sprintf("var words = %s;", toJSON(words)),
  "  var table = this.api().table();",
  "  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]);",
  "  }",
  "}"
)

ui <- fluidPage(
  br(),
  DTOutput("table"),
  div( # this is a hidden selectize input whose role is to make
    # available 'selectize.js'
    style = "display: none;",
    selectInput("id", "label", c("x", "y"))
  )
)

server <- function(input, output, session) {
  
  output[["table"]] <- renderDT({
    dat <- data.frame(
      FOO = c(unique(d$name)),
      Words = vapply(
        1:nrows,
        function(i){
          selector(paste0("slct", i), words[[i]])
        },
        character(1)
      ),
      Count = lengths(words),
      stringsAsFactors = FALSE
    )
    
    datatable(
      data = dat,
      selection = "none",
      escape = FALSE,
      rownames = FALSE,
      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)
  
  
}

shinyApp(ui, server)

Answer 1

我们可以用 selectizeInput:

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), c("",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);",
  "}"
)

ui <- fluidPage(
  br(),
  verbatimTextOutput("words1"),
  DTOutput("table"),
  div( # this is a hidden selectize input whose role is to make
       # available 'selectize.js'
    style = "display: none;",
    selectInput("id", "label", c("x", "y"))
  )
)

server <- function(input, output, session) {

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

    datatable(
      data = dat,
      selection = "none",
      escape = FALSE,
      rownames = FALSE,
      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, values, items = values){
  options <- HTML(paste0(mapply(
    function(value, item){
      as.character(tags$option(value = value, item))
    }, c("",values), c("",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))),
  "  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,",
  "    onChange: function(value) {",
  "      var count = value.length;",
  "      table.cell(1,2).data(count);",
  "    }",
  "  });",
  "  Shiny.setInputValue('slct1', words1);",
  "  Shiny.setInputValue('slct2', words2);",
  "}"
)

ui <- fluidPage(
  br(),
  verbatimTextOutput("words1"),
  DTOutput("table"),
  div( # this is a hidden selectize input whose role is to make
       # available 'selectize.js'
    style = "display: none;",
    selectInput("id", "label", c("x", "y"))
  )
)

server <- function(input, output, session) {

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

    datatable(
      data = dat,
      selection = "none",
      escape = FALSE,
      rownames = FALSE,
      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)
library(jsonlite)

selector <- function(id, values, items = values){
  options <- HTML(paste0(mapply(
    function(value, item){
      as.character(tags$option(value = value, item))
    }, c("", values), c("", items)
  ), collapse = ""))
  as.character(
    tags$select(
      id = id, class = "form-control", multiple = "multiple", 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)),
  "  var table = this.api().table();",
  "  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]);",
  "  }",
  "}"
)

ui <- fluidPage(
  br(),
  verbatimTextOutput("words1"),
  DTOutput("table"),
  div( # this is a hidden selectize input whose role is to make
       # available 'selectize.js'
    style = "display: none;",
    selectInput("id", "label", c("x", "y"))
  )
)

server <- function(input, output, session) {

  output[["table"]] <- renderDT({
    dat <- data.frame(
      FOO = c("bar", "baz"),
      Words = vapply(
        1:nrows,
        function(i){
          selector(paste0("slct", i), words[[i]])
        },
        character(1)
      ),
      Count = lengths(words),
      stringsAsFactors = FALSE
    )

    datatable(
      data = dat,
      selection = "none",
      escape = FALSE,
      rownames = FALSE,
      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)

Answer 2

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

library(shiny)
library(DT)

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

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

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

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(),
  verbatimTextOutput("words1"),
  DTOutput("table")
)

server <- function(input, output, session) {

  output[["table"]] <- renderDT({
    dat <- data.frame(
      FOO = c("bar", "baz"),
      Words = vapply(
        1:nrows,
        function(i){
          selector(paste0("slct", i), words[[i]])
        },
        character(1)
      ),
      Count = lengths(words),
      stringsAsFactors = FALSE
    )

    datatable(
      data = dat,
      selection = "none",
      escape = FALSE,
      rownames = FALSE,
      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)

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

Display multiple strings in a cell of a datatable that can be removed by clicking on them

r

shiny

dt

shinywidgets

编辑

编辑

编辑