R Shiny Selectedinput Inside Renderdatatable Cells

R Shiny selectedInput inside renderDataTable cells

Very similar to this: adding a column with TRUE/FALSE and showing that as a checkbox

library(shiny)
library(DT) 
runApp(list(
  ui = basicPage(
    h2('The mtcars data'),
    DT::dataTableOutput('mytable'),
    h2("Selected"),
    tableOutput("checked")
  ),

  server = function(input, output) {
    # helper function for making checkbox
    shinyInput = function(FUN, len, id, ...) { 
      inputs = character(len) 
      for (i in seq_len(len)) { 
        inputs[i] = as.character(FUN(paste0(id, i), label = NULL, ...)) 
      } 
      inputs 
    } 
    # datatable with checkbox
    output$mytable = DT::renderDataTable({
      data.frame(mtcars,Rating=shinyInput(selectInput,nrow(mtcars),"selecter_",
                                            choices=1:5, width="60px"))
    }, selection='none',server = FALSE, escape = FALSE, options = list( 
      paging=TRUE,
      preDrawCallback = JS('function() { 
Shiny.unbindAll(this.api().table().node()); }'), 
      drawCallback = JS('function() { 
Shiny.bindAll(this.api().table().node()); } ') 
    ) )
    # helper function for reading checkbox
    shinyValue = function(id, len) { 
      unlist(lapply(seq_len(len), function(i) { 
        value = input[[paste0(id, i)]] 
        if (is.null(value)) NA else value 
      })) 
    } 
    # output read checkboxes
    output$checked <- renderTable({
      data.frame(selected=shinyValue("selecter_",nrow(mtcars)))
    })
  }
))

Note that if you rerender the table, the inputs won't work unless you add some extra code to unbind.

edit:

Let's say the data in the table is reactive so it changes, and the table rerenders. You will need to explicitely unbind as per @yihui here: https://groups.google.com/forum/#!msg/shiny-discuss/ZUMBGGl1sss/zfcG9c6MBAAJ

So you need to add in the UI:

tags$script(HTML("Shiny.addCustomMessageHandler('unbind-DT', function(id) {
          Shiny.unbindAll($('#'+id).find('table').DataTable().table().node());
        })"))

And then in the Server you trigger the function whenever you rerender the datatable with:

session$sendCustomMessage('unbind-DT', 'mytable')

The colnames parameter is a vector of column names so when you specify a length one vector of FALSE it gives you a table with one column named FALSE. I am not sure of a straightforward way of removing column names from datatables. That would be a good SO question on its own.

Combining selectInput and DT::datatable editing in Shiny

A few modifications to achieve expected behavior :

• dtProxy should be created only once at server launch
• observeEvent(input$dt_cell_edit,...) should be independent of observeEvent(input$s_internal_idNew,...)
• df_showed() should also be updated, as df()

library(tidyverse); library(DT); library(shiny)

df <- data.frame(internal_idNew=c(1, 2, 3, 4), col_1=c("this", "is", "a", "column"))

ui <- fluidPage(
  #filter df
  selectInput("s_internal_idNew", "Record id (new)", choices=c(1:nrow(df))),
  #dt output
  dataTableOutput("dt")
)

server <- function(input, output) {
  #reactive df
  df <- reactiveVal({df})
  #reactive df filtered
  df_showed <- reactiveVal({})
  
  #create proxy dt once
  dt_proxy <- dataTableProxy("dt")
  
  
  observeEvent(input$s_internal_idNew, {
    #filter a row matching the internal id
    df_showed(df() %>% filter(internal_idNew==input$s_internal_idNew))
    #render dt
    output$dt <- DT::renderDataTable(df_showed(), editable=list(target = "cell", disable = list(columns =c(0))), options=list(dom = 't', bSort=FALSE, pageLength=1), rownames = FALSE, selection = "none")

  })

    #edit dt - separate from previous reactive
    observeEvent(input$dt_cell_edit, {
      this <- df()
      showed <- df_showed()
      
      #extract edited value to edit df
      col_name <- showed %>% names() %>% .[input$dt_cell_edit$col+1]
      row_name <- input$s_internal_idNew %>% as.numeric()
      value_name <- coerceValue(input$dt_cell_edit$value, showed[row_name, col_name])
      
      #store edited values in reactive df
      this[row_name, col_name] <- value_name
      df(this)
      df_showed(this[row_name, ]) # Also updated
      #replace data in datatable
      replaceData(dt_proxy, df_showed(), resetPaging = TRUE, rownames = FALSE)
    })
  
}

