在 DT 中嵌入具有混合 numericInput 和 selectInput 的列：反应式 table

Question

目前的问题与我之前的有关，关于在 DT 中使用 R 嵌入具有混合 numericInput 和 selectInput 的列。

那里提供的解决方案工作正常，但是当我使用反应式时出现问题 table。

更详细地说，我有一个主要的 table（项目 table）。在 selecting 一行后，第二个 table 被过滤产生反应性 table（子项目 table），其中带有 numericInput 和 selectInput 的列是嵌入式的。它工作正常，但是当我 select 项目 table 中的新行时，子项目 table 中的嵌入列未更新。

我怀疑是列绑定的问题，是用JS代码执行的，但由于我对JS一窍不通，所以无法查明。

感谢您的宝贵时间！

这是一个示例代码：


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)

Answer 1

这看起来与的问题相同。我没有尝试过，因为您没有在 post 中包含 library() 调用。试试看：

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)

在 DT 中嵌入具有混合 numericInput 和 selectInput 的列：反应式 table

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

r

shiny

dt