r - 具有嵌套/子行和模式的数据表

Question

我正在尝试制作一个具有两层嵌套的数据表。第一个用于分组行（https://github.com/rstudio/shiny-examples/issues/9#issuecomment-295018270），第二个应该打开一个模式（R shinyBS 弹出窗口）。我可以让它单独工作，但第二层嵌套会产生问题。一旦有第二次嵌套，表中的数据就不再显示在折叠组中。

所以到目前为止我所做的至少有一个问题，那就是当有多个嵌套时如何让它正确显示。之后，我不确定该模态当前是否有效。我想知道 ids 是否不会像现在这样发生冲突。

任何提示表示赞赏。

# Libraries ---------------------------------------------------------------
library(DT)
library(shiny)
library(shinyBS)
library(shinyjs)

library(tibble)
library(dplyr)
library(tidyr)
library(purrr)


# Funs --------------------------------------------------------------------

# Callback for nested rows
nest_table_callback <- function(nested_columns, not_nested_columns){

    not_nested_columns_str <- not_nested_columns %>% paste(collapse="] + '_' + d[") %>% paste0("d[",.,"]")

    paste0("
            table.column(1).nodes().to$().css({cursor: 'pointer'});

            // Format data object (the nested table) into another table
            var format = function(d) {
              if(d != null){ 
                var result = ('<table id=\"child_' + ",not_nested_columns_str," + '\">').replace('.','_') + '<thead><tr>'
                for (var col in d[",nested_columns,"]){
                  result += '<th>' + col + '</th>'
                }
                result += '</tr></thead></table>'
                return result
              }else{
                return '';
              }
            }

            var format_datatable = function(d) {
              var dataset = [];
              for (i = 0; i < + d[",nested_columns,"]['model'].length; i++) {
                var datarow = [];
                for (var col in d[",nested_columns,"]){
                  datarow.push(d[",nested_columns,"][col][i])
                }
                dataset.push(datarow)
              }
              var subtable = $(('table#child_' + ",not_nested_columns_str,").replace('.','_')).DataTable({
                'data': dataset,
                'autoWidth': true, 
                'deferRender': true, 
                'info': false, 
                'lengthChange': false, 
                'ordering': true, 
                'paging': false, 
                'scrollX': false, 
                'scrollY': false, 
                'searching': false 
              });
            };

            table.on('click', 'td.details-control', function() {
              var td = $(this), row = table.row(td.closest('tr'));
              if (row.child.isShown()) {
                row.child.hide();
                td.html('&oplus;');
              } else {
                row.child(format(row.data())).show();
                td.html('&CircleMinus;');
                format_datatable(row.data())
              }
            });
           "
          )

}



# This function will create the buttons for the datatable, they will be unique
shinyInput <- function(FUN, len, id, ...) {inputs <- character(len)
                                           for (i in seq_len(len)) {
                                             inputs[i] <- as.character(FUN(paste0(id, i), ...))}
                                           inputs
}


add_view_col <- . %>% {bind_cols(.,View = shinyInput(actionButton, nrow(.),'button_', label = "View", onclick = 'Shiny.onInputChange(\"select_button\",  this.id)' ))}



# Example nested data -----------------------------------------------------


collapse_col <- "to_nest"
modal_col <- "to_modal"

# nested data
X <- mtcars %>% 
                        rownames_to_column("model") %>% 
                        as_data_frame %>% 
                        select(mpg, cyl, model, everything()) %>%
                        nest(-mpg, -cyl, .key=!!modal_col) %>% #-#-#-#-#-#- WORKS IF THIS IS REMOVED #-#-#-#-#-#
                        nest(-mpg, .key=!!collapse_col)







data <- X %>% 
         {bind_cols(data_frame(' ' = rep('&oplus;',nrow(.))),.)} %>%
         mutate(!!collapse_col := map(!!rlang::sym(collapse_col), add_view_col))



collapse_col_idx <- which(collapse_col == colnames(data))

not_collapse_col_idx <- which(!(seq_along(data) %in% c(1,collapse_col_idx)))

callback <- nest_table_callback(collapse_col_idx, not_collapse_col_idx)




ui <- fluidPage( DT::dataTableOutput('my_table'),
                 uiOutput("popup")
                 )


server <- function(input, output, session) {

  my_data <- reactive(data)  


  output$my_table <- DT::renderDataTable(my_data(),
                                         options = list(columnDefs = list(
                                                                            list(visible = FALSE, targets = c(0,collapse_col_idx) ), # Hide row numbers and nested columns
                                                                            list(orderable = FALSE, className = 'details-control', targets = 1) # turn first column into control column
                                                                          )
                                                        ),
                                         server = FALSE,
                                         escape = -c(2),
                                         callback = JS(callback),
                                         selection = "none"
                                         )


  # Here I created a reactive to save which row was clicked which can be stored for further analysis
  SelectedRow <- eventReactive(input$select_button,
                                as.numeric(strsplit(input$select_button, "_")[[1]][2])
                              )

  # This is needed so that the button is clicked once for modal to show, a bug reported here
  # https://github.com/ebailey78/shinyBS/issues/57
  observeEvent(input$select_button, {
                                      toggleModal(session, "modalExample", "open")
                                    }
               )

  DataRow <- eventReactive(input$select_button,
                           my_data()[[collapse_col_idx]][[SelectedRow()]]
                           )

  output$popup <- renderUI({
                              bsModal("modalExample",
                                      paste0("Data for Row Number: ", SelectedRow()),
                                      "",
                                      size = "large",
                                      column(12, DT::renderDataTable(DataRow()))
                                    )
                          })

}

shinyApp(ui, server)