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

Question

I have the shiny app below in which I convert the d dataframe to a dataframe in which the unique items will be summarized based on the name and a new column will be added with their count. Then I use DT package to display this dataframe. I wonder if DT or shinywidgets or maybe another method can be used in order to display the table like in the screenshot below in which the user will be able to display the different strings in the items column as separated words that he will be able to remove. Here is an example in the second column.

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)

Stéphane Laurent · Accepted Answer · 2021-01-11T06:26:59.123

We can do that with a 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)

EDIT

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)

EDIT

With the counts:

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)

EDIT

For an arbitrary number of rows:

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)

Thanks but Im not sure how to pass my dataframe d in there since you pass the options manually. My original dataset d is much bigger I cannot pass every option manually — firmo23, Jan 11 '21 at 04:23
wow that is more than a full answer I ll give that to you ana continue my work based on your answer thanks — firmo23, Jan 11 '21 at 12:55
hey I had adapted a little bit the list I m using in your answer and now I get numbers instead of names and also the selectize inputs seem to be empty. — firmo23, Jan 11 '21 at 13:40
I have created a new Q based on this https://stackoverflow.com/questions/65668902/datatable-displays-numbers-instead-of-characters-coming-from-a-list-in-a-shiny-a — firmo23, Jan 11 '21 at 14:39

score 1 · Answer 2 · answered Jan 12 '21 at 13:52

Here is another version. It uses the JavaScript library select2 instead of selectize. I find this one more convenient for the removal of the selected options: they are removed on clicking, while with selectize one needs the keyboard to remove an option.

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)

based on your solution I developed this app and Q https://stackoverflow.com/questions/65693747/add-a-new-row-to-a-dataframe-by-clicking-on-a-datatable-row-and-actionbutton — firmo23, Jan 12 '21 at 23:54
Hi Stephane based on your code I try to implemet 2 more features. I think you re the only one that can help me to finish this since this your method. In the 1st one u need to apply the method in the next DT row https://stackoverflow.com/questions/65712967/move-to-the-next-row-of-clicked-one-in-a-dt-datatable-using-an-actionbutton and in the 2nd to another DT row https://stackoverflow.com/questions/65710169/assign-a-value-on-a-different-row-of-a-datatable-than-the-clicked-one-in-a-shiny — firmo23, Jan 14 '21 at 20:30

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

2 Answers2

EDIT

EDIT

EDIT