r - Embed column with mixed numericInput and selectInput in DT: reactive table

Question

The present question is related to my previous question, regarding embedding a column with mixed numericInput and selectInput in DT with R.

The solution provided there works fine, but there are problems when I use a reactive table.

In more detail, I have a main table (Project table). Upon selecting a row, a second table is filtered producing a reactive table (sub-project table), where the column with numericInput and selectInput is embedded. It works ok, but when I select a new row in the Project table, the embedded column in the sub-project table is not updated.

I suspect that the problem is related to column binding, performed with the JS code, but since I have no idea about JS, it is impossible for me to find out.

Thank you for your time!

Here is a sample code:

library(shiny)
library(shinydashboard)

library(DT)
library(tidyverse)

# data
df=structure(list(Project = c("P1", "P1", "P2", "P2", "P1", "P1", 
"P2", "P2", "P1", "P1", "P2", "P2", "P1", "P1", "P2", "P1"), 
    sub.proj = c("sp1", "sp2", "sp3", "sp4", "sp1", "sp2", "sp3", 
    "sp4", "sp1", "sp2", "sp3", "sp4", "sp1", "sp2", "sp4", "sp1"
    ), Param.Type = c("SimCat", "SimCat", "SimCat", "SimCat", 
    "SimCat", "SimCat", "SimCat", "SimCat", "SimNum", "SimNum", 
    "SimNum", "SimNum", "SimNum", "SimNum", "SimNum", "SimNum"
    ), PARAM = c("v1", "v1", "v1", "v1", "v2", "v2", "v2", "v2", 
    "v3", "v3", "v3", "v3", "v4", "v4", "v4", "v5"), measurement = c("v11", 
    "v12", "v13", "v14", "v21", "v22", "v23", "v24", "1", "2", 
    "3", "4", "11", "12", "13", "100")), row.names = c(NA, -16L
), class = c("tbl_df", "tbl", "data.frame"))

# Prject table
df1=df %>% select("Project" , "sub.proj" ) %>% unique()

# sub-proj table
df2=df 

# params table : gives choices for selectInput for categorical PARAM
aa=df %>% select("PARAM", "measurement" ,"Param.Type" ) %>% unique() %>% filter(PARAM %in% c("v1","v2")) %>% rename(choice.val=measurement, Param.Name=PARAM)




ui <- dashboardPage(
  dashboardHeader(title = 'Dashboard'),
  dashboardSidebar(),
  
  dashboardBody(
    
    tabsetPanel(
      tabPanel('Triplets', 
               fluidRow(
                 
                 hr(),
                 column(12, 
                        dataTableOutput('project_table'), 
                        actionButton("go", "TEST"),
                        verbatimTextOutput('sel'),
                        dataTableOutput('subproject_table'),
                        
                        dataTableOutput('test_table'))
                 
                 
               )
      )
    )
  )
)


# SERVER -----------------------------------


server <- function(input, output) { 
   
 
  
  output$project_table <- renderDataTable(df1, options = list(pageLength = 10))
  
  
  vars.long.sel.df <- reactive({
    
    
    
    s=input$project_table_rows_selected
    
    print(s)
    
    project <- unique(df1[s,c("Project")])
    vars.long.sel=df2 %>% filter(Project%in%project)  %>% mutate(test.val=NA) %>% rowid_to_column("row")
    
    
    for (i in 1:nrow(vars.long.sel)) {
      
      
      if (vars.long.sel$Param.Type[i]=="SimCat") {
        
        
        vars.long.sel$test.val[i] <- as.character(selectInput(paste0("sel", vars.long.sel$row[i]), "", choices =aa$choice.val[aa$Param.Name==vars.long.sel$PARAM[i]],selected = vars.long.sel$measurement[i], width = "100px"))
      } else {
        vars.long.sel$test.val[i] <- as.character(numericInput(paste0("sel",vars.long.sel$row[i]), "", value=as.numeric(vars.long.sel$measurement[i]), width = "100px"))
      }
    }
    
    vars.long.sel
    
        
  })
  
    
  
  output$subproject_table <- DT::renderDataTable({
    
    req(input$project_table_rows_selected)
    vars.long.sel.df()
    
    
  },
  escape = FALSE, selection = 'none', server = F,
  options = list( dom = 'Bfrtip', paging = FALSE, ordering = FALSE, buttons = c( 'excel')), extensions = 'Buttons'
  ,
  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());")
  )
  
  
  
  #   # TEST btn --------------------------
  
  output$sel = renderPrint({
    str(sapply(1:nrow(vars.long.sel.df()), function(i) input[[paste0("sel", i)]]))
  })
  
  
  
  
}

shinyApp(ui, server)

question from:https://stackoverflow.com/questions/65849337/embed-column-with-mixed-numericinput-and-selectinput-in-dt-reactive-table

Answer 1

This looks like the same issue as this one. I haven't tried because you have not included the library() calls in your post. Try that:

ui <- dashboardPage(
  dashboardHeader(title = 'Dashboard'),
  dashboardSidebar(),
  
  dashboardBody(

    tags$head(tags$script(
      HTML(
        "Shiny.addCustomMessageHandler('unbindDT', function(id) {
        var $table = $('#'+id).find('table');
        if($table.length > 0){
          Shiny.unbindAll($table.DataTable().table().node());
        }
      })")
    )),
    
    tabsetPanel(
      tabPanel('Triplets', 
               fluidRow(
                 hr(),
                 column(12, 
                        DTOutput('project_table'), 
                        actionButton("go", "TEST"),
                        verbatimTextOutput('sel'),
                        DTOutput('subproject_table'),
                        DTOutput('test_table'))
               )
      )
    )
  )
)


# SERVER -----------------------------------
server <- function(input, output, session) { 
  
  output$project_table <- renderDT(df1, options = list(pageLength = 10))
  
  vars.long.sel.df <- reactive({
    s=input$project_table_rows_selected
    print(s)
    project <- unique(df1[s,c("Project")])
    vars.long.sel=df2 %>% filter(Project%in%project)  %>% mutate(test.val=NA) %>% rowid_to_column("row")
    for (i in 1:nrow(vars.long.sel)) {
      if (vars.long.sel$Param.Type[i]=="SimCat") {
        vars.long.sel$test.val[i] <- as.character(selectInput(paste0("sel", vars.long.sel$row[i]), "", choices =aa$choice.val[aa$Param.Name==vars.long.sel$PARAM[i]],selected = vars.long.sel$measurement[i], width = "100px"))
      } else {
        vars.long.sel$test.val[i] <- as.character(numericInput(paste0("sel",vars.long.sel$row[i]), "", value=as.numeric(vars.long.sel$measurement[i]), width = "100px"))
      }
    }
    vars.long.sel
  })
  
  observeEvent(vars.long.sel.df(), {
    session$sendCustomMessage("unbindDT", "subproject_table")
  })
  
  output$subproject_table <- renderDT({
    req(input$project_table_rows_selected)
    vars.long.sel.df()
  },
  escape = FALSE, selection = 'none', server = F,
  options = list( dom = 'Bfrtip', paging = FALSE, ordering = FALSE, buttons = c( 'excel')), extensions = 'Buttons'
  ,
  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());")
  )
  
  
  
  #   # TEST btn --------------------------
  output$sel = renderPrint({
    str(sapply(1:nrow(vars.long.sel.df()), function(i) input[[paste0("sel", i)]]))
  })
  
}


shinyApp(ui, server)