更新数据表头而不刷新整个应用程序（R，Shiny） dataTableProxy()

Posted 2023-03-24

【中文标题】更新数据表头而不刷新整个应用程序（R，Shiny） dataTableProxy()

【英文标题】：Update datatable header without refreshing the whole application (R, Shiny) dataTableProxy()

【发布时间】：2021-10-21 14:10:13

【问题描述】：

我正在尝试制作一个闪亮的应用程序。

(1) 我想更新数据表而不刷新整个应用程序。 >>> 我用isolate() 和dataTableProxy() 解决它。

(2) 我想在不刷新整个应用程序的情况下更新表头（列名），例如（如果用户在 selectInput 中选择 2020。表中的新列名应该更新为 year: 2020 而不刷新整个应用程序)。

我该怎么做？

library(DT)
library(data.table)
library(dplyr)
library(shiny)

ui <- fluidPage(
  selectInput(inputId = 'choice', label = 'choice', choices = c('A', 'B'), selected = 'A'),
  selectInput(inputId = 'country', label = 'country', choices = c('UK', 'USA', 'CANADA'), selected = 'UK'), 
  selectInput(inputId = 'year', label = 'year', choices = c(2020, 2021), selected = 2020),
  uiOutput(outputId = "table")
)

server <- function(input, output, session) 
  data_a <- data.frame(year = c(rep(2020,6), rep(2021,6)),
                       country = c('UK', 'UK', 'USA', 'USA', 'CANADA','CANADA'),
                       type_a = c('AA', 'BB'),
                       num = sample(10:22, 12))
  
  dt_a <- reactive(
    if (input$choice == 'A')
      return(data_a %>% filter(year == input$year & country == input$country))
    
  )
  
  output$rtable_a <- DT::renderDataTable(
    if (input$choice == 'A')
      DT <- DT::datatable(isolate(dt_a()), 
                          rownames = FALSE,
                          options = list(processing = FALSE),
                          colnames = c('YEAR', 'COUNTRY', paste('year_a:', input$year), 'NUMBER')
                          )
      return(DT)
    
  )
  
  proxy_a <- DT::dataTableProxy('rtable_a') 
  observe(
    DT::replaceData(proxy_a, dt_a(), rownames = FALSE)
  )
  
  output$table <- renderUI(
    if (input$choice == 'A')
      return(DT::dataTableOutput("rtable_a", width = '75%'))
    
  )


shinyApp(ui, server)

【问题讨论】：

@RonakShah 我修改了数据。不再有此错误：if 中的错误：参数长度为零

【参考方案1】：

这是一个使用 javascript 库 jQuery contextMenu 的解决方案。右键单击列标题并选择年份。

library(shiny)
library(DT)

callback <- c(
  "var choices = 1: '2020', 2: '2021';",
  "var id = $(table.table().node()).closest('.datatables').attr('id');",
  "$.contextMenu(",
  "  selector: '#' + id + ' th:eq(3)',", 
  "  trigger: 'right',",
  "  autoHide: true,",
  "  items: ",
  "    select: ",
  "      name: 'Select year:',", 
  "      type: 'select',", 
  "      options: choices,", 
  "      selected: '1'",
  "    ",
  "  ,",
  "  events: ",
  "    hide: function(opt)",
  "      var $this = this;",
  "      var i = $.contextMenu.getInputValues(opt, $this.data()).select;",
  "      var year = choices[i];",
  "      Shiny.setInputValue('year', year);",
  "      var text = 'year_a: ' + year;",
  "      var $th = opt.$trigger;",
  "      $th.text(text);",
  "    ",
  "  ",
  ");" 
)


data_a <- data.frame(
  "YEAR"         = c(rep(2020,6), rep(2021,6)),
  "COUNTRY"      = c('UK', 'UK', 'USA', 'USA', 'CANADA','CANADA'),
  "year_a: 2020" = c('AA', 'BB'),
  "NUMBER"       = sample(10:22, 12),
  check.names = FALSE
)

ui <- fluidPage(
  tags$head(
    tags$link(rel = "stylesheet", href = "https://cdnjs.cloudflare.com/ajax/libs/jquery-contextmenu/2.9.2/jquery.contextMenu.min.css"),
    tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/jquery-contextmenu/2.9.2/jquery.contextMenu.min.js")
  ),
  DTOutput("dtable")
)

server <- function(input, output)
  output[["dtable"]] <- renderDT(
    datatable(data_a, callback = JS(callback))
  , server = FALSE)
  
  observe( # selected year
    print(input[["year"]])
  )


shinyApp(ui, server)

---

编辑

过滤：

library(shiny)
library(DT)

callback <- c(
  "Shiny.setInputValue('year', '2020');",
  "var choices = 1: '2020', 2: '2021';",
  "var id = $(table.table().node()).closest('.datatables').attr('id');",
  "$.contextMenu(",
  "  selector: '#' + id + ' th:eq(3)',", 
  "  trigger: 'right',",
  "  autoHide: true,",
  "  items: ",
  "    select: ",
  "      name: 'Select year:',", 
  "      type: 'select',", 
  "      options: choices,", 
  "      selected: '1'",
  "    ",
  "  ,",
  "  events: ",
  "    hide: function(opt)",
  "      var $this = this;",
  "      var i = $.contextMenu.getInputValues(opt, $this.data()).select;",
  "      var year = choices[i];",
  "      Shiny.setInputValue('year', year);",
  "      var text = 'year_a: ' + year;",
  "      var $th = opt.$trigger;",
  "      $th.text(text);",
  "    ",
  "  ",
  ");" 
)


data_a <- data.frame(
  "YEAR"         = c(rep(2020,6), rep(2021,6)),
  "COUNTRY"      = c('UK', 'UK', 'USA', 'USA', 'CANADA','CANADA'),
  "year_a: 2020" = c('AA', 'BB'),
  "NUMBER"       = sample(10:22, 12),
  check.names = FALSE
)

ui <- fluidPage(
  tags$head(
    tags$link(rel = "stylesheet", href = "https://cdnjs.cloudflare.com/ajax/libs/jquery-contextmenu/2.9.2/jquery.contextMenu.min.css"),
    tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/jquery-contextmenu/2.9.2/jquery.contextMenu.min.js")
  ),
  DTOutput("dtable")
)

server <- function(input, output)
  output[["dtable"]] <- renderDT(
    datatable(data_a, callback = JS(callback))
  , server = TRUE)
 
  proxy <- dataTableProxy("dtable")
  
  observeEvent(input[["year"]],  
    replaceData(proxy, subset(data_a, YEAR == input[["year"]]))
  )


shinyApp(ui, server)

【讨论】：

嘿，谢谢你的回答，但我真的希望这个 colname 改变取决于选择输入而不刷新整个应用程序。我希望它与使用数据表代理和隔离的行完全一样

@GreenY 这正是我的代码所做的。使用此方法选择年份时，不会重新渲染表格。

对不起，我们错过了理解 ^_^。我不希望用户点击 colname 来更改年份。当用户在 2020 上过滤时，我希望它直接来自过滤器 SelectInput，此列必须是 year:2020 并且整个表都用 2020 过滤，并且只保留与过滤器匹配的行

@GreenY 好的，我想我现在明白了。我想我有一个解决方案，但仍然使用“我的”选择输入，当单击列名时会出现该输入。恕我直言，没有其他方法，因为代理不允许更改列标题。

好的。非常感谢