为 DT shiny 中的单列渲染下拉列表，但仅在单击单元格时加载并使用 replaceData()

Question

目标

• 要在 DT 数据表中使用 select 下拉菜单，而不是在数据表的构建中，而是在单元格单击时使用replaceData()和 RDBMS (SQL Server) 上的数据。
• 当我单击所选选项时，例如Ohio ，我想将我的数据（和 RDBMS）设置为 id 2 。

问题

• 使用replaceData()

  • select 的事件未绑定。 这很奇怪，因为只有我单击的单元格是未绑定的。
  • 所选页面丢失
  • StateId 的更新有效（但如果我 select 另一个原始并回来，我无法再次单击）
  • 而且，我认为这是一件好事，select 绘制在 select 行

• 没有replaceData()

  • 所有事件都已绑定，但我无法更新 DT 数据表中的 StateId
  • 既不在数据中（因此不在 RDMBS SQL 更新中）

尚未使用

我使用下面的这个技巧在 DT Table 中添加复选框。 它工作得很好，但是当有很多数据时，它在构建时非常慢，因为每个复选框的 html 的数量非常重要。

• R Shiny，如何使数据表对数据表中的复选框做出反应，史莱克谭

尚未阅读，并受到启发

我在下面使用了这个技巧，类似于上一部分，来编写我的代码。 但是我尝试仅在单元格单击上构建，因为我知道前面的部分很慢

• 由 GyD（和 Yihu）为 DT shiny 中的单列渲染下拉列表。

这是我的代表

预先感谢您的帮助：）

library(shiny)
library(DT)
library(dplyr)
library(shinyjs)
library(DescTools)
# inspired by https://stackoverflow.com/questions/57215607/render-dropdown-for-single-column-in-dt-shiny/57218361#57218361
# 
ui <- fluidPage(
  useShinyjs(),
  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());
        }
      })")
  )),
  title = 'Selectinput column in a table',
  DT::dataTableOutput('foo_dt'),
  verbatimTextOutput('selection'),
  textInput("mypage",label = NULL,value ="" )
)
# in real case : Query on RDBMS SQL Server
df_product <- data.frame( Product = c(rep("Toaster", 3), rep("Radio", 3)),StateId = c(3,2,2,1,1,2), stringsAsFactors = FALSE)
df_state <- data.frame(StateId = c(1,2,3), State = c("Alabama","Ohio","WDC"), stringsAsFactors = FALSE)

df_datatable  <- df_product %>% left_join(.,df_state, by = c("StateId"="StateId")) %>% select (Product,State,StateId)

myselected_vector <- (which(colnames(df_datatable) %in% c("StateId"))    )
target_vector <- (which(colnames(df_datatable) %in% c("State"))    )


df_state_select <-df_state %>% transmute   (value=StateId,label=State) %>% unique()

list_label_value=setNames(df_state_select$value,df_state_select$label)

selectInputModel <-gsub("[\r\n]", "", as.character(
  selectInput("selectionXX", "", choices = list_label_value, width = "100px")
))