shinyApp(ui = ui, server = server)

How to add selectInput to each row of a datatable in R Shiny and then read it

You need to bind the inputs so their values are available in Shiny.

This is actually similar to a question I asked a while back. For more information, here's the link to the answer I was given.

Shiny widgets in DT Table

library(data.table)
library(htmltools)
library(shiny)
library(shinydashboard)
library(DT)

dbHeader <- dashboardHeader(title = "")

# Define UI for application that draws a map
ui <- fluidPage(

  dashboardPage(
    title = "Interface",
    dbHeader,
    dashboardSidebar(
      fluidRow(column(12,dateInput("whichDay", label = h4("Date"), language = "fr", value = NULL))),
      fluidRow(column(12,actionButton("submit","Sauver")))
    ),
    dashboardBody(
      dataTableOutput('myTableOutput')
    )
  )
)

# Define server logic required
server <- function(session, input, output) {

  ## Table de répartition
  repTable <<- data.table(Blocs=1:3, Véhicules=1:3 )
  output$myTableOutput <- DT::renderDataTable({repTable},escape=FALSE,options = list(pageLength = 100, info = FALSE, dom="t",
                                                                                     preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
                                                                                     drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')))

  observe({
    vehicles <- vector(mode = "character", length = 0)
    for(i in 1:3){
      vehicles[i] <- as.character(selectInput(inputId=paste0("row_select_", i), label=NULL, choices=c("","a","b")))
    }
    ## Add to table
    repTable <<- data.table(Blocs=1:3, Véhicules = vehicles )
    proxy <- dataTableProxy("myTableOutput")
    replaceData(proxy,repTable)
  }
  )

  observeEvent(input$submit,{
    ## ???? How to retrieve the values from Véhicules?
    for(i in 1:3) {
      print(input[[paste0("row_select_", i)]])
    }
  })
}

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

SelectInput (inside Table Cell) does not read input$ID value after any change in the inputs it is based on

As stated in the comment, one way to resolve your issue is to create a new ID each time a user selects a new class_col. We can attach the class and a counter to define the new inputId. Please note that the table is updated only after you click the actionButton. Try this

master_table <- data.frame("class_col" = c("A", "A", "A", "A", "A", "B", "B", "B", "B", "B", "C", "C", "C", "C", "C"), 
                           "all_student"=c("CA1", "CA2", "CA3", "CA4", "CA5", "CB1", "CB2", "CB3", "CB4", "CB5", "CC1", "CC2", "CC3", "CC4", "CC5"))

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

ui <- fluidPage(fluidRow(
  selectInput("class_input", label = "Class", choices= sort(c("Select Class"='', unique(master_table$class_col))), selected=NULL),
  shinyjs::hidden(tags$div(id="alert", tags$h5("* Please Select Class ", style = "color:red"))),
  actionBttn(inputId = 'go', label='Go!'),
  shinyjs::hidden(tags$div(id='hidden_table', DT::dataTableOutput('student_select_table'))),
  textOutput("text_output_for_selected_Student_at_Row1"))
)

server <- function(input, output, session) {
  
  mod = reactiveValues(student_reactive=0, df=NULL)
  cntr <- reactiveValues(value=0)
  
  k <- eventReactive(input$class_input, {
    cntr$value <- cntr$value+1
    return(cntr$value) })
  observe({print(k())})
  
  observeEvent(input$class_input, {
    student_table = data.table('student_input_col' = 1:5)
    #req(k())
    for (i in 1:nrow(student_table)){
      student_table$student_input_col[i] <- as.character(selectInput(inputId = paste0("student_row", i, input$class_input,k()),
                                                                     label=NULL,
                                                                     choices = sort(c("Select Student"='', master_table$all_student[master_table$class_col == input$class_input]))))
    
    }
    mod$student_reactive <- student_table
      
  }, ignoreNULL = TRUE)
  
  
  observeEvent(input$go, {
    
    if(nchar(input$class_input)<1){
      shinyjs::showElement("alert")
      shinyjs::hideElement("hidden_table")
    } else {
      shinyjs::hideElement("alert")
      shinyjs::showElement("hidden_table")
      
      mod$df <- mod$student_reactive
    }
  })
  
  output$student_select_table <- DT::renderDataTable({
    datatable(mod$df,
              class= "cell-border",
              rownames = FALSE, width = "80%",escape = FALSE,
              selection = "single",
              options = list(dom='t', paging=FALSE, ordering=FALSE, info=FALSE,
                             rowCallback = JS("function(r,d) {$(r).attr('height', '40px')}"),
                             preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
                             drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } '))
    )
  })
  
  output$text_output_for_selected_Student_at_Row1 <- renderText(paste0("Text for Student at Row1 = ", input[[paste0("student_row1",input$class_input,k())]]))
  
}

runApp(shinyApp(ui = ui, server = server))

R Shiny - Unable to display data table in mainpanel based on selectInput user selection

I think you're mixing things up here, you shouldn't be putting renderDataTable into reactive, this should work:

library(shiny)

table789 <- mtcars
table456 <- iris
table123 <- mtcars
table789$column1 <- sample(c("123","456"),nrow(table789),replace = T)

ui <- fluidPage(
    
    sidebarPanel(selectInput("selection", "Select", choices = unique(table789$column1), selected = "xyz")),
    
    mainPanel(
        tabsetPanel(
            tabPanel("select", 
                     DT::dataTableOutput("outputtable")
            )
        )
    )
)

server = function(input, output, session) {
    
    
    data <- eventReactive(input$selection,{
        if(input$selection == "123"){
            return (table123)
        }
        table456
    })
    
    output$outputtable <- DT::renderDataTable(
        data()
    )
    
}

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

Shiny selectInput in DT inside module

I've since found an error in my code: when assigning inputs above one needs to wrap the namespace around their IDs as always when assigning inputs in modules: session$ns(paste0("sel", i)). Thought I had done that originally, but apparently not. Anyway, working solution below in case helpful.

library(shiny)
library(DT)

module_ui = function(id, label) {

  ns = NS(id)

  tagList(
    DT::dataTableOutput(ns('foo')),
    verbatimTextOutput(ns('sel'))
  )

}

module_server = function(input, output, session){

  ns = session$ns

  data <- head(iris, 5)

  for (i in 1:nrow(data)) {
    data$species_selector[i] <- as.character(selectInput(ns(paste0("sel", i)), "", choices = unique(iris$Species), width = "100px"))
  }

  output$foo = DT::renderDataTable(
    data, escape = FALSE, selection = 'none', server = FALSE,
    options = list(dom = 't', paging = FALSE, ordering = FALSE),
    callback = JS("table.rows().every(function(i, tab, row) {
        var $this = $(this.node());
        $this.attr('id', this.data()[0]);
        $this.addClass('shiny-input-container');
      });
      Shiny.unbindAll(table.table().node());
      Shiny.bindAll(table.table().node());")
  )

  output$sel = renderPrint({
    str(sapply(1:nrow(data), function(i) input[[paste0("sel", i)]]))
  })
}

ui <- fluidPage(
  title = 'Selectinput column in a table',
  h3("Source:", tags$a("Yihui Xie", href = "https://yihui.shinyapps.io/DT-radio/")),
  module_ui("tabl")
)

server <- function(input, output, session) {
  callModule(module_server, "tabl")
}

shinyApp(ui, server)

---

Related Topics