Question

我正在尝试创建一个具有两层嵌套的数据表。第一个用于分组行（https://github.com/rstudio/shiny-examples/issues/9#issuecomment-295018270），第二个用于打开模态（R shinyBS popup window）。我可以单独使用它，但第二层嵌套会产生问题。只要存在第二个嵌套，表中的数据就不再显示在折叠组中。

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

任何提示都表示赞赏。

# 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)

嵌套/子行和模态

0 个答案: