Make a nicer looking dropdown filter label with DataTables DT in R

Question

I'm trying to make a datatable for a shiny dashboard that will have a dropdown filter on a column. I actually have it working, but the appearance is what I'd call subpar.

Here is my simple example

library(DT)
mytable <- data.frame(Col1 = as.factor(LETTERS[1:3]))
datatable(mytable, filter = "top")

When I have the dropdown active, the filter text input looks nice:

However, when I click away, it does not look as nice:

Is there any way to keep that nice looking A with an x in a bubble (sorry I'm sure there's a better term for that), or at least get rid of the bracket and quotation marks? I know that if the column values are characters rather than factors, I can get a nicer looking text input, but them I lose the dropdown functionality (related to this question Factor dropdown filter in DT::datatable in shiny dashboards not working), which I need.

mytable <- data.frame(Col1 = LETTERS[1:3], stringsAsFactors = FALSE)
datatable(mytable, filter = "top")

I'd be happy with a cell dropdown like the one in this post Edit datatable in Shiny with dropdown selection for factor variables, but I need to filter the table, not edit it.

Version info:

R version 3.5.3

DT_0.20

Answer 1

This is not a helpful answer but I wanted to add - I've noticed in other Shiny Dashboards where I use "DataTableOutput" it renders in the desired way. Doesn't seem like that solves your problem for this use case, though it helped me out after some frustration trying to solve this proto-typing with the Rstudio viewer first.

Answer 2

I know how to do that but with the dropdowns in the footer, I don't know how to put them at the top. The code uses the JavaScript library select2.

library(shiny)
library(DT)

dat <- iris

sketch <- htmltools::tags$table(
  tableHeader(c("",names(dat))),
  tableFooter(rep("", 1+ncol(dat)))
)

js <- c(
  "function(){", 
  "  this.api().columns().every(function(i){",
  "    var column = this;",
  "    var select = $('<select multiple=\"multiple\"><option value=\"\"></option></select>')",
  "      .appendTo( $(column.footer()).empty() )", 
  "      .on('change', function(){",
  "        var vals = $('option:selected', this).map(function(index,element){",
  "          return $.fn.dataTable.util.escapeRegex($(element).val());",
  "        }).toArray().join('|');",
  "        column.search(vals.length > 0 ? '^('+vals+')$' : '', true, false).draw();",
  "      });",
  "    var data = column.data();",
  "    if(i == 0){",
  "      data.each(function(d, j){",
  "        select.append('<option value=\"'+d+'\">'+d+'</option>');",
  "      });",
  "    }else{",
  "      data.unique().sort().each(function(d, j){",
  "        select.append('<option value=\"'+d+'\">'+d+'</option>');",
  "      });",
  "    }",
  "    select.select2({width: '100%', closeOnSelect: false});",
  "  });",
  "}")


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("dtable")
)

server <- function(input, output, session){
  output[["dtable"]] <- renderDT({
    datatable(
      dat, container=sketch, 
      options = list(
        initComplete = JS(js),
        columnDefs = list(
          list(targets = "_all", className = "dt-center")
        )
      )
    )
  }, server = FALSE)
}

shinyApp(ui, server)

---

Edit

To have the filters at the top:

library(shiny)
library(DT)
library(htmltools)

dat <- iris

sketch <- tags$table(
  tags$thead(
    tags$tr(
      tags$th(),
      lapply(names(dat), tags$th)
    ),
    tags$tr(
      tags$th(id = "th0"),
      tags$th(id = "th1"),
      tags$th(id = "th2"),
      tags$th(id = "th3"),
      tags$th(id = "th4"),
      tags$th(id = "th5")
    )
  )
)

js <- c(
  "function(){", 
  "  this.api().columns().every(function(i){",
  "    var column = this;",
  "    var select = $('<select multiple=\"multiple\"><option value=\"\"></option></select>')",
  "      .appendTo( $('#th'+i).empty() )", 
  "      .on('change', function(){",
  "        var vals = $('option:selected', this).map(function(index,element){",
  "          return $.fn.dataTable.util.escapeRegex($(element).val());",
  "        }).toArray().join('|');",
  "        column.search(vals.length > 0 ? '^('+vals+')$' : '', true, false).draw();",
  "      });",
  "    var data = column.data();",
  "    if(i == 0){",
  "      data.each(function(d, j){",
  "        select.append('<option value=\"'+d+'\">'+d+'</option>');",
  "      });",
  "    }else{",
  "      data.unique().sort().each(function(d, j){",
  "        select.append('<option value=\"'+d+'\">'+d+'</option>');",
  "      });",
  "    }",
  "    select.select2({width: '100%', closeOnSelect: false});",
  "  });",
  "}")


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("dtable")
)

server <- function(input, output, session){
  output[["dtable"]] <- renderDT({
    datatable(
      dat, container=sketch, 
      options = list(
        orderCellsTop = TRUE,
        initComplete = JS(js),
        columnDefs = list(
          list(targets = "_all", className = "dt-center")
        )
      )
    )
  }, server = FALSE)
}

shinyApp(ui, server)