Merge pull request #1616 from bigomics/gset-rowgroup

enable grouping by database of geneset table

Author: ivokwee

components/board.enrichment/R/enrichment_plot_top_enrich_gsets.R

@@ -96,12 +96,8 @@ enrichment_plot_top_enrich_gsets_server <- function(id,
       }
 
       ## selected
-      sel <- as.integer(gseatable$rows_selected())
-      sel.gs <- NULL
-      if (!is.null(sel) && length(sel) > 0) sel.gs <- rownames(rpt)[sel]
-
-      ii <- gseatable$rows_selected()
-      jj <- gseatable$rows_current()
+      ii <- gseatable$rownames_selected()
+      jj <- gseatable$rownames_current()
       shiny::req(jj)
 
       if (nrow(rpt) == 0) {

components/board.enrichment/R/enrichment_server.R

@@ -368,7 +368,7 @@ EnrichmentBoard <- function(id, pgx,
     ## Enrichment table
     ## ================================================================================
 
-    gset_selected <- shiny::reactive({
+    gset_selected.SAVE <- shiny::reactive({
       i <- as.integer(gseatable$rows_selected())
       if (is.null(i) || length(i) == 0) {
         return(NULL)
@@ -378,6 +378,14 @@ EnrichmentBoard <- function(id, pgx,
       return(gs)
     })
 
+    gset_selected <- shiny::reactive({
+      gs <- gseatable$rownames_selected()
+      if (is.null(gs) || length(gs) == 0) {
+        return(NULL)
+      }
+      return(gs)
+    })
+
     geneDetails <- shiny::reactive({
       ## return details of the genes in the selected gene set
       shiny::req(pgx$X, input$gs_contrast)

components/board.enrichment/R/enrichment_table_enrichment_analysis.R

@@ -15,12 +15,13 @@ enrichment_table_enrichment_analysis_ui <- function(
 
   gseatable_opts <- shiny::tagList(
     withTooltip(shiny::checkboxInput(ns("gs_showqvalues"), "Show individual q-values", FALSE),
-      "Show q-values of each statistical method in the table.",
-      placement = "top", options = list(container = "body")
+      "Show q-values of each statistical method in the table."
     ),
     withTooltip(shiny::checkboxInput(ns("show_scores"), "Show method-specific score", FALSE),
-      "Show enrichment score of each statistical method in the table.",
-      placement = "top", options = list(container = "body")
+      "Show enrichment score of each statistical method in the table."
+    ),
+    withTooltip(shiny::checkboxInput(ns("rowgroup"), "Group by database", FALSE),
+      "Groups genesets by database."
     )
   )
 
@@ -60,7 +61,7 @@ enrichment_table_enrichment_analysis_server <- function(id,
         return(NULL)
       }
 
-      if ("GS" %in% colnames(rpt)) rpt$GS <- playbase::shortstring(rpt$GS, 72)
+      if ("GS" %in% colnames(rpt)) rpt$GS <- playbase::shortstring(rpt$GS, 60)
       if ("size" %in% colnames(rpt)) rpt$size <- as.integer(rpt$size)
 
       fx <- NULL
@@ -91,17 +92,27 @@ enrichment_table_enrichment_analysis_server <- function(id,
       rpt$GS <- paste(rpt$GS, "&nbsp;", GS_link)
       colnames(rpt) <- sub("GS", "geneset", colnames(rpt))
 
+      if(input$rowgroup) {
+        db <- sub(":.*","",rownames(rpt))
+        rpt <- cbind( DB = db, rpt )
+        rpt <- rpt[order(rpt$DB, rpt$meta.q, -abs(rpt$logFC)), ]
+      }
+      
       is.numcol <- sapply(rpt, function(col) is.numeric(col) && !is.integer(col))
       numcols <- which(is.numcol & !colnames(rpt) %in% c("size"))
       numcols <- colnames(rpt)[numcols]
+      escapecols <- -1 * (match(c("geneset"), colnames(rpt)) + 0)
 
-
+      rowgroup.opt <- NULL
+      if(input$rowgroup) rowgroup.opt <- list(dataSrc = 0)
+      
       DT::datatable(rpt,
         class = "compact cell-border stripe hover",
         rownames = FALSE,
-        escape = c(-1, -2),
-        extensions = c("Scroller"),
-        plugins = "scrollResize",
+        #escape = c(-1, -2),
+        escape = escapecols,
+        extensions = c("Scroller","RowGroup"),
+        plugins = c("scrollResize","ellipsis"),
         fillContainer = TRUE,
         selection = list(mode = "single", target = "row", selected = 1),
         options = list(
@@ -113,10 +124,15 @@ enrichment_table_enrichment_analysis_server <- function(id,
           scrollResize = TRUE,
           scroller = TRUE,
           deferRender = TRUE,
+          rowGroup = rowgroup.opt,
           search = list(
             regex = TRUE,
             caseInsensitive = TRUE
-          )
+          ),
+          columnDefs = list(list(
+            targets = c("geneset"),
+            render = DT::JS("$.fn.dataTable.render.ellipsis( 60, false )")
+          ))          
         ) ## end of options.list
       ) %>%
         DT::formatSignif(numcols, 4) %>%