From 176cb411a669c57407aae9b12453a152b6ec5c04 Mon Sep 17 00:00:00 2001 From: ncullen93 Date: Tue, 14 Mar 2023 09:49:38 +0100 Subject: [PATCH 1/2] board.expression converted to pgx --- components/app/R/server.R | 56 ++++----- .../R/expression_plot_barplot.R | 13 +- .../R/expression_plot_maplot.R | 12 +- .../R/expression_plot_topfoldchange.R | 9 +- .../R/expression_plot_topgenes.R | 15 ++- .../R/expression_plot_volcanoAll.R | 9 +- .../R/expression_plot_volcanoMethods.R | 17 ++- .../board.expression/R/expression_server.R | 114 ++++++++---------- .../R/expression_table_FDRtable.R | 11 +- .../R/expression_table_fctable.R | 11 +- 10 files changed, 125 insertions(+), 142 deletions(-) diff --git a/components/app/R/server.R b/components/app/R/server.R index 9e9dffe43..f9a33bba1 100644 --- a/components/app/R/server.R +++ b/components/app/R/server.R @@ -182,102 +182,102 @@ app_server <- function(input, output, session) { }) shiny::withProgress(message="Preparing your dashboards...", value=0, { - + if(ENABLED['dataview']) { info("[server.R] calling module dataview") DataViewBoard("dataview", pgx=PGX) } - + if(ENABLED['clustersamples']) { info("[server.R] calling module clustersamples") ClusteringBoard("clustersamples", pgx=PGX) } - + if(ENABLED['wordcloud']) { info("[server.R] calling WordCloudBoard module") WordCloudBoard("wordcloud", pgx=PGX) } shiny::incProgress(0.2) - + if(ENABLED['diffexpr']) { info("[server.R] calling ExpressionBoard module") - ExpressionBoard("diffexpr", inputData=inputData) -> env$diffexpr + env$diffexpr <- ExpressionBoard("diffexpr", pgx=PGX) } if(ENABLED['clusterfeatures']) { info("[server.R] calling FeatureMapBoard module") FeatureMapBoard("clusterfeatures", inputData=inputData) } - + if(ENABLED['enrich']) { - info("[server.R] calling EnrichmentBoard module") + info("[server.R] calling EnrichmentBoard module") EnrichmentBoard("enrich", inputData = inputData, selected_gxmethods = env$diffexpr$selected_gxmethods ) -> env$enrich } if(ENABLED['pathway']) { - info("[server.R] calling FunctionalBoard module") + info("[server.R] calling FunctionalBoard module") FunctionalBoard("pathway", inputData = inputData, selected_gsetmethods = env$enrich$selected_gsetmethods) } - + shiny::incProgress(0.4) if(ENABLED['drug']) { - info("[server.R] calling DrugConnectivityBoard module") + info("[server.R] calling DrugConnectivityBoard module") DrugConnectivityBoard("drug", inputData = inputData) } - + if(ENABLED['isect']) { - info("[server.R] calling IntersectionBoard module") + info("[server.R] calling IntersectionBoard module") IntersectionBoard("isect", inputData = inputData, selected_gxmethods = env$diffexpr$selected_gxmethods, selected_gsetmethods = env$enrich$selected_gsetmethods) } - + if(ENABLED['sig']) { - info("[server.R] calling SignatureBoard module") + info("[server.R] calling SignatureBoard module") SignatureBoard("sig", inputData = inputData, selected_gxmethods = env$diffexpr$selected_gxmethods) } - + if(ENABLED['corr']) { info("[server.R] calling CorrelationBoard module") CorrelationBoard("corr", inputData = inputData) } shiny::incProgress(0.6) - + if(ENABLED['bio']) { - info("[server.R] calling BiomarkerBoard module") + info("[server.R] calling BiomarkerBoard module") BiomarkerBoard("bio", inputData = inputData) } - + if(ENABLED['cmap']) { - info("[server.R] calling ConnectivityBoard module") + info("[server.R] calling ConnectivityBoard module") ConnectivityBoard("cmap", inputData = inputData) } - + if(ENABLED['cell']) { - info("[server.R] calling SingleCellBoard module") + info("[server.R] calling SingleCellBoard module") SingleCellBoard("cell", inputData = inputData) } - + shiny::incProgress(0.8) if(ENABLED['tcga']) { - info("[server.R] calling TcgaBoard module") + info("[server.R] calling TcgaBoard module") TcgaBoard("tcga", inputData = inputData) } if(ENABLED['wgcna']) { - info("[server.R] calling WgcnaBoard module") + info("[server.R] calling WgcnaBoard module") WgcnaBoard("wgcna", inputData = inputData) } if(ENABLED['comp']) { - info("[server.R] calling CompareBoard module") + info("[server.R] calling CompareBoard module") CompareBoard("comp", inputData = inputData) } - info("[server.R] calling modules done!") + info("[server.R] calling modules done!") }) ## remove modal from LoadingBoard @@ -326,7 +326,7 @@ app_server <- function(input, output, session) { ## trigger on change dataset dbg("[server.R] trigger on change dataset") - + ## show beta feauture show.beta <- env$user$enable_beta() if(is.null(show.beta) || length(show.beta)==0) show.beta=FALSE @@ -492,7 +492,7 @@ Upgrade today and experience advanced analysis features without the time limit.< ## trigger on change of USER logged <- auth$logged() info("[server.R] change in user log status : logged = ",logged) - + ##--------- force logout callback??? -------------- if(opt$AUTHENTICATION!='firebase' && !logged) { ## Forcing logout ensures "clean" sessions. For firebase diff --git a/components/board.expression/R/expression_plot_barplot.R b/components/board.expression/R/expression_plot_barplot.R index ea6c05e73..286ad6de9 100644 --- a/components/board.expression/R/expression_plot_barplot.R +++ b/components/board.expression/R/expression_plot_barplot.R @@ -54,7 +54,7 @@ expression_plot_barplot_ui <- function(id, #' #' @param id #' @param comp -#' @param ngs +#' @param pgx #' @param sel #' @param res #' @param watermark @@ -64,7 +64,7 @@ expression_plot_barplot_ui <- function(id, #' @export expression_plot_barplot_server <- function(id, comp, - ngs, + pgx, sel, res, watermark = FALSE) { @@ -76,18 +76,17 @@ expression_plot_barplot_server <- function(id, grouped <- input$barplot_grouped logscale <- input$barplot_logscale showothers <- input$barplot_showothers - ngs <- ngs() sel <- sel() res <- res() psel <- rownames(res)[sel] - gene <- ngs$genes[1, "gene_name"] + gene <- pgx$genes[1, "gene_name"] - gene <- ngs$genes[psel, "gene_name"] + gene <- pgx$genes[psel, "gene_name"] srt <- ifelse(grouped, 0, 35) return(list( - ngs = ngs, + pgx = pgx, gene = gene, comp = comp, sel = sel, @@ -113,7 +112,7 @@ expression_plot_barplot_server <- function(id, } fig <- pgx.plotExpression( - pd[["ngs"]], + pd[["pgx"]], pd[["gene"]], comp = pd[["comp"]], grouped = pd[["grouped"]], diff --git a/components/board.expression/R/expression_plot_maplot.R b/components/board.expression/R/expression_plot_maplot.R index 6f404bb6e..6a7dfc2c2 100644 --- a/components/board.expression/R/expression_plot_maplot.R +++ b/components/board.expression/R/expression_plot_maplot.R @@ -41,7 +41,7 @@ expression_plot_maplot_ui <- function(id, #' @description A shiny Module for plotting (server code). #' #' @param id -#' @param inputData +#' @param pgx #' @param gx_fdr #' @param gx_contrast #' @param gx_lfc @@ -55,7 +55,7 @@ expression_plot_maplot_ui <- function(id, #' #' @export expression_plot_maplot_server <- function(id, - inputData, + pgx, gx_fdr, gx_contrast, gx_lfc, @@ -75,9 +75,7 @@ expression_plot_maplot_server <- function(id, if (length(comp1) == 0) { return(NULL) } - - ngs <- inputData() - shiny::req(ngs) + shiny::req(pgx) fdr <- as.numeric(gx_fdr()) lfc <- as.numeric(gx_lfc()) @@ -89,7 +87,7 @@ expression_plot_maplot_server <- function(id, fc.genes <- as.character(res[, grep("^gene$|gene_name", colnames(res))]) ## filter genes by gene family or gene set - fam.genes <- unique(unlist(ngs$families[10])) + fam.genes <- unique(unlist(pgx$families[10])) fam.genes <- res$gene_name if (gx_features() != "") { gset <- getGSETS(gx_features()) @@ -147,7 +145,7 @@ expression_plot_maplot_server <- function(id, } ylim <- c(-1, 1) * max(abs(y), na.rm = TRUE) - x <- rowMeans(ngs$X[rownames(res), ], na.rm = TRUE) + x <- rowMeans(pgx$X[rownames(res), ], na.rm = TRUE) impt <- function(g) { j <- match(g, fc.genes) diff --git a/components/board.expression/R/expression_plot_topfoldchange.R b/components/board.expression/R/expression_plot_topfoldchange.R index c62232349..5f1ff4c43 100644 --- a/components/board.expression/R/expression_plot_topfoldchange.R +++ b/components/board.expression/R/expression_plot_topfoldchange.R @@ -37,7 +37,7 @@ expression_plot_topfoldchange_ui <- function(id, #' #' @param id #' @param comp -#' @param ngs +#' @param pgx #' @param sel #' @param res #' @param watermark @@ -47,7 +47,7 @@ expression_plot_topfoldchange_ui <- function(id, #' @export expression_plot_topfoldchange_server <- function(id, comp, - ngs, + pgx, sel, res, watermark = FALSE) { @@ -56,12 +56,11 @@ expression_plot_topfoldchange_server <- function(id, plot_data <- shiny::reactive({ comp <- comp() # input$gx_contrast - ngs <- ngs() sel <- sel() res <- res() psel <- rownames(res)[sel] - gene <- ngs$genes[psel, "gene_name"] + gene <- pgx$genes[psel, "gene_name"] if (is.null(sel) || length(sel) == 0) { # Ugly return(list(sel = sel)) @@ -70,7 +69,7 @@ expression_plot_topfoldchange_server <- function(id, if (is.null(comp) || length(comp) == 0) { return(NULL) } - fc <- sapply(ngs$gx.meta$meta, function(x) x[psel, "meta.fx"]) + fc <- sapply(pgx$gx.meta$meta, function(x) x[psel, "meta.fx"]) top.up <- head(names(sort(fc[which(fc > 0)], decreasing = TRUE)), 10) top.dn <- head(names(sort(fc[which(fc < 0)], decreasing = FALSE)), 10) fc.top <- c(fc[top.up], fc[top.dn]) diff --git a/components/board.expression/R/expression_plot_topgenes.R b/components/board.expression/R/expression_plot_topgenes.R index 944cded0b..364542de6 100644 --- a/components/board.expression/R/expression_plot_topgenes.R +++ b/components/board.expression/R/expression_plot_topgenes.R @@ -54,7 +54,7 @@ expression_plot_topgenes_ui <- function(id, #' #' @param id #' @param comp -#' @param inputData +#' @param pgx #' @param res #' @param ii #' @param watermark @@ -64,7 +64,7 @@ expression_plot_topgenes_ui <- function(id, #' @export expression_plot_topgenes_server <- function(id, comp, - inputData, + pgx, res, ii, watermark = FALSE) { @@ -73,8 +73,7 @@ expression_plot_topgenes_server <- function(id, plot_data <- shiny::reactive({ comp <- comp() # input$gx_contrast - ngs <- inputData() - shiny::req(ngs) + shiny::req(pgx) res <- res() if (is.null(res) || nrow(res) == 0) { @@ -98,7 +97,7 @@ expression_plot_topgenes_server <- function(id, mar1 <- 3.5 ylab <- ifelse(logscale, "log2CPM", "CPM") - ny <- nrow(ngs$samples) ## ???!! + ny <- nrow(pgx$samples) ## ???!! show.names <- ifelse(!grouped & ny > 25, FALSE, TRUE) nx <- ifelse(grouped, 3, ny) nc <- 4 @@ -112,7 +111,7 @@ expression_plot_topgenes_server <- function(id, return(list( res = res, - ngs = ngs, + pgx = pgx, comp = comp, grouped = grouped, showothers = showothers, @@ -141,7 +140,7 @@ expression_plot_topgenes_server <- function(id, plts <- lapply(1:plots2show, function(x){ gene <- rownames(pd[["res"]])[x] pgx.plotExpression( - pd[["ngs"]], + pd[["pgx"]], # pd[["gene"]], gene, pd[["comp"]], @@ -178,7 +177,7 @@ expression_plot_topgenes_server <- function(id, ## gene = sub(".*:","",top.up[i]) # gene <- rownames(pd[["res"]])[i] # plt <- pgx.plotExpression( - # pd[["ngs"]], + # pd[["pgx"]], # # pd[["gene"]], # gene, # pd[["comp"]], diff --git a/components/board.expression/R/expression_plot_volcanoAll.R b/components/board.expression/R/expression_plot_volcanoAll.R index 610fdb4a3..7c60cfbc3 100644 --- a/components/board.expression/R/expression_plot_volcanoAll.R +++ b/components/board.expression/R/expression_plot_volcanoAll.R @@ -41,7 +41,7 @@ expression_plot_volcanoAll_ui <- function(id, #' @return #' @export expression_plot_volcanoAll_server <- function(id, - inputData, + pgx, getAllContrasts, features, fdr, @@ -50,18 +50,17 @@ expression_plot_volcanoAll_server <- function(id, moduleServer(id, function(input, output, session) { # reactive function listening for changes in input plot_data <- shiny::reactive({ - ngs <- inputData() features <- features() - if (is.null(ngs)) { + if (is.null(pgx)) { return(NULL) } ct <- getAllContrasts() F <- ct$F Q <- ct$Q - ## comp = names(ngs$gx.meta$meta) + ## comp = names(pgx$gx.meta$meta) comp <- names(F) if (length(comp) == 0) { return(NULL) @@ -75,7 +74,7 @@ expression_plot_volcanoAll_server <- function(id, fdr <- as.numeric(fdr()) lfc <- as.numeric(lfc()) - sel.genes <- rownames(ngs$X) + sel.genes <- rownames(pgx$X) if (features != "") { gset <- getGSETS(features) sel.genes <- unique(unlist(gset)) diff --git a/components/board.expression/R/expression_plot_volcanoMethods.R b/components/board.expression/R/expression_plot_volcanoMethods.R index a18096cc1..2477db91d 100644 --- a/components/board.expression/R/expression_plot_volcanoMethods.R +++ b/components/board.expression/R/expression_plot_volcanoMethods.R @@ -42,7 +42,7 @@ expression_plot_volcanoMethods_ui <- function(id, #' @return #' @export expression_plot_volcanoMethods_server <- function(id, - inputData, + pgx, comp, # input$gx_contrast features, # input$gx_features fdr, # input$gx_fdr @@ -57,13 +57,12 @@ expression_plot_volcanoMethods_server <- function(id, if (is.null(comp)) { return(NULL) } - ngs <- inputData() - shiny::req(ngs) + shiny::req(pgx) if (is.null(features)) { return(NULL) } - comp <- names(ngs$gx.meta$meta)[1] + comp <- names(pgx$gx.meta$meta)[1] fdr <- as.numeric(fdr()) # fdr <- 1 lfc <- as.numeric(lfc()) # lfc <- 1 genes <- NULL @@ -73,7 +72,7 @@ expression_plot_volcanoMethods_server <- function(id, return( list( - ngs = ngs, + pgx = pgx, fdr = fdr, lfc = lfc, comp = comp, @@ -87,7 +86,7 @@ expression_plot_volcanoMethods_server <- function(id, shiny::req(pd) ## meta tables - mx <- pd[["ngs"]]$gx.meta$meta[[pd[["comp"]]]] + mx <- pd[["pgx"]]$gx.meta$meta[[pd[["comp"]]]] fc <- unclass(mx$fc) ## pv = unclass(mx$p) qv <- unclass(mx$q) @@ -95,11 +94,11 @@ expression_plot_volcanoMethods_server <- function(id, ymax <- max(3, 1.2 * quantile(nlq, probs = 0.999, na.rm = TRUE)[1]) ## y-axis xlim <- c(-1.1, 1.1) * max(abs(fc)) xlim <- 1.3 * c(-1, 1) * quantile(abs(fc), probs = 0.999) - fc.genes <- pd[["ngs"]]$genes[rownames(mx), "gene_name"] + fc.genes <- pd[["pgx"]]$genes[rownames(mx), "gene_name"] nplots <- min(24, ncol(qv)) - ## methods = names(ngs$gx.meta$output) - methods <- colnames(pd[["ngs"]]$gx.meta$meta[[1]]$fc) + ## methods = names(pgx$gx.meta$output) + methods <- colnames(pd[["pgx"]]$gx.meta$meta[[1]]$fc) nc <- 6 par(mfrow = c(2, 6), mar = c(4, 4, 2, 2) * 0, oma = c(1, 1, 0, 0) * 2) if (nplots > 12) { diff --git a/components/board.expression/R/expression_server.R b/components/board.expression/R/expression_server.R index 15555797d..8b6ed17e6 100644 --- a/components/board.expression/R/expression_server.R +++ b/components/board.expression/R/expression_server.R @@ -3,7 +3,7 @@ ## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. ## -ExpressionBoard <- function(id, inputData) { +ExpressionBoard <- function(id, pgx) { moduleServer(id, function(input, output, session) { ns <- session$ns ## NAMESPACE @@ -47,16 +47,16 @@ ExpressionBoard <- function(id, inputData) { ## update choices upon change of data set shiny::observe({ - ngs <- inputData() - shiny::req(ngs) + pgx <- pgx + shiny::req(pgx) - contr <- colnames(ngs$model.parameters$contr.matrix) + contr <- colnames(pgx$model.parameters$contr.matrix) shiny::updateSelectInput(session, "gx_contrast", choices = sort(contr)) - fam <- pgx.getFamilies(ngs, nmin = 10, extended = FALSE) + fam <- pgx.getFamilies(pgx, nmin = 10, extended = FALSE) shiny::updateSelectInput(session, "gx_features", choices = fam) ## available statistical methods - gx.methods <- colnames(ngs$gx.meta$meta[[1]]$fc) ## available + gx.methods <- colnames(pgx$gx.meta$meta[[1]]$fc) ## available sel1 <- c(intersect(GX.DEFAULTTEST, gx.methods), gx.methods) sel1 <- head(unique(sel1), 3) ## maximum three!! @@ -65,7 +65,7 @@ ExpressionBoard <- function(id, inputData) { selected = sel1 ) - shiny::updateCheckboxInput(session, "gx_ungroup", value = (ncol(ngs$X) <= 8)) + shiny::updateCheckboxInput(session, "gx_ungroup", value = (ncol(pgx$X) <= 8)) }) @@ -88,9 +88,8 @@ ExpressionBoard <- function(id, inputData) { selected_gxmethods <- shiny::reactive({ - ngs <- inputData() - req(ngs) - gx.methods0 <- colnames(ngs$gx.meta$meta[[1]]$fc) + req(pgx) + gx.methods0 <- colnames(pgx$gx.meta$meta[[1]]$fc) test <- input$gx_statmethod test <- intersect(test, gx.methods0) test @@ -106,11 +105,10 @@ ExpressionBoard <- function(id, inputData) { comparison <- 1 testmethods <- c("trend.limma") add.pq <- 0 - getDEGtable <- function(ngs, testmethods, comparison, add.pq, + getDEGtable <- function(pgx, testmethods, comparison, add.pq, lfc, fdr) { - ## ngs = inputData() - ## if(is.null(ngs)) return(NULL) - shiny::req(ngs) + ## if(is.null(pgx)) return(NULL) + shiny::req(pgx) if (is.null(testmethods)) { return(NULL) @@ -126,7 +124,7 @@ ExpressionBoard <- function(id, inputData) { } ## build meta table - mx <- ngs$gx.meta$meta[[comparison]] + mx <- pgx$gx.meta$meta[[comparison]] if (is.null(mx)) { return(NULL) } @@ -161,13 +159,13 @@ ExpressionBoard <- function(id, inputData) { stars <- sapply(rowSums(is.sig, na.rm = TRUE), star.symbols) ## recalculate group averages??? - y0 <- ngs$model.parameters$exp.matrix[, comparison] - names(y0) <- rownames(ngs$model.parameters$exp.matrix) - AveExpr1 <- rowMeans(ngs$X[rownames(mx), names(which(y0 > 0)), drop = FALSE]) - AveExpr0 <- rowMeans(ngs$X[rownames(mx), names(which(y0 < 0)), drop = FALSE]) + y0 <- pgx$model.parameters$exp.matrix[, comparison] + names(y0) <- rownames(pgx$model.parameters$exp.matrix) + AveExpr1 <- rowMeans(pgx$X[rownames(mx), names(which(y0 > 0)), drop = FALSE]) + AveExpr0 <- rowMeans(pgx$X[rownames(mx), names(which(y0 < 0)), drop = FALSE]) - ## logFC <- unclass(ngs$gx.meta$meta[[comparison]][,"fc"])[,"trend.limma"] - ## logFC <- ngs$gx.meta$meta[[comparison]][,"meta.fx"] + ## logFC <- unclass(pgx$gx.meta$meta[[comparison]][,"fc"])[,"trend.limma"] + ## logFC <- pgx$gx.meta$meta[[comparison]][,"meta.fx"] logFC <- mx$meta.fx ## logFC <- (AveExpr1 - AveExpr0) ## override ??? yes: see "contrast in R" Rose Maier 2015... ## [hack] adjust averages to match logFC... @@ -176,8 +174,8 @@ ExpressionBoard <- function(id, inputData) { AveExpr0 <- mean0 - logFC / 2 ## gene.annot = mx[,grep("^gene|^chr",colnames(mx)),drop=FALSE] - aa <- intersect(c("gene_name", "gene_title", "chr"), colnames(ngs$genes)) - gene.annot <- ngs$genes[rownames(mx), aa] + aa <- intersect(c("gene_name", "gene_title", "chr"), colnames(pgx$genes)) + gene.annot <- pgx$genes[rownames(mx), aa] gene.annot$chr <- sub("_.*", "", gene.annot$chr) ## strip any alt postfix res <- data.frame(gene.annot, logFC = logFC, @@ -197,8 +195,7 @@ ExpressionBoard <- function(id, inputData) { fullDiffExprTable <- shiny::reactive({ ## return the full DE table - ngs <- inputData() - if (is.null(ngs)) { + if (is.null(pgx)) { return(NULL) } comp <- 1 @@ -216,7 +213,7 @@ ExpressionBoard <- function(id, inputData) { if (is.null(tests)) { return(NULL) } - res <- getDEGtable(ngs, + res <- getDEGtable(pgx, testmethods = tests, comparison = comp, add.pq = TRUE, lfc = lfc, fdr = fdr ) @@ -228,7 +225,7 @@ ExpressionBoard <- function(id, inputData) { if (gx_features != "") { ## gset <- GSETS[[gx_features]] gset <- unlist(getGSETS(gx_features)) - psel <- filterProbes(ngs$genes, gset) + psel <- filterProbes(pgx$genes, gset) } res <- res[which(rownames(res) %in% psel), , drop = FALSE] dim(res) @@ -242,9 +239,8 @@ ExpressionBoard <- function(id, inputData) { ## DE table filtered by FDR and gene family ## ## - ngs <- inputData() - ## if(is.null(ngs)) return(NULL) - shiny::req(ngs, input$gx_features, input$gx_fdr, input$gx_lfc) + ## if(is.null(pgx)) return(NULL) + shiny::req(pgx, input$gx_features, input$gx_fdr, input$gx_lfc) comp <- 1 test <- "trend.limma" @@ -253,8 +249,8 @@ ExpressionBoard <- function(id, inputData) { fdr <- as.numeric(input$gx_fdr) lfc <- as.numeric(input$gx_lfc) - ## res = getDEGtable(ngs, testmethods="trend.limma", comparison=1,add.pq=FALSE) - ## res = getDEGtable(ngs, testmethods=tests, comparison=comp, + ## res = getDEGtable(pgx, testmethods="trend.limma", comparison=1,add.pq=FALSE) + ## res = getDEGtable(pgx, testmethods=tests, comparison=comp, ## add.pq=TRUE, lfc=lfc, fdr=fdr, filter.sig=FALSE) res <- fullDiffExprTable() if (is.null(res) || nrow(res) == 0) { @@ -314,7 +310,7 @@ ExpressionBoard <- function(id, inputData) { expression_plot_maplot_server( id = "plots_maplot", - inputData = inputData, + pgx = pgx, gx_fdr = reactive(input$gx_fdr), gx_contrast = reactive(input$gx_contrast), gx_lfc = reactive(input$gx_lfc), @@ -331,7 +327,7 @@ ExpressionBoard <- function(id, inputData) { expression_plot_barplot_server( id = "plots_barplot", comp = shiny::reactive(input$gx_contrast), - ngs = inputData, + pgx = pgx, sel = genetable_rows_selected, res = filteredDiffExprTable, watermark = FALSE @@ -340,7 +336,7 @@ ExpressionBoard <- function(id, inputData) { expression_plot_topfoldchange_server( id = "plots_topfoldchange", comp = shiny::reactive(input$gx_contrast), - ngs = inputData, + pgx = pgx, sel = genetable_rows_selected, res = filteredDiffExprTable, watermark = FALSE @@ -349,11 +345,10 @@ ExpressionBoard <- function(id, inputData) { # tab differential expression > Top genes #### getAllContrasts <- shiny::reactive({ - ngs <- inputData() - if (is.null(ngs)) { + if (is.null(pgx)) { return(NULL) } - comp <- names(ngs$gx.meta$meta) + comp <- names(pgx$gx.meta$meta) if (length(comp) == 0) { return(NULL) } @@ -362,7 +357,7 @@ ExpressionBoard <- function(id, inputData) { ## fdr=1;lfc=0 ## fdr = as.numeric(input$gx_fdr) ## lfc = as.numeric(input$gx_lfc) - tests <- colnames(ngs$gx.meta$meta[[1]]$p) + tests <- colnames(pgx$gx.meta$meta[[1]]$p) tests <- input$gx_statmethod if (is.null(tests)) { return(NULL) @@ -374,7 +369,7 @@ ExpressionBoard <- function(id, inputData) { Q <- list() shiny::withProgress(message = "computing contrasts ...", value = 0, { for (i in 1:length(comp)) { - res <- getDEGtable(ngs, + res <- getDEGtable(pgx, testmethods = tests, comparison = comp[i], add.pq = FALSE, lfc = 0, fdr = 1 ) @@ -400,7 +395,7 @@ ExpressionBoard <- function(id, inputData) { expression_plot_topgenes_server( id = "topgenes", comp = shiny::reactive(input$gx_contrast), - inputData = inputData, + pgx = pgx, res = filteredDiffExprTable, ii = genetable$rows_current, watermark = FALSE @@ -410,7 +405,7 @@ ExpressionBoard <- function(id, inputData) { expression_plot_volcanoAll_server( id = "volcanoAll", - inputData = inputData, + pgx = pgx, getAllContrasts = getAllContrasts, features = shiny::reactive(input$gx_features), fdr = shiny::reactive(input$gx_fdr), @@ -422,7 +417,7 @@ ExpressionBoard <- function(id, inputData) { expression_plot_volcanoMethods_server( id = "volcanoMethods", - inputData = inputData, + pgx = pgx, comp = shiny::reactive(input$gx_contrast), features = shiny::reactive(input$gx_features), fdr = shiny::reactive(input$gx_fdr), @@ -435,7 +430,6 @@ ExpressionBoard <- function(id, inputData) { # rendering tables #### gx_related_genesets <- shiny::reactive({ - ngs <- inputData() res <- filteredDiffExprTable() if (is.null(res) || nrow(res) == 0) { return(NULL) @@ -454,18 +448,18 @@ ExpressionBoard <- function(id, inputData) { gene0 <- rownames(res)[sel.row] gene1 <- toupper(sub(".*:", "", gene0)) ## always uppercase... - j <- which(toupper(rownames(ngs$GMT)) == gene1) - gset <- names(which(ngs$GMT[j, ] != 0)) - gset <- intersect(gset, rownames(ngs$gsetX)) + j <- which(toupper(rownames(pgx$GMT)) == gene1) + gset <- names(which(pgx$GMT[j, ] != 0)) + gset <- intersect(gset, rownames(pgx$gsetX)) if (length(gset) == 0) { return(NULL) } - fx <- ngs$gset.meta$meta[[contr]]$meta.fx - names(fx) <- rownames(ngs$gset.meta$meta[[contr]]) + fx <- pgx$gset.meta$meta[[contr]]$meta.fx + names(fx) <- rownames(pgx$gset.meta$meta[[contr]]) fx <- round(fx[gset], digits = 4) - rho <- cor(t(ngs$gsetX[gset, ]), ngs$X[gene0, ])[, 1] + rho <- cor(t(pgx$gsetX[gset, ]), pgx$X[gene0, ])[, 1] rho <- round(rho, digits = 3) gset1 <- substring(gset, 1, 60) @@ -492,7 +486,7 @@ ExpressionBoard <- function(id, inputData) { expression_table_fctable_server( id = "fctable", - ngs = inputData, + pgx = pgx, res = filteredDiffExprTable, metaFC = metaFC, metaQ = metaQ, @@ -503,7 +497,7 @@ ExpressionBoard <- function(id, inputData) { expression_table_FDRtable_server( id = "FDRtable", - ngs = inputData, + pgx = pgx, methods = shiny::reactive(input$gx_statmethod), tabV = tabV, height = c(tabH, 700), @@ -513,21 +507,19 @@ ExpressionBoard <- function(id, inputData) { # reactive values to return to parent environment ######### metaQ <- shiny::reactive({ - ngs <- inputData() - req(ngs) + req(pgx) methods <- selected_gxmethods() - metaQ <- sapply(ngs$gx.meta$meta, function(m) apply(m$q[, methods, drop = FALSE], 1, max, na.rm = TRUE)) - rownames(metaQ) <- rownames(ngs$gx.meta$meta[[1]]) + metaQ <- sapply(pgx$gx.meta$meta, function(m) apply(m$q[, methods, drop = FALSE], 1, max, na.rm = TRUE)) + rownames(metaQ) <- rownames(pgx$gx.meta$meta[[1]]) metaQ }) metaFC <- shiny::reactive({ - ngs <- inputData() - req(ngs) + req(pgx) methods <- selected_gxmethods() - ## metaFC <- sapply(ngs$gx.meta$meta, function(m) rowMeans(m$fc[,methods,drop=FALSE])) - metaFC <- sapply(ngs$gx.meta$meta, function(m) m$meta.fx) - rownames(metaFC) <- rownames(ngs$gx.meta$meta[[1]]) + ## metaFC <- sapply(pgx$gx.meta$meta, function(m) rowMeans(m$fc[,methods,drop=FALSE])) + metaFC <- sapply(pgx$gx.meta$meta, function(m) m$meta.fx) + rownames(metaFC) <- rownames(pgx$gx.meta$meta[[1]]) metaFC }) diff --git a/components/board.expression/R/expression_table_FDRtable.R b/components/board.expression/R/expression_table_FDRtable.R index 4e1b81aea..5cd353d0e 100644 --- a/components/board.expression/R/expression_table_FDRtable.R +++ b/components/board.expression/R/expression_table_FDRtable.R @@ -32,7 +32,7 @@ expression_table_FDRtable_ui <- function(id, width, height) { #' #' @export expression_table_FDRtable_server <- function(id, - ngs, + pgx, methods, # input$gx_statmethod tabV, height, # c(tabH, 700) @@ -49,12 +49,11 @@ expression_table_FDRtable_server <- function(id, } ## comp <- input$gx_contrast - ngs <- ngs() - kk <- rownames(ngs$gx.meta$sig.counts[[1]][[1]]) - kk <- intersect(methods, rownames(ngs$gx.meta$sig.counts[[1]][[1]])) - counts.up <- ngs$gx.meta$sig.counts$up - counts.down <- ngs$gx.meta$sig.counts$down + kk <- rownames(pgx$gx.meta$sig.counts[[1]][[1]]) + kk <- intersect(methods, rownames(pgx$gx.meta$sig.counts[[1]][[1]])) + counts.up <- pgx$gx.meta$sig.counts$up + counts.down <- pgx$gx.meta$sig.counts$down counts.up <- lapply(counts.up, function(x) x[kk, , drop = FALSE]) counts.down <- lapply(counts.down, function(x) x[kk, , drop = FALSE]) for (i in 1:length(counts.up)) { diff --git a/components/board.expression/R/expression_table_fctable.R b/components/board.expression/R/expression_table_fctable.R index 1280f88b3..3f82d8605 100644 --- a/components/board.expression/R/expression_table_fctable.R +++ b/components/board.expression/R/expression_table_fctable.R @@ -40,7 +40,7 @@ expression_table_fctable_ui <- function(id, width, height) { #' #' @export expression_table_fctable_server <- function(id, - ngs, # inputData() + pgx, # inputData() res, # filteredDiffExprTable metaFC, metaQ, @@ -51,16 +51,15 @@ expression_table_fctable_server <- function(id, ns <- session$ns fctable.RENDER <- shiny::reactive({ - ngs <- ngs() res <- res() if (is.null(res) || nrow(res) == 0) { return(NULL) } - ## F <- sapply(ngs$gx.meta$meta, function(x) unclass(x$fc)[,"trend.limma"]) - ## Q <- sapply(ngs$gx.meta$meta, function(x) x$meta.q) - ## F <- sapply(ngs$gx.meta$meta, function(x) x$meta.fx) - ## rownames(F)=rownames(Q)=rownames(ngs$gx.meta$meta[[1]]) + ## F <- sapply(pgx$gx.meta$meta, function(x) unclass(x$fc)[,"trend.limma"]) + ## Q <- sapply(pgx$gx.meta$meta, function(x) x$meta.q) + ## F <- sapply(pgx$gx.meta$meta, function(x) x$meta.fx) + ## rownames(F)=rownames(Q)=rownames(pgx$gx.meta$meta[[1]]) F <- metaFC() Q <- metaQ() From 0e0e71b7a958cf41abfd3632af310b3eeb85b033 Mon Sep 17 00:00:00 2001 From: ncullen93 Date: Tue, 14 Mar 2023 09:56:53 +0100 Subject: [PATCH 2/2] expression board to pgx --- components/app/R/server.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/components/app/R/server.R b/components/app/R/server.R index f9a33bba1..bc7bd956a 100644 --- a/components/app/R/server.R +++ b/components/app/R/server.R @@ -201,7 +201,7 @@ app_server <- function(input, output, session) { if(ENABLED['diffexpr']) { info("[server.R] calling ExpressionBoard module") - env$diffexpr <- ExpressionBoard("diffexpr", pgx=PGX) + ExpressionBoard("diffexpr", pgx=PGX) -> env$diffexpr } if(ENABLED['clusterfeatures']) {