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

user_11600565 0
Viewed 711

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:

enter image description here

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

enter image description here

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

enter image description here

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

dt datatables r
1 Answers

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)

enter image description here

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)

enter image description here

user_11001070
Related