在 R Shiny 中向嵌套数据表添加其他按钮

Question

有没有办法向嵌套数据表中的父行和子行添加额外的操作按钮？我尝试通过 JS 和 Shiny 端添加按钮，但它似乎不起作用。有什么建议？大部分代码是从这篇文章中借来的：Matching Parent/Child data up in a DataTable in R Shiny appThanks

    library(data.table)
    library(DT)
    library(purrr)
    library(shiny)
    library(dplyr)
    library(foreach)
    library(data.table)
    library(tidyverse)
    
    df <- data.frame("Gene.5" = c("PDE1A", "SLC45A3", "SLC45A3", "SLC45A3", "TARBP1", "CUL4A", "CUL4A"),
                     "Junction.5" = c("chr2:182198385:-", "chr1:205680393:-", "chr1:205680393:-", "chr1:205680393:-", "chr1:234420701:-", "chr13:113245060:+", "chr13:113245060:+"),
                     "Gene.3" = c("ELK4", "ETV2", "ETV2", "ETV2", "CEACAM1", "chr13_q32.3", "chr13_q32.3"),
                     "Junction.3" = c("chr1:205623892:-", "chr19:35642433:+", "chr19:35642614:+", "chr19:35642964:+", "chr19:42522203:-", "chr13:100068494:-", "chr13:100069868:-"),
                     "breakpoints" = c("1", "5", "5", "5", "2", "3", "3"),
                     "primary" = c("p","p","s","s","p","p","s")
    )
    head(df)
    gene_list <- c("SLC45A3", "CUL4A")
    
    df$V4=(
        df$Gene.5 %in% gene_list |
            df$Gene.3 %in% gene_list
    )
    print(df)
    par <- subset(df, df$primary == 'p')
    ch <- df
    
    all <-rbind(par,ch) #rbind the columns
    ch_only_df <- all[!duplicated(all,fromLast = FALSE)&!duplicated(all,fromLast = TRUE),] 
    print(ch_only_df)
    children_list<-list()
    for (row in 1:nrow(par)) {
        g5 <- paste(par[row, "Gene.5"])
        print(g5)
        g3 <- paste(par[row, "Gene.3"])
        tdf <- subset(ch_only_df, ch_only_df$Gene.5 == g5 & ch_only_df$Gene.3 == g3)
        if (nrow(tdf)<1){
            children_list[[row]] <- data.frame(NULL)
        }else{
            children_list[[row]] <- tdf
        }
    }
    children_list
    NestedData <- function(dat, children){
        stopifnot(length(children) == nrow(dat))
        g <- function(d){
            if(is.data.frame(d)){
                purrr::transpose(d)
            }else{
                purrr::transpose(NestedData(d[[1]], children = d$children))
            }
        }
        subdats <- lapply(children, g)
        oplus <- sapply(subdats, function(x) if(length(x)) "&oplus;" else "")
        cbind(" " = oplus, dat, "_details" = I(subdats), stringsAsFactors = FALSE)
    }
    
    rowNames <- FALSE
    colIdx <- as.integer(rowNames)
    
   
    ui <- fluidPage(# Application title
        titlePanel("Example"),
        checkboxInput("unroll", label = "Panel Genes", value = FALSE),
        tags$hr(),
        mainPanel(DTOutput("my_table"))
    )
    
    server <- function(input, output) {
       
        market_mix_table <- reactive({
            Dat <- NestedData(
                dat = par,
                children = children_list
            )
            if (!input$unroll) {
                Dat
            } else {
                Dat <- subset(Dat, Dat$V4 == TRUE)
            }
            return(Dat)
        })
 ## make the callback
    parentRows <- which(Dat[,1] != "")
    callback = JS(
        sprintf("var parentRows = [%s];", toString(parentRows-1)),
        sprintf("var j0 = %d;", colIdx),
        "var nrows = table.rows().count();",
        "for(var i=0; i < nrows; ++i){",
        "  if(parentRows.indexOf(i) > -1){",
        "    table.cell(i,j0).nodes().to$().css({cursor: 'pointer'});",
        "  }else{",
        "    table.cell(i,j0).nodes().to$().removeClass('details-control');",
        "  }",
        "}",
        "",
        "// make the table header of the nested table",
        "var format = function(d, childId){",
        "  if(d != null){",
        "    var html = ", 
        "      '<table class=\"display compact hover\" ' + ",
        "      'style=\"padding-left: 30px;\" id=\"' + childId + '\"><thead><tr>';",
        "    for(var key in d[d.length-1][0]){",
        "      html += '<th>' + key + '</th>';",
        "    }",
        "    html += '</tr></thead></table>'",
        "    return html;",
        "  } else {",
        "    return '';",
        "  }",
        "};",
        "",
        "// row callback to style the rows of the child tables",
        "var rowCallback = function(row, dat, displayNum, index){",
        "  if($(row).hasClass('odd')){",
        "    $(row).css('background-color', '##DDDDDD');",
        "    $(row).hover(function(){",
        "     $(this).css('background-color', '#DDDDDD');",
        "    }, function() {",
        "      $(this).css('background-color', '##DDDDDD');",
        "    });",
        "  } else {",
        "    $(row).css('background-color', '#EAF2F8');",
        "    $(row).hover(function(){",
        "      $(this).css('background-color', '#DDDDDD');",
        "    }, function() {",
        "      $(this).css('background-color', '#EAF2F8');",
        "    });",
        "  }",
        "};",
        "",
        "// header callback to style the header of the child tables",
        "var headerCallback = function(thead, data, start, end, display){",
        "  $('th', thead).css({",
        "    'border-top': '3px solid indigo',", 
        "    'color': '#00274c',",
        "    'background-color': '##DDDDDD'",
        "  });",
        "};",
        "",
        "// make the datatable",
        "var format_datatable = function(d, childId){",
        "  var dataset = [];",
        "  var n = d.length - 1;",
        "  for(var i = 0; i < d[n].length; i++){",
        "    var datarow = $.map(d[n][i], function (value, index) {",
        "      return [value];",
        "    });",
        "    dataset.push(datarow);",
        "  }",
        "  var id = 'table#' + childId;",
        "  if (Object.keys(d[n][0]).indexOf('_details') === -1) {",
        "    var subtable = $(id).DataTable({",
        "                 'data': dataset,",
        "                 'autoWidth': true,",
        "                 'deferRender': true,",
        "                 'info': false,",
        "                 'lengthChange': false,",
        "                 'ordering': d[n].length > 1,",
        "                 'order': [],",
        "                 'paging': false,",
        "                 'scrollX': false,",
        "                 'scrollY': false,",
        "                 'searching': false,",
        "                 'sortClasses': false,",
        "                 'rowCallback': rowCallback,",
        "                 'headerCallback': headerCallback,",
        "                 'columnDefs': [{targets: '_all', className: 'dt-center'}]",
        "               });",
        "  } else {",
        "    var subtable = $(id).DataTable({",
        "            'data': dataset,",
        "            'autoWidth': true,",
        "            'deferRender': true,",
        "            'info': false,",
        "            'lengthChange': false,",
        "            'ordering': d[n].length > 1,",
        "            'order': [],",
        "            'paging': false,",
        "            'scrollX': false,",
        "            'scrollY': false,",
        "            'searching': false,",
        "            'sortClasses': false,",
        "            'rowCallback': rowCallback,",
        "            'headerCallback': headerCallback,",
        "            '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",
        "table.on('click', 'td.details-control', function(){",
        "  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('&oplus;');",
        "  } else {",
        "    var childId = tblId + '-child-' + rowIdx;",
        "    row.child(format(row.data(), childId)).show();",
        "    td.html('&CircleMinus;');",
        "    format_datatable(row.data(), childId);",
        "  }",
        "});")
    
        output$my_table <- DT::renderDT({
            Dat <- market_mix_table()
            datatable(
                Dat, callback = callback, rownames = rowNames, escape = -colIdx-1,
                options = list(
                               columnDefs = list(
                                   list(visible = FALSE, targets = ncol(Dat)-1+colIdx),
                                   list(orderable = FALSE, className = 'details-control', targets = colIdx)
                                   
                               )
                )
            )
        })
    }
    
    # Run the application
    shinyApp(ui = ui, server = server)

Answer 1

dat0   = iris[1:3,]        # main table, with three rows
dat01  = airquality[1:4,]  # |- child of first row
dat02  = cars[1:2,]        # |- child of second row, with two rows
dat021 = mtcars[1:3,]      # |  |- child of first row of dat02
dat022 = PlantGrowth[1:4,] # |  |- child of second row of dat02
dat03  = data.frame(NULL)  # |- third row has no child

# add buttons
dat01 <- cbind(
  dat01, 
  "Click me" = as.character(htmltools::tags$button("Click me")),
  stringsAsFactors = FALSE
)

Dat <- NestedData(
  dat = dat0, 
  children = list(
    dat01, 
    list(  
      dat02, 
      children = list(
        dat021, 
        dat022
      )
    ), 
    dat03 
  )
)