adding additional buttons to nested data table in R shiny

Question

Is there a way to add additional action buttons to both parent and child rows in a nested data table? I've tried adding the buttons via JS and the Shiny side, but it doesn't seem to work. Any suggestions? Most of the code was borrowed from this post: Matching Parent/Child data up in a DataTable in R Shiny app Thanks

    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)

What is the difficulty? You just have to put `as.character(actionButton(......` in the cells you want. — Stéphane Laurent, Oct 17 '20 at 16:14
Do you know of an example I can refer to? also, does escape = FALSE for this to work? I've tried this method: https://stackoverflow.com/questions/45739303/r-shiny-handle-action-buttons-in-data-table thanks — user3781528, Oct 17 '20 at 16:26
Moreover there are unnecessary library() calls in your code. Please remove them. — Stéphane Laurent, Oct 20 '20 at 02:35
I'm having the same problem, it can't find Dat in `which(Dat[,1]!= "")` for some reason. It worked earlier. — user3781528, Oct 22 '20 at 03:26

score 1 · Answer 1 · answered Oct 21 '20 at 17:28

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

adding additional buttons to nested data table in R shiny

1 Answers1