使用 R 中的 DataTables DT 制作一个更美观的下拉过滤器标签

Question

我正在尝试为闪亮的仪表板制作一个数据表，该仪表板将在列上有一个下拉过滤器。我实际上可以使用它，但外观我称之为低于标准。

这是我的简单例子

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

当我激活下拉菜单时，过滤器文本输入看起来不错：

然而，当我点击离开时，它看起来并不那么好：

有没有什么方法可以保留那个漂亮的 A 和一个气泡中的 x（抱歉，我确信有一个更好的术语），或者至少去掉括号和引号？我知道，如果列值是字符而不是因子，我可以获得更好看的文本输入，但是它们我失去了下拉功能（与这个问题Factor dropdown filter in DT::datatable in闪亮仪表板不起作用），这我需要。

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

我对像这篇文章Edit datatable in Shiny with dropdown select for Factor Variables 中的单元格下拉菜单感到满意，但我需要过滤表格，而不是编辑它。

版本信息：

R版本3.5.3

DT_0.20

Answer 1

我知道该怎么做，但对于页脚中的下拉菜单，我不知道如何将它们放在顶部。该代码使用 JavaScript 库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)

编辑

要将过滤器放在顶部：

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)