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

Question

Goal

• To have select dropdown in DT datatables not at the building of the datatable but built on cell click, with replaceData() and with the datas on RDBMS (SQL Server).
• When I click on the selected option of the, for example Ohio I want to set my data (and the RDBMS) with the id 2 .

The issue

• With replaceData()

  • the events of select are unbinded. It strange because only the cells where I've clicked are unbinded.
  • the selected page is lost
  • Update of StateId works (but I cannot click again on if I select an another raw and come back)
  • and, it's a positive thing I think, the select are drawn at row select

• Without replaceData()

  • all the events are binded but I cannot update StateId in DT datatable
  • neither in datas (and consequently not in RDMBS SQL update)

Used yet

I used this trick below to add checkbox in DT Table. It works very well but it's very slow at the building when there is lot of datas because the amount of html for each checkbox is very important.

• R Shiny, how to make datatable react to checkboxes in datatable by Shrek Tan

Read yet, and inspired by

I used this trick below, similar to previous part, to write my code. But I try to build only on cell click because I know by the previous part that is slow

• render dropdown for single column in DT shiny by GyD (and Yihu).

Here is my reprex

Thank you in advance for your help:)

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

You have to unbind before running 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',
  ......

and in server :

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