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

Question

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

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

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