In R using DT shiny datatable move the column selection to the top of the dataframe

Question

I would like to move the column selection ability to be at the top of the dataframe instead of the bottom. I have no real need for the sorting ability that the current header provides so that can either get moved to the bottom or removed entirely. Would this be possible?

library(shiny)
library(DT)

mapping_list_headers <- mtcars

# Define UI
ui <- fluidPage(
  titlePanel("Remove Extra Headers and Columns from Dataframe"),
  mainPanel(
    helpText("Select the rows/columns to remove by clicking on them."),
    actionButton("removeRows", "Remove Selected Rows"),
    actionButton("removeCols", "Remove Selected Columns"),
    actionButton("closeApp", "Close App and Session"),
    hr(),
    fluidRow(
      column(12, DT::dataTableOutput("data_table"))
    )
  )
)


# Define server logic
server <- function(input, output, session) {
  # Sample dataframe
  data <- reactiveVal(mapping_list_headers)
  
  # Display dataframe in table format
  output$data_table <- renderDataTable({
    datatable(data(),selection = list(mode = 'multiple', target = 'row+column'))
  })
  
  # Remove selected rows
  observeEvent(input$removeRows, {
    if (!is.null(input$data_table_rows_selected)) {
      print(str(input))
      print((input))
      selected_rows <- input$data_table_rows_selected
      print(selected_rows)
      df_data <- data()
      df_data <- df_data[-selected_rows, , drop = FALSE]
      data(df_data)
    }
  })
  
  # Remove selected columns
  observeEvent(input$removeCols, {
    if (!is.null(input$data_table_columns_selected)) {
      selected_cols <- input$data_table_columns_selected
      print(selected_cols)
      df_data <- data()
      df_data <- df_data[, -selected_cols, drop = FALSE]
      data(df_data)
    }
  })
  
  # Close the app and session
  observeEvent(input$closeApp, {
    data_out <<- data()
    session$close()
    stopApp()
  })
}

# Run the application
shinyApp(ui = ui, server = server)

Solution from @Stéphane Laurent implemented with removal of col/rows:

library(shiny)
library(DT)

callback <- c(
  "table.on('click', 'thead th', function() {",
  "  Shiny.setInputValue('clickedCol', $(this).index(), {priority: 'event'});",
  "});"
)

ui <- fluidPage(
  br(),
  actionButton("removeSelectedRows", "Remove Selected Rows"),
  actionButton("removeSelectedColumns", "Remove Selected Columns"),
  br(),
  DTOutput("dtable")
)

server <- function(input, output, session) {
  
  # Make a copy of the iris dataset
  data <- reactiveVal(iris)
  
  output$dtable <- renderDT({
    datatable(
      data(),
      selection = list(mode = 'multiple', target = 'row+column'),
      callback = JS(callback),
      options = list(
        ordering = FALSE # remove the sorting arrows
      )
    )
  })
  
  proxy <- dataTableProxy("dtable")
  
  selectedColumns <- reactiveVal()
  
  observeEvent(input$dtable_columns_selected, {
    selectedColumns(input$dtable_columns_selected)
  }, ignoreNULL = FALSE)
  
  observeEvent(input$clickedCol, {
    j <- input$clickedCol
    selected_columns <- selectedColumns()
    if(j %in% selected_columns) {
      sel <- setdiff(selected_columns, j)
    } else {
      sel <- c(selected_columns, j)
    }
    selectColumns(proxy, sel)
  })
  
  observeEvent(input$removeSelectedRows, {
    removeRows <- input$dtable_rows_selected
    if (!is.null(removeRows) && length(removeRows) > 0) {
      data(data()[-removeRows, ])
    }
  })
  
  observeEvent(input$removeSelectedColumns, {
    removeCols <- selectedColumns()
    if (!is.null(removeCols) && length(removeCols) > 0) {
      data(data()[, -removeCols, drop = FALSE])
    }
  })
  
}

shinyApp(ui, server)

Answer 1

Here is a way. Thanks to the JavaScript callback, when you click on a column header, the index of this column is attributed to the Shiny value input$clickedCol. Then, observing this Shiny value in the server, the selected columns are updated thanks to the DT function selectColumns. You can still select a column by clicking the footer.

library(shiny)
library(DT)


callback <- c(
  "table.on('click', 'thead th', function() {",
  "  Shiny.setInputValue('clickedCol', $(this).index(), {priority: 'event'});",
  "});"
)

ui <- fluidPage(
  br(),
  DTOutput("dtable")
)

server <- function(input, output, session) {
  
  output$dtable <- renderDT({
    datatable(
      iris,
      selection = list(mode = 'multiple', target = 'row+column'),
      callback = JS(callback),
      options = list(
        ordering = FALSE # remove the sorting arrows
      )
    )
  })
  
  proxy <- dataTableProxy("dtable")
  
  selectedColumns <- reactiveVal()
  
  observeEvent(input$dtable_columns_selected, {
    selectedColumns(input$dtable_columns_selected)
  }, ignoreNULL = FALSE)
  
  observe({
    print(input$dtable_columns_selected)
  })
  
  observeEvent(input$clickedCol, {
    j <- input$clickedCol
    selected_columns <- selectedColumns()
    if(j %in% selected_columns) {
      sel <- setdiff(selected_columns, j)
    } else {
      sel <- c(selected_columns, j)
    }
    selectColumns(proxy, sel)
  })
  
}

shinyApp(ui, server)