R DT filter for comma-separated text with multi-select

I have a dataframe with a weekday column. In it can be one weekday or multiple weekdays, comma separated. I want to show the table with the filter on top and the weekdays column should behave like a factor filter, so the multi-select pops-up with the 7 possible weekdays.

I tried with the yadcf Datatables plugin: https://github.com/vedmack/yadcf/

library(shiny)

ui <- fluidPage(
  tags$head(
    tags$link(href="jquery.dataTables.yadcf.css", rel = "stylesheet"),
    tags$script(src="jquery.dataTables.yadcf.js"),
  ),
  dataTableOutput("sometable")
)

jsc <- '
    function(settings, json) {
        var table = settings.oInstance.api();
        yadcf.init(table, [{
          column_number : 2,
          column_data_type: "text",
          data: [{"label": "Montag", "value": 1}, {"label": "Dienstag", "value": 2}, {"label": "Mittwoch", "value": 3},
                 {"label": "Donnerstag", "value": 4}, {"label": "Freitag", "value": 5}, {"label": "Samstag", "value": 6}, {"label": "Sonntag", "value": 7}],
          omit_default_label: true,
          //filter_type: "multi_select",
          text_data_delimiter: ","
        }]);
    }
'

server <- function(input, output) {
  output$sometable <- renderDataTable({
    df <- data.frame(ID = 1:6,
                     Weekdays = c("Montag", "Dienstag,Mittwoch", "Mittwoch,Samstag",
                                  "Donnerstag", "Montag,Freitag", "Samstag,Sonntag"))

    datatable(df, filter = "top",
              options = list(
                initComplete = JS(jsc))
    )
  })
}

shinyApp(ui, server)

EDIT: This JS works, but I would like the multi-select to look nicer, like a normal select input and actually I would like that select instead of the default one from filter="top".

jsc <- '
    function(settings, json) {
        var table = settings.oInstance.api();
        yadcf.init(table, [{
          column_number : 2,
          column_data_type: "text",
          data: ["Montag","Dienstag","Mittwoch","Donnerstag","Freitag","Samstag","Sonntag"],
          sort_as: "num",
          omit_default_label: true,
          filter_type: "multi_select",
          text_data_delimiter: ","
        }]);
    }
'

EDIT 2:

Ideally I would like the behaviour in this example in the Tags column https://yadcf-showcase.appspot.com/cumulative_filtering.html

Solution

I removed data and omit_default_label and it works fine. Is it what you want?

library(DT)

js <- '
      yadcf.init(table, [
        {
          column_number : 2,
          column_data_type: "text",
          //data: [{"label": "Montag", "value": 1}, {"label": "Dienstag", "value": 2}, {"label": "Mittwoch", "value": 3},
          //       {"label": "Donnerstag", "value": 4}, {"label": "Freitag", "value": 5}, {"label": "Samstag", "value": 6}, {"label": "Sonntag", "value": 7}],
          //omit_default_label: true,
          text_data_delimiter: ","
        }
      ]);
'

df <- data.frame(ID = 1:6,
                 Weekdays = c("Montag", "Dienstag,Mittwoch", "Mittwoch,Samstag",
                              "Donnerstag", "Montag,Freitag", "Samstag,Sonntag"))

dtable <- datatable(
  df, #filter = "top",
  callback = JS(js)
)

dep <- htmltools::htmlDependency(
  "yadcf", "0.9.3",
  c(href =  "https://cdnjs.cloudflare.com/ajax/libs/yadcf/0.9.3/"),
  script = "jquery.dataTables.yadcf.min.js",
  stylesheet = "jquery.dataTables.yadcf.min.css")
dtable$dependencies <- c(dtable$dependencies, list(dep))
dep <- htmltools::htmlDependency(
  "jquery-ui", "1.12.1",
  src = "www/shared/jqueryui/",
  script = "jquery-ui.js",
  stylesheet = "jquery-ui.css",
  package = "shiny")
dtable$dependencies <- c(dtable$dependencies, list(dep))
dep <- htmltools::htmlDependency(
  "moment", "2.27.0",
  c(href =  "https://cdnjs.cloudflare.com/ajax/libs/moment.js/2.27.0/"),
  script = "moment.min.js")
dtable$dependencies <- c(dtable$dependencies, list(dep))

dtable

Edit

To get the desired order:

library(DT)

js <- '
      yadcf.init(table, [
        {
          column_number : 2,
          column_data_type: "text",
          data: [
            {"label": "Montag", "value": "Montag"}, 
            {"label": "Dienstag", "value": "Dienstag"}, 
            {"label": "Mittwoch", "value": "Mittwoch"},
            {"label": "Donnerstag", "value": "Donnerstag"}, 
            {"label": "Freitag", "value": "Freitag"}, 
            {"label": "Samstag", "value": "Samstag"}, 
            {"label": "Sonntag", "value": "Sonntag"}
          ],
          //omit_default_label: true,
          filter_type: "select",
          select_type: "jquery-ui",
          text_data_delimiter: /,/
        }
      ]);
'

df <- data.frame(ID = 1:6,
                 Weekdays = c("Montag", "Dienstag,Mittwoch", "Mittwoch,Samstag",
                              "Donnerstag", "Montag,Freitag", "Samstag,Sonntag"))

dtable <- datatable(
  df, #filter = "top",
  callback = JS(js)
)

