问题描述
我正在尝试将两个共同共享的 JS 回调合并到一个 R 数据表闪亮应用程序中（具有单选按钮（请参阅 https://yihui.shinyapps.io/DT-radio/ 和 Extracting user input values from radio buttons in Shiny DT into a dataframe or list）并在子/父表中具有嵌套行（请参阅 { {3}} 和许多其他地方）。它们单独工作，但不能一起工作。我不确定我是否错误地绑定了 JS 或 JS 以某种方式相互矛盾？无论哪种方式，我都无法访问用户输入不再（如果我查看 input$xxx 的结构，只会返回一个空值）。我已经包含了一个小例子（虽然仍然很长）我的意思。
library(shiny)
library(DT)
library(shinyWidgets)
library(tidyverse)
shinyApp(
ui = fluidPage(
title = 'Radio button and a dropdown manue ',sliderInput("n_rows_table","Number of rows:",min = 0,max = 10,value = 5),actionBttn(
inputId = "btnCancel",label = "Make tables",size = "sm",color = "warning"
),p("THIS EXAMPLE DOES NOT WORK!"),DT::dataTableOutput("datatable"),verbatimtextoutput('sel'),p("THIS SIMPLER EXAMPLE DOES WORK!"),DT::dataTableOutput("datatable2"),verbatimtextoutput('sel2'),p("These of the R6 input class objects,the the ones from the first tabel do not show up"),verbatimtextoutput('sel_all'),),server = function(input,output,session) {
# Ideally instead of working with a counter,# this would just override the old value so instead of a_1,a_2,# everything you click the button it just sets input$a back to null
# until the users clicks again.
# But in the meantime this is a work around
counter <- reactiveValues(countervalue = 0) # Defining & initializing the reactiveValues object
observeEvent(input$btnCancel,{
counter$countervalue <- counter$countervalue + 1 # if the add button is clicked,increment the value by 1 and update it
})
# ----- Create a table based on the number of rows from the slider
# ----- and create it when the user clicks the button
data_for_table <- eventReactive(
input$btnCancel,{
tibble(
let_rowid = paste0(letters[1:input$n_rows_table],"_",counter$countervalue ),val_1 = round(runif(input$n_rows_table,10),1),val_2 = round(rnorm(input$n_rows_table),2),val_3 = round(rnorm(input$n_rows_table),val_4 = letters[1:input$n_rows_table],Yes = "Yes",No = "No",Maybe = "Maybe",result = NA # ideally the what ever selection in yes/no/maybe shows up in this column (future improvement)
) %>%
mutate(oplus = "⊕") %>%
relocate(oplus) %>%
mutate(
Yes = sprintf('<input type="radio" name="%s" value="%s"/>',let_rowid,Yes),No = sprintf('<input type="radio" name="%s" value="%s"/>',No),Maybe = sprintf('<input type="radio" name="%s" value="%s"/>',Maybe)
) %>%
nest(datalist = c(val_3,val_4)) %>%
mutate(datalist = map(datalist,as.list)) %>%
mutate(datalist = map(datalist,list))
})
# ----- Render the table
# ----- The table renders ok.
output$datatable <- DT::renderDT({
parentRows <- which(data_for_table()[,1] != "")
# ------ This JS is neede to make the child/parent dropdown
callback <- JS(
sprintf("var parentRows = [%s];",toString(parentRows-1)),sprintf("var j0 = %d;",0),"var nrows = table.rows().count();","for(let i = 0; i < nrows; ++i){"," var $cell = table.cell(i,j0).nodes().to$();"," if(parentRows.indexOf(i) > -1){"," $cell.css({cursor: 'pointer'});"," }else{"," $cell.removeClass('details-control');"," }","}","","// --- make the table header of the nested table --- //","var formatHeader = function(d,childId){"," if(d !== null){"," var html = "," '<table class=\"display compact hover\" ' + "," 'style=\"padding-left: 30px;\" id=\"' + childId + "," '\"><thead><tr>';"," var data = d[d.length-1] || d.datalist;"," for(let key in data[0]){"," html += '<th>' + key + '</th>';"," }"," html += '</tr></thead></table>'"," return html;"," } else {"," return '';","};","// --- row callback to style rows of child tables --- //","var rowCallback = function(row,dat,displayNum,index){"," if($(row).hasClass('odd')){"," $(row).css('background-color','papayawhip');"," $(row).hover(function(){"," $(this).css('background-color','#E6FF99');"," },function(){"," });",'lemonchiffon');",'#DDFF75');","// --- header callback to style header of child tables --- //","var headerCallback = function(thead,data,start,end,display){"," $('th',thead).css({"," 'border-top': '3px solid indigo',"," 'color': 'indigo'," 'background-color': '#fadadd'"," });","// --- make the datatable --- //","var formatDatatable = function(d," var data = d[d.length-1] || d.datalist;"," var colNames = Object.keys(data[0]);"," var columns = colNames.map(function(x){"," return {data: x.replace(/\\./g,'\\\\\\.'),title: x};"," var id = 'table#' + childId;"," if(colNames.indexOf('datalist') === -1){"," var subtable = $(id).DataTable({"," 'data': data," 'columns': columns," 'autoWidth': true," 'deferRender': true," 'info': false," 'lengthChange': false," 'ordering': data.length > 1," 'order': []," 'paging': false," 'scrollX': false," 'scrollY': false," 'searching': false," 'sortClasses': false," 'rowCallback': rowCallback," 'headerCallback': headerCallback," 'columnDefs': [{targets: '_all',className: 'dt-center'}]"," 'columnDefs': ["," {targets: -1,visible: false}," {targets: 0,orderable: false,className: 'details-control'}," {targets: '_all',className: 'dt-center'}"," ]"," }).column(0).nodes().to$().css({cursor: 'pointer'});","// --- display the child table on click --- //","// array to store id's of already created child tables","var children = [];","table.on('click','td.details-control'," var tbl = $(this).closest('table')," tblId = tbl.attr('id')," td = $(this)," row = $(tbl).DataTable().row(td.closest('tr'))," rowIdx = row.index();"," if(row.child.isShown()){"," row.child.hide();"," td.html('⊕');"," var childId = tblId + '-child-' + rowIdx;"," if(children.indexOf(childId) === -1){"," // this child has not been created yet"," children.push(childId);"," row.child(formatHeader(row.data(),childId)).show();"," td.html('⊖');"," formatDatatable(row.data(),childId,rowIdx);"," }else{"," // this child has already been created"," row.child(true);","}); ","// --- add radio button functionality --- //","table.rows().every(function(i,tab,row) {"," var $this = $(this.node());"," $this.attr('id',this.data()[0]);"," $this.addClass('shiny-input-radiogroup');"," Shiny.unbindAll(table.table().node());"," Shiny.bindAll(table.table().node());")
datatable(
data_for_table(),escape = F,rownames = F,callback = callback,options = list(
dom = 't',paging = FALSE,ordering = FALSE,searching = FALSE,columnDefs = list(
list(
visible = FALSE,targets = c(c(1,ncol(data_for_table())-1)) # do not show certain ID variables,we do not need
),list(
orderable = FALSE,className = "details-control",targets = 0
),list(
className = "dt-left",targets = "_all"
)
)
)
)
},server = F)
list_results <- reactive({
list_values <- list()
for (i in unique(data_for_table()$let_rowid)) {
list_values[[i]] <- paste0(i,": ",input[[i]])
}
list_values
})
output$sel = renderPrint({
list_results()
})
####################################
## this simpler version does work ##
####################################
data_for_table2 <- eventReactive(
input$btnCancel,{
tibble(
let_rowid = paste0(letters[11:(10+input$n_rows_table)],result = NA # ideally the what ever selection in yes/no/maybe shows up in this column (future improvement)
) %>%
mutate(
Yes = sprintf('<input type="radio" name="%s" value="%s"/>',Maybe)
) })
output$datatable2 <- DT::renderDT({
# ---- only difference here is he lack of a drop down.
callback <- JS("table.rows().every(function(i,row) {
var $this = $(this.node());
$this.attr('id',this.data()[0]);
$this.addClass('shiny-input-radiogroup');
});
Shiny.unbindAll(table.table().node());
Shiny.bindAll(table.table().node());")
datatable(
data_for_table2(),columnDefs = list(
# list(
# visible = FALSE,# targets = c(ncol(data_for_table2())-1+0) # do not show certain ID variables,we do not need
# ),server = F)
list_results2 <- reactive({
list_values <- list()
for (i in unique(data_for_table2()$let_rowid)) {
list_values[[i]] <- paste0(i,input[[i]])
}
list_values
})
output$sel2 = renderPrint({
list_results2()
})
# make this regex working
list_results_all <- reactive({
list_values_all <- list()
for(i in names(input)[grepl("([a-z]{1}_)([0-9]{1,3})",names(input))]){
list_values_all[[i]] <- tibble(id = i,value = paste0(input[[i]]))
}
do.call(rbind,list_values_all)
})
output$sel_all = renderPrint({
list_results_all()
})
}
)
编辑（附加问题）
给出的答案解决了我对 MWE 的原始问题。但是，再深入一点，通过在表格中添加额外类型的按钮，单选按钮仍然会中断（例如，通过添加删除按钮，如果我首先单击单选按钮然后删除它确实有效，但不是反之亦然）。有没有办法让这种行为更加一致？
（部分代码取自这个问题的答案：https://stackoverflow.com/a/56599838/10624798）
library(shiny)
library(DT)
library(shinyWidgets)
library(tidyverse)
# 1) These two function allows for setting a remove function in the app.
# This code is taken from here: https://stackoverflow.com/questions/53908266/r-shiny-remove-row-button-in-data-table
getRemoveButton <- function(n,idS = "",lab = "Pit") {
if (stringr::str_length(idS) > 0) idS <- paste0(idS,"-")
ret <- shinyInput(actionButton,n,'button_',label = "Remove",onclick = sprintf('Shiny.onInputChange(\"%sremove_button_%s\",this.id)',idS,lab))
return (ret)
}
shinyInput <- function(FUN,id,ses,...) {
as.character(FUN(paste0(id,n),...))
}
shinyApp(
ui = fluidPage(
title = 'Radio button and a dropdown manue ',#p("THIS SIMPLER EXAMPLE DOES WORK!"),#DT::dataTableOutput("datatable2"),#verbatimtextoutput('sel2'),#("These of the R6 input class objects,#verbatimtextoutput('sel_all'),session) {
# Ideally instead of working with a counter,increment the value by 1 and update it
})
values <- reactiveValues(tab = NULL)
# ----- Create a table based on the number of rows from the slider
# ----- and create it when the user clicks the button
observeEvent(
input$btnCancel,{
values$tab <- tibble(
let_rowid = paste0(letters[1:input$n_rows_table],Maybe)
) %>%
## THIS IS NEW ###################################################
mutate(id = 1:n()) %>% #
rowwise() %>% #
mutate(Remove = getRemoveButton(id,lab = "Tab1"))%>% #
ungroup() %>% #
##################################################################
nest(datalist = c(val_3,list))
})
# add a proxy table
proxyTable <- DT::dataTableProxy("tab")
# ----- Render the table
# ----- The table renders ok.
output$datatable <- DT::renderDT({
parentRows <- which(values$tab[,1] != "")
# ------ This JS is neede to make the child/parent dropdown
callback <- JS(
sprintf("var parentRows = [%s];",this.data()[1]);"," Shiny.bindAll(table.table().node());")
datatable(
values$tab,columnDefs = list(
list(
visible = FALSE,ncol(values$tab)-1)) # do not show certain ID variables,we do not need
),targets = "_all"
)
)
)
) },server = F)
observeEvent(input$remove_button_Tab1,{
myTable <- values$tab
s <- as.numeric(strsplit(input$remove_button_Tab1,"_")[[1]][2])
myTable <- filter(myTable,id != s)
replaceData(proxyTable,myTable,resetPaging = FALSE)
values$tab <- myTable
})
list_results <- reactive({
list_values <- list()
for (i in unique( values$tab$let_rowid)) {
list_values[[i]] <- paste0(i,input[[i]])
}
list_values
})
output$sel = renderPrint({
list_results()
})
####################################
## this simpler version does work ##
####################################
# removed for Now
}
)
我尝试过的另一件事（但没有奏效）
我现在也尝试了此处给出的解决方案：R Shiny: Remove Row Button in Data Table，但这给出了完全相同的问题。
解决方法
您在 JavaScript 回调中分配了错误的 id 元素，因为在您的表格中，第一列实际上是 &oplus 列，但您想要第二列。
因此改变这个
table.rows().every(function(i,tab,row) {
var $this = $(this.node());
$this.attr('id',this.data()[0]); // this.data()[0] refers to the firts column,i.e. ⊕
$this.addClass('shiny-input-radiogroup');
});
为此：
table.rows().every(function(i,this.data()[1]); // the id is in the second column in your case
$this.addClass('shiny-input-radiogroup');
});