server <- function(input, output, session) {
  
  
  
  react <- reactiveValues(
    foo_dt_page=NULL,
    # in real case : Query on RDBMS SQL Server
    datas = df_datatable,
    foo_dt_refresh= FALSE
  )  
  
  
  datas_react <-reactive({
    input_evt=react$foo_dt_refresh
    isolate(react$datas)
  })
  
  proxy_foo_dt=dataTableProxy('foo_dt')
  
  
  output$foo_dt = DT::renderDataTable(
    datas_react(), escape = FALSE, selection='single',
    server = TRUE,
    editable = list(target = "cell"),
    options = list(
      ordering = FALSE,
      columnDefs = list(
        list(orderable = FALSE, className = 'details-control', targets = target_vector),
        list(width = '10px', targets = myselected_vector)
      ),
      stateSave = TRUE,
      pageLength = 2,
      lengthMenu = c(2,5,6),
      preDrawCallback = JS('function() { 
                              Shiny.unbindAll(this.api().table().node()); }'), 
      drawCallback = JS("function() { 
       
                        mypage = $('#mypage').val();        
                        if (typeof mypage !== 'undefined' && mypage.trim().length!=0) {
                          if ( $('#foo_dt').find('.dataTable').DataTable().page()!=parseInt(mypage) ) {
                              $('#foo_dt').find('.dataTable').DataTable().page(parseInt(mypage)).draw(false);
                              $('#mypage').val('');
                          }
                        } 

                         Shiny.bindAll(this.api().table().node()); 
                         


                         } ")
    ),
    
    callback = JS(paste0("
    

         table.on('click', 'td.details-control', function() {
             console.log('phil test')
        
             var td = $(this),
                 row = table.row(td.closest('tr'));
             myrow = row.data()[0];
             myselected = row.data()[",myselected_vector[1],"];

             if ($('#selection' + myrow).length == 0) {
        
                 selectInputModel = '",selectInputModel[1],"';
                 
                 selectInputModel = selectInputModel.replace('<select id=\\\"selectionXX\\\">','<select id=\\\"selectionXX\\\"  class=\\\"shiny-bound-input\\\">');
                 selectInputModel = selectInputModel.replace(/XX/g, myrow);
                 // selectInputModel = selectInputModel.replace('selected', '');
                 selectInputModel = selectInputModel.replace('value=\\\"' + myselected + '\\\"', 'value=\\\"' + myselected + '\\\" selected');
                 td.html(selectInputModel);
        
                 Shiny.unbindAll(table.table().node());

                 Shiny.bindAll(table.table().node());
             }
        
         })
                  
    "))
  )
  
  output$selection = renderPrint({
    str(sapply(1:nrow(datas_react()), function(i) input[[paste0("selection", i)]]))
  })
  
  
  ReplaceData_foo_dtRefresh <- function (react) {
    react$foo_dt_refresh <- TRUE
    session$sendCustomMessage("unbindDT", "foo_dt")
    replaceData(proxy_foo_dt,(datas_react()) , resetPaging = TRUE)
    
    
    react$foo_dt_refresh <- FALSE
    
  }
  
  observeEvent(lapply(1:nrow(isolate(datas_react())), function(i) input[[paste0("selection", i)]]), {
    validate(
      need(!is.null(input$foo_dt_cell_clicked) , message = FALSE)
    )
    

    print(
      paste0(Sys.time() ," : ", 
             as.character( input$foo_dt_cell_clicked$row)," =" ,
             input[[paste0("selection",  input$foo_dt_cell_clicked$row )]]
      )
    )
    
    if ( react$datas[input$foo_dt_cell_clicked$row,myselected_vector]!= input[[paste0("selection",  input$foo_dt_cell_clicked$row )]] ) {
      isolate(react$datas[input$foo_dt_cell_clicked$row,myselected_vector]<- input[[paste0("selection",  input$foo_dt_cell_clicked$row )]] )
      isolate(react$datas[input$foo_dt_cell_clicked$row,target_vector]<-(df_state %>% filter(StateId==input[[paste0("selection",  input$foo_dt_cell_clicked$row )]]))$State)
      
      ReplaceData_foo_dtRefresh (react)

      updateTextInput(session,"mypage",label = NULL,ceiling(input$foo_dt_cell_clicked$row / input$foo_dt_state$length)-1)
    }
    
    
  },ignoreNULL = TRUE)
  
  
}

shinyApp(ui, server)

xfun::session_info()

Package version:
  assertthat_0.2.1   backports_1.1.7    BH_1.72.0.3        callr_3.4.3        cli_2.0.2          colorspace_1.4.1   compiler_3.6.3     crayon_1.3.4      
  crosstalk_1.0.0    desc_1.2.0         digest_0.6.25      dplyr_1.0.0        DT_0.12.1          ellipsis_0.3.1     evaluate_0.14      fansi_0.4.1       
  farver_2.0.3       fastmap_1.0.1      generics_0.0.2     ggplot2_3.3.1      glue_1.4.1         graphics_3.6.3     grDevices_3.6.3    grid_3.6.3        
  gtable_0.3.0       htmltools_0.4.0    htmlwidgets_1.5.1  httpuv_1.5.2       isoband_0.2.1      jsonlite_1.6.1     labeling_0.3       later_1.0.0       
  lattice_0.20.38    lazyeval_0.2.2     lifecycle_0.2.0    magrittr_1.5       MASS_7.3.51.5      Matrix_1.2.17      methods_3.6.3      mgcv_1.8.31       
  mime_0.9           munsell_0.5.0      nlme_3.1.141       pillar_1.4.4       pkgbuild_1.0.8     pkgconfig_2.0.3    pkgload_1.1.0      praise_1.0.0      
  prettyunits_1.1.1  processx_3.4.2     promises_1.1.0     ps_1.3.3           purrr_0.3.4        R6_2.4.1           RColorBrewer_1.1.2 Rcpp_1.0.4.6      
  rlang_0.4.6        rprojroot_1.3.2    rstudioapi_0.11    scales_1.1.1       shiny_1.4.0        sourcetools_0.1.7  splines_3.6.3      stats_3.6.3       
  testthat_2.3.2     tibble_3.0.1       tidyselect_1.1.0   tools_3.6.3        utf8_1.1.4         utils_3.6.3        vctrs_0.3.1        viridisLite_0.3.0 
  withr_2.2.0        xfun_0.14          xtable_1.8-4       yaml_2.2.1        

Answer 1

您必须在运行replaceData之前取消绑定。

ui <- fluidPage(
  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());
        }
      })")
  )),
  title = 'Selectinput column in a table',
  ......

在server中：

  ......
  session$sendCustomMessage("unbindDT", "foo_dt")
  ReplaceData_foo_dtRefresh (react)