render dropdown for single column in DT shiny BUT loaded only on cell click and with 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://mcmap.net/q/912672/-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        

Ph

Hello. Is it what you want? – Trix

Hello. My POC doesn't work with replaceData(). With replaceData() my js events on dynamic <select> input are dropped after one use. Therefore I would like this bug fixed :) and I tried myself without success. – Ph

@ phili_b, you don't need this messy code if you use the way I suggest. – Trix

Thanks but I don't want factor : I need the couple Id - Name for the RDBMS. Therefore I need a <select> like <select id="selection1"><option value="1" selected>Alabama</option><option value="2">Ohio</option><option value="3">WDC</option></select> . There is perhaps "messy" code for line >100: normal it's the core of my question. But the code between between 10 and 26 is not messy : it's a simulation of RDBMS SQL Code: Master Table 1,n-> Child Table with Foreign Key. For RDBMS I need the Id updated in data. Therefore your solution linked doesn't answer to my question. :) – Ph

And in your solution your <select> is unstable :) : the select doesn't work very well, the select closes itself sometimes before you can click. I would like the same select as GyD (and Yihu) solution. – Ph

When I click on the <select> I would like the Id be updated in the data. The normal solution is by _cell_edit, EditData() but the _cell_edit is not fired with this sort of select. So I use ReplaceData() but it reset all the selects yet fired. – Ph

@ phili_b> You can use _cell_edit with my solution. And it is not true that the select is unstable: it automatically closes when it loses the focus, that's all. And this has nothing to do with factors. – Trix

Your select is less pratical than the GyD (and Yihu) <select> because of the lost of focus and more click with your <select>. I prefer the GyD (and Yihu) <select>. Would you help updating my code, please ? or updating the @Gyd solution for my answer but with an Id and updated data ? (I understand that factor is not the cause, but I don't want factors still because with RDBMS R Queries and factors are not good friends). – Ph

@ phili-b> You can set the option autoHide = false if you don't want the dropdown to be hidden on lost of focus. What do you mean by "more clicks"? This is the normal behavior of an editable datatable. Yihui's code is an horrible hack, I don't have the envy to put my hands into it, especially if there is a nicer solution. – Trix

Your solution is nice for developers but not for UI users: I like his solution not for his code but for the UI <select> usable with one click: I would like the same UI with another code if you want. And you don't answer to my question to implement Id in the <select> and update the data. – Ph

@ phili_b> My solution is nice for everybody :) I've just tried your code. The dropdown menu remains visible when you use it. Do you like that behavior?? It's ugly IMHO. I don't see what you mean by "implementing the id". Please be more precise. – Trix

It doesn't remain when replaceData() is called. "Implementing the Id": When I click on the selected option of the <select>, for example Ohio I want to set my data (and the RDBMS) with the id 2. I don't want your <select> where we have to click and click again : forget it please :) – Ph

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)
  

Christmastide

Thank you but nearly good: sometimes two rows get the updated value of one clicked row. For example row1: 1-Alabama, row2=2-Ohio, If I click a row2 with 1-Alabama, then row1 get 1-Alabama also sometimes. – Ph

and current page is reseted – Ph

I put +1 for your work. I try to solve the bug about rows updated by error. – Ph

Some changes with isolate (), page in memory, but my code is buggy again. If there is no solution, the solution will be as I did for other R Shiny screens: to click on a datable row and update in a form under the datatable. – Ph

A little addendum seeing the others +1 : I think the solution doesn't work very well for me because DT/datatables.net is in server mode and I reload data from RDBMS during the use of <select> of datatables. Therefore I use <form> under the datatable since 6 months. – Ph