board.intersection: ngs + inputData -> pgx

bigomics · Mar 14, 2023 · fb7cd2b · fb7cd2b
1 parent ff18b5e
commit fb7cd2b
Show file tree

Hide file tree

Showing 6 changed files with 54 additions and 66 deletions.
diff --git a/components/app/R/server.R b/components/app/R/server.R
@@ -229,7 +229,7 @@ app_server <- function(input, output, session) {
 
           if(ENABLED['isect']) {
             info("[server.R] calling IntersectionBoard module")
-            IntersectionBoard("isect", inputData = inputData,
+            IntersectionBoard("isect", pgx = PGX,
               selected_gxmethods = env$diffexpr$selected_gxmethods,
               selected_gsetmethods = env$enrich$selected_gsetmethods)
           }

diff --git a/components/board.intersection/R/intersection_plot_contrast_correlation.R b/components/board.intersection/R/intersection_plot_contrast_correlation.R
@@ -42,13 +42,12 @@ contrast_correlation_ui <- function(id, label = "", height = c(600, 800)) {
 
 contrast_correlation_server <- function(id,
                                         getFoldChangeMatrix,
-                                        inputData,
+                                        pgx,
                                         input_comparisons,
                                         watermark = FALSE) {
   moduleServer(id, function(input, output, session) {
     plot_data <- shiny::reactive({
-      ngs <- inputData()
-      shiny::req(ngs)
+      shiny::req(pgx)
 
       res <- getFoldChangeMatrix()
       if (is.null(res)) {
@@ -125,11 +124,10 @@ contrast_correlation_server <- function(id,
 
 # ctcorrplot.PLOT <- shiny::reactive({
 #
-#     ngs <- inputData()
-#     shiny::req(ngs)
+#     shiny::req(pgx)
 #     shiny::req(input$comparisons)
 #
-#     ## res <- pgx.getMetaFoldChangeMatrix(ngs, what="meta")
+#     ## res <- pgx.getMetaFoldChangeMatrix(pgx, what="meta")
 #     res <- getFoldChangeMatrix()
 #
 #     if(is.null(res)) return(NULL)

diff --git a/components/board.intersection/R/intersection_plot_foldchange_heatmap.R b/components/board.intersection/R/intersection_plot_foldchange_heatmap.R
@@ -43,12 +43,11 @@ foldchange_heatmap_ui <- function(id, label = "", height = c(600, 800)) {
 foldchange_heatmap_server <- function(id,
                                       getFoldChangeMatrix,
                                       getActiveFoldChangeMatrix,
-                                      inputData,
+                                      pgx,
                                       level,
                                       watermark = FALSE) {
   moduleServer(id, function(input, output, session) {
     plot_data <- shiny::reactive({
-      ngs <- inputData()
       if (input$FoldchangeHeatmap_allfc) {
         F <- getFoldChangeMatrix()$fc
       } else {

diff --git a/components/board.intersection/R/intersection_plot_scatterplot_pairs.R b/components/board.intersection/R/intersection_plot_scatterplot_pairs.R
@@ -32,7 +32,7 @@ intersection_scatterplot_pairs_ui <- function(id, label = "", height = c(600, 80
 intersection_scatterplot_pairs_server <- function(id,
                                                   getActiveFoldChangeMatrix,
                                                   level,
-                                                  inputData,
+                                                  pgx,
                                                   watermark = FALSE) {
   moduleServer(id, function(input, output, session) {
     plot_data <- shiny::reactive({
@@ -106,9 +106,8 @@ intersection_scatterplot_pairs_server <- function(id,
       ## tt <- sub("","",tt)  ## strip prefix??
       # if(input$level == "gene") {
       if (level == "gene") {
-        ngs <- inputData()
         g <- rownames(df)
-        tt <- paste0("<b>", g, "</b> ", ngs$genes[g, "gene_title"])
+        tt <- paste0("<b>", g, "</b> ", pgx$genes[g, "gene_title"])
       }
       tt <- gsub("_", " ", tt)
       tt <- sapply(tt, breakstring2, 50, brk = "<br>")

diff --git a/components/board.intersection/R/intersection_plot_table_venn_diagram.R b/components/board.intersection/R/intersection_plot_table_venn_diagram.R
@@ -61,7 +61,7 @@ intersection_plot_venn_diagram_ui <- function(id, label = "", height = c(600, 80
 
 
 intersection_plot_venn_diagram_server <- function(id,
-                                                  inputData,
+                                                  pgx,
                                                   level,
                                                   input_comparisons,
                                                   getFoldChangeMatrix,
@@ -209,11 +209,10 @@ intersection_plot_venn_diagram_server <- function(id,
     getSignificanceCalls <- shiny::reactive({
       ## Gets the matrix of significance calls.
       ##
-      ngs <- inputData()
 
-      sel <- head(names(ngs$gset.meta$meta), 7)
+      sel <- head(names(pgx$gset.meta$meta), 7)
       sel <- input_comparisons()
-      sel <- intersect(sel, names(ngs$gset.meta$meta))
+      sel <- intersect(sel, names(pgx$gset.meta$meta))
       if (length(sel) == 0) {
         return(NULL)
       }
@@ -328,8 +327,7 @@ intersection_plot_venn_diagram_server <- function(id,
     })
 
     venntable.RENDER <- shiny::reactive({
-      ngs <- inputData()
-      shiny::req(ngs)
+      shiny::req(pgx)
 
       ## get foldchanges
       fc0 <- getSignificantFoldChangeMatrix() ## isolate??
@@ -339,7 +337,7 @@ intersection_plot_venn_diagram_server <- function(id,
 
       ## add gene name/title
       if (level == "gene") {
-        gene <- as.character(ngs$genes[rownames(fc0), "gene_name"])
+        gene <- as.character(pgx$genes[rownames(fc0), "gene_name"])
         gene.tt <- substring(GENE.TITLE[gene], 1, 50)
         gene.tt <- as.character(gene.tt)
         ## fc0 = data.frame( name=name, title=gene.tt, fc0)

diff --git a/components/board.intersection/R/intersection_server.R b/components/board.intersection/R/intersection_server.R
@@ -3,7 +3,7 @@
 ## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved.
 ##
 
-IntersectionBoard <- function(id, inputData, selected_gxmethods, selected_gsetmethods) {
+IntersectionBoard <- function(id, pgx, selected_gxmethods, selected_gsetmethods) {
   moduleServer(id, function(input, output, session) {
     ns <- session$ns ## NAMESPACE
     fullH <- 800 # row height of panel
@@ -37,12 +37,11 @@ IntersectionBoard <- function(id, inputData, selected_gxmethods, selected_gsetme
 
     ## update choices upon change of data set
     shiny::observe({
-      ngs <- inputData()
-      ## req(ngs)
-      if (is.null(ngs)) {
+      ## req(pgx)
+      if (is.null(pgx)) {
         return(NULL)
       }
-      comparisons <- colnames(ngs$model.parameters$contr.matrix)
+      comparisons <- colnames(pgx$model.parameters$contr.matrix)
       comparisons <- sort(comparisons)
       shiny::updateSelectInput(session, "comparisons",
         choices = comparisons,
@@ -53,20 +52,19 @@ IntersectionBoard <- function(id, inputData, selected_gxmethods, selected_gsetme
     ## update choices upon change of feature level
     ## observeEvent( input$level, {
     shiny::observe({
-      ngs <- inputData()
-      ## shiny::req(ngs,input$level)
-      if (is.null(ngs)) {
+      ## shiny::req(pgx,input$level)
+      if (is.null(pgx)) {
         return(NULL)
       }
       shiny::req(input$level)
-      ## flt.choices = names(ngs$families)
+      ## flt.choices = names(pgx$families)
       if (input$level == "geneset") {
         ft <- names(COLLECTIONS)
-        nn <- sapply(COLLECTIONS, function(x) sum(x %in% rownames(ngs$gsetX)))
+        nn <- sapply(COLLECTIONS, function(x) sum(x %in% rownames(pgx$gsetX)))
         ft <- ft[nn >= 10]
       } else {
         ## gene level
-        ft <- pgx.getFamilies(ngs, nmin = 10, extended = FALSE)
+        ft <- pgx.getFamilies(pgx, nmin = 10, extended = FALSE)
       }
       ft <- sort(ft)
       ## if(input$level=="gene") ft = sort(c("<custom>",ft))
@@ -91,19 +89,18 @@ IntersectionBoard <- function(id, inputData, selected_gxmethods, selected_gsetme
 
     getFoldChangeMatrix <- shiny::reactive({
       ##
-      ## Get full foldchange matrix from ngs object.
+      ## Get full foldchange matrix from pgx object.
       ##
       ##
       ##
       fc0 <- NULL
       qv0 <- NULL
-      ngs <- inputData()
-      alertDataLoaded(session, ngs)
-      shiny::req(ngs)
+      alertDataLoaded(session, pgx)
+      shiny::req(pgx)
 
-      sel <- names(ngs$gset.meta$meta)
+      sel <- names(pgx$gset.meta$meta)
       ## sel = input_comparisons()
-      ## sel = intersect(sel, names(ngs$gset.meta$meta))
+      ## sel = intersect(sel, names(pgx$gset.meta$meta))
       ## if(length(sel)==0) return(NULL)
 
       if (input$level == "geneset") {
@@ -113,21 +110,21 @@ IntersectionBoard <- function(id, inputData, selected_gxmethods, selected_gsetme
           return(NULL)
         }
 
-        ## fc0 = sapply(ngs$gset.meta$meta[sel], function(x)
+        ## fc0 = sapply(pgx$gset.meta$meta[sel], function(x)
         ##    rowMeans(unclass(x$fc)[,gsetmethods,drop=FALSE]))
-        fc0 <- sapply(ngs$gset.meta$meta[sel], function(x) x$meta.fx)
-        rownames(fc0) <- rownames(ngs$gset.meta$meta[[1]])
-        qv0 <- sapply(ngs$gset.meta$meta[sel], function(x) {
+        fc0 <- sapply(pgx$gset.meta$meta[sel], function(x) x$meta.fx)
+        rownames(fc0) <- rownames(pgx$gset.meta$meta[[1]])
+        qv0 <- sapply(pgx$gset.meta$meta[sel], function(x) {
           apply(unclass(x$q)[, gsetmethods, drop = FALSE], 1, max)
         })
-        rownames(qv0) <- rownames(ngs$gset.meta$meta[[1]])
+        rownames(qv0) <- rownames(pgx$gset.meta$meta[[1]])
 
         ## apply user selected filter
         gsets <- rownames(fc0)
         if (input$filter == "<custom>") {
           gsets <- strsplit(input$customlist, split = "[, ;]")[[1]]
           if (length(gsets) > 0) {
-            gsets <- intersect(rownames(ngs$gsetX), gsets)
+            gsets <- intersect(rownames(pgx$gsetX), gsets)
           }
         } else if (input$filter != "<all>") {
           gsets <- unique(unlist(COLLECTIONS[input$filter]))
@@ -142,18 +139,18 @@ IntersectionBoard <- function(id, inputData, selected_gxmethods, selected_gsetme
         gxmethods <- c("trend.limma", "edger.qlf", "deseq2.wald")
         gxmethods <- selected_gxmethods() ## reactive object from EXPRESSION section
 
-        mq1 <- ngs$gx.meta$meta[[1]]$meta.q
+        mq1 <- pgx$gx.meta$meta[[1]]$meta.q
 
         if (length(gxmethods) < 1 || gxmethods[1] == "") {
           return(NULL)
         }
 
-        fc0 <- sapply(ngs$gx.meta$meta[sel], function(x) x$meta.fx)
-        rownames(fc0) <- rownames(ngs$gx.meta$meta[[1]])
-        qv0 <- sapply(ngs$gx.meta$meta[sel], function(x) {
+        fc0 <- sapply(pgx$gx.meta$meta[sel], function(x) x$meta.fx)
+        rownames(fc0) <- rownames(pgx$gx.meta$meta[[1]])
+        qv0 <- sapply(pgx$gx.meta$meta[sel], function(x) {
           apply(unclass(x$q)[, gxmethods, drop = FALSE], 1, max)
         })
-        rownames(qv0) <- rownames(ngs$gx.meta$meta[[1]])
+        rownames(qv0) <- rownames(pgx$gx.meta$meta[[1]])
         dim(fc0)
         dim(qv0)
 
@@ -162,12 +159,12 @@ IntersectionBoard <- function(id, inputData, selected_gxmethods, selected_gsetme
         if (input$filter == "<custom>") {
           genes <- strsplit(input$customlist, split = "[, ;]")[[1]]
           if (length(genes) > 0) {
-            sel.probes <- filterProbes(ngs$genes, genes)
+            sel.probes <- filterProbes(pgx$genes, genes)
           }
         } else if (input$filter != "<all>") {
           ## gset <- GSETS[[input$filter]]
           gset.genes <- unlist(getGSETS(input$filter))
-          sel.probes <- filterProbes(ngs$genes, gset.genes)
+          sel.probes <- filterProbes(pgx$genes, gset.genes)
         }
         sel.probes <- intersect(sel.probes, rownames(fc0))
         fc1 <- fc0[sel.probes, , drop = FALSE]
@@ -206,17 +203,16 @@ IntersectionBoard <- function(id, inputData, selected_gxmethods, selected_gsetme
       ## Switch between FC profile or NMF vectors
       ##
       ##
-      ngs <- inputData()
-      shiny::req(ngs)
+      shiny::req(pgx)
       progress <- shiny::Progress$new()
       on.exit(progress$close())
 
       ## ------------ UMAP clustering (genes) -----------------
       progress$inc(0.33, "calculating UMAP for genes...")
-      if ("cluster.genes" %in% names(ngs)) {
-        pos <- ngs$cluster.genes$pos[["umap2d"]]
+      if ("cluster.genes" %in% names(pgx)) {
+        pos <- pgx$cluster.genes$pos[["umap2d"]]
       } else {
-        X1 <- ngs$X
+        X1 <- pgx$X
         X1 <- (X1 - rowMeans(X1)) / mean(apply(X1, 1, sd, na.rm = TRUE))
         pos <- pgx.clusterBigMatrix(
           t(X1),
@@ -227,10 +223,10 @@ IntersectionBoard <- function(id, inputData, selected_gxmethods, selected_gsetme
 
       ## ------------ UMAP clustering (genesets) -----------------
       progress$inc(0.33, "calculating UMAP for genesets...")
-      if ("cluster.gsets" %in% names(ngs)) {
-        gsea.pos <- ngs$cluster.gsets$pos[["umap2d"]]
+      if ("cluster.gsets" %in% names(pgx)) {
+        gsea.pos <- pgx$cluster.gsets$pos[["umap2d"]]
       } else {
-        X2 <- ngs$gsetX
+        X2 <- pgx$gsetX
         X2 <- (X2 - rowMeans(X2)) / mean(apply(X2, 1, sd, na.rm = TRUE))
         gsea.pos <- pgx.clusterBigMatrix(
           t(X2),
@@ -241,8 +237,8 @@ IntersectionBoard <- function(id, inputData, selected_gxmethods, selected_gsetme
       }
 
       ## ------------ get signature matrices -----------------
-      F <- pgx.getMetaMatrix(ngs, level = "gene")
-      G <- pgx.getMetaMatrix(ngs, level = "geneset")
+      F <- pgx.getMetaMatrix(pgx, level = "gene")
+      G <- pgx.getMetaMatrix(pgx, level = "geneset")
       ## f.score <- F$fc * -log10(F$qv)
       ## g.score <- G$fc * -log10(G$qv)
       f.score <- F$fc * (1 - F$qv)**4 ## q-weighted FC
@@ -533,7 +529,6 @@ IntersectionBoard <- function(id, inputData, selected_gxmethods, selected_gsetme
     ## -------------------------------------------
 
     getGeneTable <- shiny::reactive({
-      ngs <- inputData()
       out <- getCurrentSig()
 
       W <- out$sig
@@ -548,7 +543,7 @@ IntersectionBoard <- function(id, inputData, selected_gxmethods, selected_gsetme
       }
 
       ## only genes
-      W <- W[rownames(W) %in% rownames(ngs$X), , drop = FALSE]
+      W <- W[rownames(W) %in% rownames(pgx$X), , drop = FALSE]
       W <- W[, sel0, drop = FALSE]
 
       tt <- NA
@@ -613,7 +608,6 @@ IntersectionBoard <- function(id, inputData, selected_gxmethods, selected_gsetme
     ## -------------------------------------------
 
     ctGseaTable.RENDER <- shiny::reactive({
-      ngs <- inputData()
       out <- getCurrentSig()
       df <- out$gsea
       sel0 <- input_comparisons()
@@ -674,7 +668,7 @@ IntersectionBoard <- function(id, inputData, selected_gxmethods, selected_gsetme
 
     intersection_plot_venn_diagram_server(
       "venndiagram",
-      inputData           = inputData,
+      pgx           = pgx,
       level               = input$level,
       input_comparisons   = input_comparisons,
       getFoldChangeMatrix = getFoldChangeMatrix,
@@ -685,7 +679,7 @@ IntersectionBoard <- function(id, inputData, selected_gxmethods, selected_gsetme
       "scatterplot",
       getActiveFoldChangeMatrix = getActiveFoldChangeMatrix,
       level                     = input$level,
-      inputData                 = inputData,
+      pgx                 = pgx,
       watermark                 = WATERMARK
     )
 
@@ -695,15 +689,15 @@ IntersectionBoard <- function(id, inputData, selected_gxmethods, selected_gsetme
       "FoldchangeHeatmap",
       getFoldChangeMatrix       = getFoldChangeMatrix,
       getActiveFoldChangeMatrix = getActiveFoldChangeMatrix,
-      inputData                 = inputData,
+      pgx                 = pgx,
       level                     = input$level,
       watermark                 = WATERMARK
     )
 
     contrast_correlation_server(
       "ctcorrplot",
       getFoldChangeMatrix = getFoldChangeMatrix,
-      inputData           = inputData,
+      pgx           = pgx,
       input_comparisons   = input_comparisons
     )
   })