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
OhioI want to set my data (and the RDBMS) with the id2.
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.
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
