为 DT 闪亮中的单列渲染下拉列表，但仅在单元格单击时加载并使用 replaceData()
Posted
技术标签:
【中文标题】为 DT 闪亮中的单列渲染下拉列表，但仅在单元格单击时加载并使用 replaceData()【英文标题】：render dropdown for single column in DT shiny BUT loaded only on cell click and with replaceData() 【发布时间】：2020-11-14 07:39:09 【问题描述】：目标
使用replaceData() 和 RDBMS (SQL Server) 上的数据在 DT 数据表中选择下拉菜单，而不是在数据表的构建中，而是在单元格单击时构建。
当我单击 的选定选项时，例如 Ohio，我想将我的数据（和 RDBMS）设置为 id 2。
问题
与replaceData()
没有replaceData()
使用过
我使用下面的这个技巧在 DT Table 中添加复选框。它工作得很好，但是当有很多数据时它在构建时非常慢，因为每个复选框的 html 数量非常重要。
R Shiny, how to make datatable react to checkboxes in datatable 史瑞克谭尚未阅读，并受到启发
我使用下面的这个技巧，类似于上一部分，来编写我的代码。但我尝试只在单元格点击上构建，因为我知道前面的部分很慢
render dropdown for single column in DT shiny GyD（和 Yihu）。这是我的代表
提前感谢您的帮助:)
library(shiny)
library(DT)
library(dplyr)
library(shinyjs)
library(DescTools)
# inspired by https://***.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
【问题讨论】：
你好。 Is it what you want? 你好。我的 POC 不适用于 replaceData()。使用 replaceData() 我在动态 @phili_b，如果你使用我建议的方式，你就不需要这个乱码。 谢谢，但我不想要因素：我需要一对 Id - RDBMS 的名称。因此，我需要像<select id="selection1"><option value="1" selected>Alabama</option><option value="2">Ohio</option><option value="3">WDC</option></select> 这样的
在您的解决方案中，您的
【参考方案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)
【讨论】：
谢谢，但几乎很好：有时两行会获得一次点击行的更新值。例如 row1: 1-Alabama, row2=2-Ohio，如果我点击 row2 和 1-Alabama，那么 row1 有时也会得到 1-Alabama。 当前页面被重置 我为你的工作+1。我尝试解决有关错误更新的行的错误。 用isolate()进行了一些更改，内存中的页面，但我的代码又出现了错误。如果没有解决方案，解决方案将像我对其他 R Shiny 屏幕所做的那样：单击数据行并在数据表下的表单中更新。 看到其他人+1的一点补充：我认为该解决方案对我来说效果不佳，因为 DT/datatables.net 处于服务器模式，并且我在使用过程中从 RDBMS 重新加载数据 数据表。因此，我在数据表下使用以上是关于为 DT 闪亮中的单列渲染下拉列表，但仅在单元格单击时加载并使用 replaceData()的主要内容，如果未能解决你的问题，请参考以下文章