Update datatable header without refreshing the whole application (R, Shiny) dataTableProxy() - r

Question

I am trying to make a Shiny app.
(1) I want update data table without refreshing the whole application.
>>> I resolve it with isolate({}) and dataTableProxy().
(2) I want update the header (column name) without refreshing the whole application, for example (If the user choose in the selectInput 2020. The new colname in the table should update to year: 2020 without refreshing the whole application).
How can I do that?
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

Here is a solution using the JavaScript library jQuery contextMenu. Right-click on the column header and select the year.
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)
EDIT
With filtering:
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)