dep <- htmltools::htmlDependency(
  "yadcf", "0.9.3",
  c(href =  "https://cdnjs.cloudflare.com/ajax/libs/yadcf/0.9.3/"),
  script = "jquery.dataTables.yadcf.min.js",
  stylesheet = "jquery.dataTables.yadcf.min.css")
dtable$dependencies <- c(dtable$dependencies, list(dep))
dep <- htmltools::htmlDependency(
  "jquery-ui", "1.12.1",
  src = "www/shared/jqueryui/",
  script = "jquery-ui.js",
  stylesheet = "jquery-ui.css",
  package = "shiny")
dtable$dependencies <- c(dtable$dependencies, list(dep))
dep <- htmltools::htmlDependency(
  "moment", "2.27.0",
  c(href =  "https://cdnjs.cloudflare.com/ajax/libs/moment.js/2.27.0/"),
  script = "moment.min.js")
dtable$dependencies <- c(dtable$dependencies, list(dep))

dtable

Edit: nice multi select

If you want to have a nice multi select, you have to set the option select_type=select2 but you also have to include the select2 library.

library(DT)

js <- '
      yadcf.init(table, [
        {
          column_number : 2,
          column_data_type: "text",
          data: [
            {"label": "Montag", "value": "Montag"}, 
            {"label": "Dienstag", "value": "Dienstag"}, 
            {"label": "Mittwoch", "value": "Mittwoch"},
            {"label": "Donnerstag", "value": "Donnerstag"}, 
            {"label": "Freitag", "value": "Freitag"}, 
            {"label": "Samstag", "value": "Samstag"}, 
            {"label": "Sonntag", "value": "Sonntag"}
          ],
          //omit_default_label: true,
          filter_type: "multi_select",
          select_type: "select2",
          text_data_delimiter: /,/
        }
      ]);
'

df <- data.frame(ID = 1:6,
                 Weekdays = c("Montag", "Dienstag,Mittwoch", "Mittwoch,Samstag",
                              "Donnerstag", "Montag,Freitag", "Samstag,Sonntag"))

dtable <- datatable(
  df, #filter = "top",
  callback = JS(js)
)

dep <- htmltools::htmlDependency(
  "yadcf", "0.9.3",
  c(href =  "https://cdnjs.cloudflare.com/ajax/libs/yadcf/0.9.3/"),
  script = "jquery.dataTables.yadcf.min.js",
  stylesheet = "jquery.dataTables.yadcf.min.css")
dtable$dependencies <- c(dtable$dependencies, list(dep))
dep <- htmltools::htmlDependency(
  "jquery-ui", "1.12.1",
  src = "www/shared/jqueryui/",
  script = "jquery-ui.js",
  stylesheet = "jquery-ui.css",
  package = "shiny")
dep <- htmltools::htmlDependency(
  "select2_js", "4.0.13",
  c(href =  "https://cdnjs.cloudflare.com/ajax/libs/select2/4.0.13/"),
  script = "js/select2.min.js",
  stylesheet = "css/select2.min.css")
dtable$dependencies <- c(dtable$dependencies, list(dep))
dep <- htmltools::htmlDependency(
  "moment", "2.27.0",
  c(href =  "https://cdnjs.cloudflare.com/ajax/libs/moment.js/2.27.0/"),
  script = "moment.min.js")
dtable$dependencies <- c(dtable$dependencies, list(dep))

dtable

Edit: in Shiny

library(DT)
library(shiny)

js <- '
      yadcf.init(table, [
        {
          column_number : 2,
          column_data_type: "text",
          data: [
            {"label": "Montag", "value": "Montag"}, 
            {"label": "Dienstag", "value": "Dienstag"}, 
            {"label": "Mittwoch", "value": "Mittwoch"},
            {"label": "Donnerstag", "value": "Donnerstag"}, 
            {"label": "Freitag", "value": "Freitag"}, 
            {"label": "Samstag", "value": "Samstag"}, 
            {"label": "Sonntag", "value": "Sonntag"}
          ],
          //omit_default_label: true,
          filter_type: "multi_select",
          select_type: "select2",
          text_data_delimiter: /,/
        }
      ]);
'

df <- data.frame(ID = 1:6,
                 Weekdays = c("Montag", "Dienstag,Mittwoch", "Mittwoch,Samstag",
                              "Donnerstag", "Montag,Freitag", "Samstag,Sonntag"))

dtable <- datatable(
  df, #filter = "top",
  callback = JS(js)
)

ui <- fluidPage(
  tagList(
    htmltools::htmlDependency(
      "yadcf", "0.9.3",
      c(href =  "https://cdnjs.cloudflare.com/ajax/libs/yadcf/0.9.3/"),
      script = "jquery.dataTables.yadcf.min.js",
      stylesheet = "jquery.dataTables.yadcf.min.css"),
    htmltools::htmlDependency(
      "select2_js", "4.0.13",
      c(href =  "https://cdnjs.cloudflare.com/ajax/libs/select2/4.0.13/"),
      script = "js/select2.min.js",
      stylesheet = "css/select2.min.css"),
    htmltools::htmlDependency(
      "moment", "2.27.0",
      c(href =  "https://cdnjs.cloudflare.com/ajax/libs/moment.js/2.27.0/"),
      script = "moment.min.js")
  ),
  DTOutput("dtable")
)

server <- function(input, output, session) {
  output[["dtable"]] <- renderDT({
    dtable
  }, server = FALSE)
}

shinyApp(ui, server)