From daf5a25a5563e3b56f9bcca86c6ceaa7deccbc73 Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Mon, 23 Jan 2023 09:30:11 +0100 Subject: [PATCH 01/32] updated height and width to match old codebase worked well in different resolutions, still overlapping with plot legend (to be fixed later) --- components/board.expression/R/expression_ui.R | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/components/board.expression/R/expression_ui.R b/components/board.expression/R/expression_ui.R index 2cc556f60..d5a6d2cf7 100644 --- a/components/board.expression/R/expression_ui.R +++ b/components/board.expression/R/expression_ui.R @@ -67,6 +67,7 @@ ExpressionUI <- function(id) { fullH <- 800 ## full height of page rowH <- 340 ## full height of page + imgH <- 340 ## height of images tagList( div( @@ -81,16 +82,16 @@ ExpressionUI <- function(id) { class = "col-md-3", expression_plot_volcano_ui(ns("plots_volcano"), label = "A", - height = c(0.45 * fullH, 700), - width = c("auto", 1200) + height = c(imgH, imgH), + width = c("auto", imgH) ), ), div( class = "col-md-3", expression_plot_maplot_ui(ns("plots_maplot"), label = "B", - height = c(0.45 * fullH, 700), - width = c("auto", 1200) + height = c(imgH, imgH), + width = c("auto", imgH) ), ), div( @@ -98,8 +99,8 @@ ExpressionUI <- function(id) { expression_plot_boxplot_ui( id = "plots_boxplot", label = "C", - height = c(0.45 * fullH, 700), - width = c("auto", 1200) + height = c(imgH, imgH), + width = c("auto", imgH) ), ), div( @@ -107,8 +108,8 @@ ExpressionUI <- function(id) { expression_plot_topfoldchange_ui( id = "plots_topfoldchange", label = "D", - height = c(0.45 * fullH, 700), - width = c("auto", 1200) + height = c(imgH, imgH), + width = c("auto", imgH) ), ) ), From b34ba823b52ff2e40b7b152f730c57277e2f4bf9 Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Mon, 23 Jan 2023 10:48:48 +0100 Subject: [PATCH 02/32] removed serverSideComputation to simplify code and reactivity --- .../board.expression/R/expression_server.R | 470 +++++++++++++++++- .../board.expression/R/expression_volcano.R | 81 ++- 2 files changed, 497 insertions(+), 54 deletions(-) diff --git a/components/board.expression/R/expression_server.R b/components/board.expression/R/expression_server.R index 403a79842..dc56f5917 100644 --- a/components/board.expression/R/expression_server.R +++ b/components/board.expression/R/expression_server.R @@ -288,16 +288,15 @@ ExpressionBoard <- function(id, inputData) { expression_plot_volcano_server( id = "plots_volcano", - pgx_fdr = reactive(input$gx_fdr), - pgx_contrast = reactive(input$gx_contrast), - pgx_lfc = reactive(input$gx_lfc), - pgx_features = reactive(input$gx_features), + comp1 = shiny::reactive(input$gx_contrast), + fdr= shiny::reactive(input$gx_fdr), + lfc = shiny::reactive(input$gx_lfc), + features = shiny::reactive(input$gx_features), res = fullDiffExprTable, sel1 = genetable$rows_selected, df1 = filteredDiffExprTable, sel2 = gsettable$rows_selected, - df2 = gx_related_genesets, - fam.genes = res$gene_name + df2 = gx_related_genesets ) expression_plot_maplot_server( @@ -390,6 +389,465 @@ ExpressionBoard <- function(id, inputData) { ii = genetable$rows_current ) + + # MA old code refactored into plot module ##### + # plots_maplot.RENDER <- shiny::reactive({ + # comp1 = input$gx_contrast + # if(length(comp1)==0) return(NULL) + # + # ngs <- inputData() + # shiny::req(ngs) + # + # fdr=1;lfc=1 + # fdr = as.numeric(input$gx_fdr) + # lfc = as.numeric(input$gx_lfc) + # + # res = fullDiffExprTable() + # if(is.null(res)) return(NULL) + # fc.genes = as.character(res[,grep("^gene$|gene_name",colnames(res))]) + # ##pval = res$P.Value + # ##pval = res[,grep("P.Value|meta.p|pval|p.val",colnames(res))[1]] + # + # ## filter genes by gene family or gene set + # fam.genes = unique(unlist(ngs$families[10])) + # ##fam.genes = unique(unlist(ngs$families[input$gx_features])) + # fam.genes = res$gene_name + # if(input$gx_features!="") { + # ##gset <- GSETS[input$gx_features] + # gset <- getGSETS( input$gx_features ) + # fam.genes = unique(unlist(gset)) + # } + # jj <- match(toupper(fam.genes),toupper(res$gene_name)) + # sel.genes <- res$gene_name[setdiff(jj,NA)] + # + # qval = res[,grep("adj.P.Val|meta.q|qval|padj",colnames(res))[1]] + # fx = res[,grep("logFC|meta.fx|fc",colnames(res))[1]] + # + # sig.genes = fc.genes[which(qval <= fdr & abs(fx) > lfc )] + # sel.genes = intersect(sig.genes, sel.genes) + # + # xlim = c(-1,1)*max(abs(fx),na.rm=TRUE) + # ma = rowMeans(ngs$X[rownames(res),], na.rm=TRUE) + # + # par(mfrow=c(1,1), mar=c(4,3,2,1.5), mgp=c(2,0.8,0), oma=c(1,0,0.5,0)) + # par(mfrow=c(1,1), mar=c(4,3,1,1.5), mgp=c(2,0.8,0), oma=c(0,0,0,0)) + # gx.volcanoPlot.XY( x=fx, pv=qval, gene=fc.genes, lfc=lfc, + # render="canvas", n=5000, nlab=12, + # xlim=xlim, ylim=c(0,15), + # xlab="average expression (log2CPM)", + # ylab="effect size (log2FC)", + # ma_plot=TRUE, ma = ma, ## hi.col="#222222", + # use.fdr=TRUE, p.sig=fdr, ##main=comp1, + # highlight = sel.genes, + # lab.cex = lab.cex, + # ## highlight = sel.genes, + # ## main="MA plot", + # cex=0.9, lab.cex=1.4, cex.main=1.0 ) + # }) + # + # plots_maplot.PLOTLY <- shiny::reactive({ + # comp1 = input$gx_contrast + # if(length(comp1)==0) return(NULL) + # + # ngs <- inputData() + # shiny::req(ngs) + # + # dbg("[plots_maplot.PLOTLY] reacted") + # + # fdr=1;lfc=1 + # fdr = as.numeric(input$gx_fdr) + # lfc = as.numeric(input$gx_lfc) + # + # res = fullDiffExprTable() + # if(is.null(res)) return(NULL) + # fc.genes = as.character(res[,grep("^gene$|gene_name",colnames(res))]) + # ##pval = res$P.Value + # ##pval = res[,grep("P.Value|meta.p|pval|p.val",colnames(res))[1]] + # + # ## filter genes by gene family or gene set + # fam.genes = unique(unlist(ngs$families[10])) + # ##fam.genes = unique(unlist(ngs$families[input$gx_features])) + # fam.genes = res$gene_name + # if(input$gx_features!="") { + # ##gset <- GSETS[input$gx_features] + # gset <- getGSETS( input$gx_features ) + # fam.genes = unique(unlist(gset)) + # } + # jj <- match(toupper(fam.genes),toupper(res$gene_name)) + # sel.genes <- res$gene_name[setdiff(jj,NA)] + # + # qval = res[,grep("adj.P.Val|meta.q|qval|padj",colnames(res))[1]] + # y = res[,grep("logFC|meta.fx|fc",colnames(res))[1]] + # + # scaled.x <- scale(-log10(qval),center=FALSE) + # scaled.y <- scale(y,center=FALSE) + # fc.genes <- rownames(res) + # impt <- function(g) { + # j = match(g, fc.genes) + # x1 = scaled.x[j] + # y1 = scaled.y[j] + # x = sign(x1)*(0.25*x1**2 + y1**2) + # names(x)=g + # x + # } + # + # sig.genes = fc.genes[which(qval <= fdr & abs(y) > lfc )] + # sel.genes = intersect(sig.genes, sel.genes) + # + # ## are there any genes/genesets selected? + # sel1 = genetable$rows_selected() + # df1 = filteredDiffExprTable() + # sel2 = gsettable$rows_selected() + # df2 <- gx_related_genesets() + # lab.cex = 1 + # gene.selected <- !is.null(sel1) && !is.null(df1) + # gset.selected <- !is.null(sel2) && !is.null(df2) + # if(gene.selected && !gset.selected) { + # lab.genes = rownames(df1)[sel1] + # sel.genes = lab.genes + # lab.cex = 1.3 + # } else if(gene.selected && gset.selected) { + # gs <- rownames(df2)[sel2] + # dbg("[plots_maplot.PLOTLY] gs = ",gs) + # ##gset <- GSETS[[gs]] + # gset <- unlist(getGSETS(gs)) + # sel.genes = intersect(sel.genes, gset) + # lab.genes = c( head(sel.genes[order(impt(sel.genes))],10), + # head(sel.genes[order(-impt(sel.genes))],10) ) + # lab.cex = 1 + # } else { + # lab.genes = c( head(sel.genes[order(impt(sel.genes))],10), + # head(sel.genes[order(-impt(sel.genes))],10) ) + # lab.cex = 1 + # } + # + # ylim = c(-1,1)*max(abs(y),na.rm=TRUE) + # x = rowMeans( ngs$X[rownames(res),], na.rm=TRUE) + # + # impt <- function(g) { + # j = match(g, fc.genes) + # x1 = scale(x,center=FALSE)[j] + # y1 = scale(y,center=FALSE)[j] + # x = sign(y1)*(1.0*x1**2 + 1.0*y1**2) + # names(x)=g + # x + # } + # lab.genes = c( head(sel.genes[order(impt(sel.genes))],10), + # head(sel.genes[order(-impt(sel.genes))],10) ) + # + # highlight=sel.genes;label=lab.genes;names=fc.genes + # plt <- plotlyMA( + # x=x, y=y, names=fc.genes, + # source = "plot1", marker.type = "scattergl", + # highlight = sel.genes, + # label = lab.genes, label.cex = lab.cex, + # group.names = c("group1","group0"), + # ##xlim=xlim, ylim=ylim, ## hi.col="#222222", + # ##use.fdr=TRUE, + # psig = fdr, lfc = lfc, + # xlab = "average expression (log2.CPM)", + # ylab = "effect size (log2.FC)", + # marker.size = 4, + # displayModeBar = FALSE, + # showlegend = FALSE) %>% + # plotly::layout( margin = list(b=65) ) + # + # dbg("[plots_maplot.PLOTLY] done!") + # + # return(plt) + # }) + # + # shiny::callModule( plotModule, + # id="plots_maplot", + # ##func = plots_maplot.RENDER, + # ##func2 = plots_maplot.RENDER, + # func = plots_maplot.PLOTLY, plotlib="plotly", + # info.text = plots_maplot_text, label="b", + # title = "MA plot", + # height = imgH, + # pdf.width=6, pdf.height=6, res=75, + # add.watermark = WATERMARK + # ) + + # MA end of old code refactored into plot module ##### + + # topgenesbarplot old code NOT refactored into plot module #### + + # plots_topgenesbarplot.RENDER <- shiny::reactive({ + # + # ngs = inputData() + # shiny::req(ngs) + # comp1 = input$gx_contrast + # + # dbg("plots_topgenesbarplot.RENDER: reacted") + # + # if(length(comp1)==0) return(NULL) + # + # ## get table + # ##sel.row=1;pp=rownames(ngs$X)[1] + # ##sel.row = input$genetable_rows_selected + # + # res = filteredDiffExprTable() + # if(is.null(res)) return(NULL) + # + # ##fc <- res$meta.fx + # fc <- res$logFC + # names(fc) <- rownames(res) + # 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]) + # klr.pal <- RColorBrewer::brewer.pal(4,"Paired")[2:1] + # klr <- c( rep(klr.pal[1],length(top.up)), rep(klr.pal[2],length(top.dn)) ) + # names(fc.top) <- sub(".*:","",names(fc.top)) + # + # ii <- order(fc.top) + # par(mfrow=c(1,1), mar=c(5,3,1,1), mgp=c(2,0.8,0), oma=c(0,0,0,0)) + # barplot(fc.top[ii], las=3, cex.names=0.75, ylab="fold change", + # col=klr[ii], ylim=c(-1.1,1.2)*max(abs(fc.top),na.rm=TRUE) ) + # + # ## warning A_vs_B or B_vs_A not checked!!! + # groups <- strsplit(comp1,split="[._ ]vs[._ ]")[[1]] + # if(is.POSvsNEG(ngs)) groups <- rev(groups) + # groups <- gsub("@.*","",gsub(".*[:]","",groups)) + # tt <- c( paste("up in",groups[2]), paste("up in",groups[1]) ) + # ##tt <- c( paste("up in",groups[1]), paste("down in",groups[1]) ) + # legend("topleft", legend=tt, fill=klr.pal, cex=0.9, y.intersp=0.85, bty="n") + # ##title("top DE genes",cex.main=1) + # + # dbg("plots_topgenesbarplot.RENDER: done\n") + # + # }) + # + # shiny::callModule( + # plotModule, + # id="plots_topgenesbarplot", ## ns=ns, + # func = plots_topgenesbarplot.RENDER, + # func2 = plots_topgenesbarplot.RENDER, + # info.text = plots_topgenesbarplot_text, label="c", + # title = "top DE genes", + # height = c(imgH,500), width=c('auto',800), + # pdf.width=6, pdf.height=6, res=75, + # add.watermark = WATERMARK + # ) + # + # + # plots_topfoldchange.RENDER <- shiny::reactive({ + # + # ngs = inputData() + # shiny::req(ngs) + # + # ## get table + # ##sel=1;pp=rownames(ngs$X)[1] + # sel = genetable$rows_selected() + # if(is.null(sel) || length(sel)==0) { + # frame() + # text(0.5,0.5, "No gene selected", col='black') + # return(NULL) + # } + # + # res = filteredDiffExprTable() + # if(is.null(res) || is.null(sel)) return(NULL) + # psel <- rownames(res)[sel] + # gene <- ngs$genes[psel,"gene_name"] + # + # ##fc <- res$meta.fx + # comp=1 + # comp = input$gx_contrast + # if(is.null(comp) || length(comp)==0) return(NULL) + # fc <- sapply( ngs$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]) + # fc.top <- fc.top[head(order(-abs(fc.top)),15)] + # fc.top <- sort(fc.top) + # fc.top <- head(c(fc.top, rep(NA,99)),15) + # + # klr.pal <- RColorBrewer::brewer.pal(4,"Paired")[2:1] + # ##klr.pal <- BLUERED(16)[c(3,14)] + # klr <- klr.pal[1 + 1*(sign(fc.top)<0)] + # + # par(mfrow=c(1,1), mar=c(4,4,2,2)*1, mgp=c(2,0.8,0), oma=c(1,1,1,0.5)*0.2) + # par(mfrow=c(1,1), mar=c(6,3,0,1), mgp=c(2,0.8,0), oma=c(1,0,0,0)) + # nch <- max(nchar(names(fc.top))) + # m1 <- ifelse(nch > 12, 12, 8) + # m1 <- ifelse(nch > 30, 16, m1) + # + # ##par( mar=c(4,m1,2,0.5) ) + # par( mar=c(3.2,m1-0.5,1,1) ) + # cex1 <- 0.9 + # nn <- sum(!is.na(fc.top)) + # if(nn>15) cex1 <- 0.8 + # barplot(fc.top, col=klr, horiz=TRUE, las=1, + # xlim=c(-1,1)*max(abs(fc.top),na.rm=TRUE), + # cex.names=cex1, xlab="fold change (log2)") + # title(gene, cex.main=1, line=-0.15) + # + # }) + # + # shiny::callModule( plotModule, + # id = "plots_topfoldchange", + # func = plots_topfoldchange.RENDER, + # func2 = plots_topfoldchange.RENDER, + # info.text = plots_topfoldchange_text, + # title = "Gene in contrasts", label = "d", + # height = c(imgH,500), width=c('auto',700), + # pdf.width=6, pdf.height=6, res=74, + # add.watermark = WATERMARK + # ) + # + # # end of topgenesbarplot old code NOT into plot module #### + + + # # boxplot old code refactored into plot module #### + # + # plots_boxplot.RENDER <- shiny::reactive({ + # + # ngs = inputData() + # shiny::req(ngs) + # + # ## get table + # ##sel=1 + # sel = genetable$rows_selected() + # if(is.null(sel) || length(sel)==0) { + # frame() + # text(0.5,0.5, "No gene selected", col='black') + # return(NULL) + # } + # + # res = filteredDiffExprTable() + # if(is.null(res) || is.null(sel)) return(NULL) + # + # psel <- rownames(res)[sel] + # gene=ngs$genes[1,"gene_name"];comp=1;grouped=TRUE;logscale=TRUE;srt=45 + # gene = ngs$genes[psel,"gene_name"] + # comp = input$gx_contrast + # shiny::req(comp) + # grouped <- input$boxplot_grouped + # logscale <- input$boxplot_logscale + # srt <- ifelse(grouped, 0, 35) + # + # par(mfrow=c(1,1), mar=c(4,3,1.5,1.5), mgp=c(2,0.8,0), oma=c(1,0.5,0,0.5)) + # pgx.plotExpression(ngs, gene, comp=comp, grouped=grouped, + # max.points = 200, ## slow!! + # names = TRUE, + # logscale=logscale, srt=srt) + # + # }) + # + # ##plots_boxplot + # plots_boxplot_opts = shiny::tagList( + # withTooltip( shiny::checkboxInput(ns('boxplot_grouped'),'grouped',TRUE), + # "Group expression values by conditions.", + # placement="right", options = list(container = "body")), + # withTooltip( shiny::checkboxInput(ns('boxplot_logscale'),'log scale',TRUE), + # "Show logarithmic (log2CPM) expression values.", + # placement="right", options = list(container = "body")) + # ) + # + # shiny::callModule( plotModule, + # id = "plots_boxplot", label = "c", + # func = plots_boxplot.RENDER, + # func2 = plots_boxplot.RENDER, + # options = plots_boxplot_opts, + # info.text = "Differential expression boxplot for selected gene.", + # info.width = "150px", + # title = "Differential expression", + # height = imgH, + # pdf.width=6, pdf.height=6, res=75, + # add.watermark = WATERMARK + # ) + + + # end boxplot old code refactored into plot module #### + + + # topgenes old code refactor into plotmodule ##### + + # topgenes.RENDER <- shiny::reactive({ + # + # ngs <- inputData() + # shiny::req(ngs) + # + # res <- filteredDiffExprTable() + # if(is.null(res) || nrow(res)==0) return(NULL) + # + # ## filter on active rows (using search) + # ##ii <- genetable$rows_all() + # ii <- genetable$rows_current() + # res <- res[ii,,drop=FALSE] + # if(nrow(res)==0) return(NULL) + # + # comp=1;grouped=0;logscale=1 + # comp = input$gx_contrast + # grouped <- !input$gx_ungroup + # logscale <- input$gx_logscale + # showothers <- input$gx_showothers + # + # mar1 = 3.5 + # ylab = ifelse(logscale, "log2CPM", "CPM") + # + # ny <- nrow(ngs$samples) ## ???!! + # show.names <- ifelse(!grouped & ny>25, FALSE, TRUE) + # ##nx = ifelse(grouped, ngrp, length(y)) + # nx = ifelse(grouped, 3, ny) + # nc = 4 + # nc = 8 + # if( nx <= 3) nc <- 10 + # if( nx > 10) nc <- 5 + # if( nx > 25) nc <- 4 + # srt = 35 + # sumlen.grpnames <- sum(nchar(strsplit(sub(".*:","",comp),split="_vs_")[[1]])) + # if(show.names && sumlen.grpnames <= 20) srt <- 0 + # + # nc <- 8 + # par(mfrow=c(2,nc), mar=c(mar1,3.5,1,1), mgp=c(2,0.8,0), oma=c(0.1,0.6,0,0.6) ) + # i=1 + # for(i in 1:nrow(res)) { + # ## if(i > length(top.up)) { frame() } + # ##gene = sub(".*:","",top.up[i]) + # gene = rownames(res)[i] + # pgx.plotExpression( + # ngs, gene, comp=comp, grouped=grouped, + # max.points = 200, ## slow!! + # collapse.others=TRUE, showothers=showothers, + # ylab = ylab, xlab="", srt=srt, + # logscale=logscale, names=show.names, main="") + # title( gene, cex.main=1, line=-0.6) + # } + # }) + # + # topgenes_opts = shiny::tagList( + # withTooltip( shiny::checkboxInput(ns('gx_logscale'),'log scale',TRUE), + # "Logarithmic scale the counts (abundance levels).", + # placement="right", options = list(container = "body")), + # withTooltip( shiny::checkboxInput(ns('gx_ungroup'),'ungroup samples',FALSE), + # "Ungroup samples in the plot", + # placement="right", options = list(container = "body")), + # withTooltip( shiny::checkboxInput(ns('gx_showothers'),'show others',FALSE), + # "Show the 'others' class (if any)", + # placement="right", options = list(container = "body")) + # ) + # + # topgenes_text = "The Top genes section shows the average expression plots across the samples for the top differentially (both positively and negatively) expressed genes for the selected comparison from the Contrast settings. Under the plot Settings, users can scale the abundance levels (counts) or ungroup the samples in the plot from the log scale and ungroup samples settings, respectively." + # + # topgenes_caption = "Top differentially expressed genes. Expression barplots of the top most differentially (both positively and negatively) expressed genes for the selected contrast." + # + # shiny::callModule( plotModule, + # id = "topgenes", + # func = topgenes.RENDER, + # func2 = topgenes.RENDER, + # options = topgenes_opts, + # info.text = topgenes_text, + # ##caption = topgenes_caption, + # height = c(imgH,420), width = c('auto',1600), + # res = c(90,105), + # pdf.width=14, pdf.height=3.5, + # title="Expression of top differentially expressed genes", + # add.watermark = WATERMARK + # ) + + # end topgenes old code refactor into plotmodule ##### + ## ================================================================================ ## Volcano (all contrasts) ## ================================================================================ diff --git a/components/board.expression/R/expression_volcano.R b/components/board.expression/R/expression_volcano.R index 5cbb518ac..79a8a0b7b 100644 --- a/components/board.expression/R/expression_volcano.R +++ b/components/board.expression/R/expression_volcano.R @@ -43,10 +43,10 @@ expression_plot_volcano_ui <- function(id, #' @description A shiny Module for plotting (server code). #' #' @param id -#' @param pgx_fdr -#' @param pgx_contrast -#' @param pgx_lfc -#' @param pgx_features +#' @param comp1 +#' @param fdr +#' @param lfc +#' @param features #' @param res #' @param sel1 #' @param df1 @@ -56,38 +56,39 @@ expression_plot_volcano_ui <- function(id, #' #' @export expression_plot_volcano_server <- function(id, - pgx_fdr = 0.1, - pgx_contrast, - pgx_lfc = 1.0, - pgx_features, + comp1, + fdr, + lfc, + features, res, sel1, df1, sel2, df2, - fam.genes, watermark = FALSE) { - moduleServer(id, function(input, output, session, watermark) { - - # calculate required inputs for plotting - serverSideComputation <- function(pgx_fdr, - pgx_contrast, - pgx_lfc, - pgx_features, - res, - sel1, - df1, - sel2, - df2, - fam.genes) { - comp1 <- pgx_contrast - # alertDataLoaded(session,gx) - # res <- res() - fdr <- as.numeric(pgx_fdr) + moduleServer(id, function(input, output, session) { + + # reactive function listening for changes in input + plot_data <- shiny::reactive({ + # calculate required inputs for plotting + + + comp1 = comp1() + fdr = as.numeric(fdr()) + lfc = as.numeric(lfc()) + features = features() + res = res() + sel1= sel1() + df1 = df1() + sel2 = sel2() + df2 = df2() + + # comp1 <- input$gx_contrast() + # fdr <- as.numeric(input$gx_fdr()) # res = fullDiffExprTable() - lfc <- as.numeric(pgx_lfc) + # lfc <- as.numeric(input$gx_lfc()) fam.genes <- res$gene_name - ## fam.genes = unique(unlist(pgx$families[input$pgx_features])) + ## fam.genes = unique(unlist(gx$families[features])) if (is.null(res)) { return(NULL) @@ -95,12 +96,12 @@ expression_plot_volcano_server <- function(id, if (length(comp1) == 0) { return(NULL) } - if (is.null(pgx_features)) { + if (is.null(features)) { return(NULL) } - if (pgx_features != "") { - ## gset <- GSETS[input$pgx_features] - gset <- getGSETS(pgx_features) + if (features != "") { + ## gset <- GSETS[features] + gset <- getGSETS(features) fam.genes <- unique(unlist(gset)) } @@ -165,22 +166,6 @@ expression_plot_volcano_server <- function(id, fdr = fdr, lfc = lfc )) - } - - # reactive function listening for changes in input - plot_data <- shiny::reactive({ - serverSideComputation( - pgx_fdr(), - pgx_contrast(), - pgx_lfc(), - pgx_features(), - res(), - sel1(), - df1(), - sel2(), - df2(), - fam.genes - ) }) From b7a01e92a11011fc2c568f8c06bc86e86c52a1f7 Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Mon, 23 Jan 2023 10:58:20 +0100 Subject: [PATCH 03/32] file names conform --- .../R/{expression_maplot.R => expression_plot_maplot.R} | 0 .../R/{expression_volcano.R => expression_plot_volcano.R} | 0 2 files changed, 0 insertions(+), 0 deletions(-) rename components/board.expression/R/{expression_maplot.R => expression_plot_maplot.R} (100%) rename components/board.expression/R/{expression_volcano.R => expression_plot_volcano.R} (100%) diff --git a/components/board.expression/R/expression_maplot.R b/components/board.expression/R/expression_plot_maplot.R similarity index 100% rename from components/board.expression/R/expression_maplot.R rename to components/board.expression/R/expression_plot_maplot.R diff --git a/components/board.expression/R/expression_volcano.R b/components/board.expression/R/expression_plot_volcano.R similarity index 100% rename from components/board.expression/R/expression_volcano.R rename to components/board.expression/R/expression_plot_volcano.R From ef784f02431f972a4f61d36a09a3a6bee67845d0 Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Mon, 23 Jan 2023 13:27:23 +0100 Subject: [PATCH 04/32] boxplot refactor [args and opts] --- .../R/expression_plot_boxplot.R | 57 +++++++++++-------- .../board.expression/R/expression_server.R | 7 ++- components/board.expression/R/expression_ui.R | 5 +- 3 files changed, 42 insertions(+), 27 deletions(-) diff --git a/components/board.expression/R/expression_plot_boxplot.R b/components/board.expression/R/expression_plot_boxplot.R index 3e2587381..a7a332de5 100644 --- a/components/board.expression/R/expression_plot_boxplot.R +++ b/components/board.expression/R/expression_plot_boxplot.R @@ -16,11 +16,19 @@ expression_plot_boxplot_ui <- function(id, label = "", height, - width) { + width){ ns <- shiny::NS(id) - options <- tagList( - actionButton(ns("button1"), "some action") - ) + # options <- tagList( + # actionButton(ns("button1"), "some action") + # ) + + plots_boxplot_opts = shiny::tagList( + withTooltip( shiny::checkboxInput(ns('boxplot_grouped'),'grouped',TRUE), + "Group expression values by conditions.", + placement="right", options = list(container = "body")), + withTooltip( shiny::checkboxInput(ns('boxplot_logscale'),'log scale',TRUE), + "Show logarithmic (log2CPM) expression values.", + placement="right", options = list(container = "body"))) info_text <- "The top N = {12} differentially (both positively and negatively) expressed gene barplot for the selected comparison under the Contrast settings." @@ -29,7 +37,7 @@ expression_plot_boxplot_ui <- function(id, label = label, plotlib = "base", info.text = info_text, - options = NULL, + options = plots_boxplot_opts, download.fmt = c("png", "pdf", "csv"), width = width, height = height @@ -41,7 +49,10 @@ expression_plot_boxplot_ui <- function(id, #' @description A shiny Module for plotting (server code). #' #' @param id -#' @param inputData +#' @param comp +#' @param grouped +#' @param logscale +#' @param ngs #' @param sel #' @param res #' @param watermark @@ -50,7 +61,10 @@ expression_plot_boxplot_ui <- function(id, #' #' @export expression_plot_boxplot_server <- function(id, - inputData, + comp, + grouped, + logscale, + ngs, sel, res, watermark = FALSE) { @@ -58,49 +72,46 @@ expression_plot_boxplot_server <- function(id, # #calculate required inputs for plotting --------------------------------- plot_data <- shiny::reactive({ - ngs <- inputData() - shiny::req(ngs) - ## get table - ## sel=1 + comp <- comp() #input$gx_contrast + grouped <- grouped() #input$boxplot_grouped + logscale <- logscale() #input$boxplot_logscale + ngs <- ngs() sel <- sel() + res <- res() + + if (is.null(sel) || length(sel) == 0) { frame() text(0.5, 0.5, "No gene selected", col = "black") return(NULL) } - res <- res() + if (is.null(res) || is.null(sel)) { return(NULL) } psel <- rownames(res)[sel] gene <- ngs$genes[1, "gene_name"] - comp <- 1 - grouped <- TRUE - logscale <- TRUE - srt <- 45 + gene <- ngs$genes[psel, "gene_name"] - comp <- input$gx_contrast - shiny::req(comp) - grouped <- input$boxplot_grouped - logscale <- input$boxplot_logscale srt <- ifelse(grouped, 0, 35) - return( + return(list( ngs = ngs, gene = gene, comp = comp, grouped = grouped, logscale = logscale, - srt = srt - ) + srt = srt) + ) }) plotly.RENDER <- function() { pd <- plot_data() shiny::req(pd) + browser() par(mfrow = c(1, 1), mar = c(4, 3, 1.5, 1.5), mgp = c(2, 0.8, 0), oma = c(1, 0.5, 0, 0.5)) pgx.plotExpression(pd[["ngs"]], diff --git a/components/board.expression/R/expression_server.R b/components/board.expression/R/expression_server.R index dc56f5917..f5a26d1d2 100644 --- a/components/board.expression/R/expression_server.R +++ b/components/board.expression/R/expression_server.R @@ -316,8 +316,11 @@ ExpressionBoard <- function(id, inputData) { ) expression_plot_boxplot_server( - id = "plots_barplot", - inputData = inputData, + id = "plots_boxplot", + comp = shiny::reactive(input$gx_contrast), + grouped = shiny::reactive(input$boxplot_grouped), + logscale = shiny::reactive(input$boxplot_logscale), + ngs = inputData, sel = genetable$rows_selected, res = filteredDiffExprTable, watermark = FALSE diff --git a/components/board.expression/R/expression_ui.R b/components/board.expression/R/expression_ui.R index d5a6d2cf7..fdce4337e 100644 --- a/components/board.expression/R/expression_ui.R +++ b/components/board.expression/R/expression_ui.R @@ -88,7 +88,8 @@ ExpressionUI <- function(id) { ), div( class = "col-md-3", - expression_plot_maplot_ui(ns("plots_maplot"), + expression_plot_maplot_ui( + id = ns("plots_maplot"), label = "B", height = c(imgH, imgH), width = c("auto", imgH) @@ -97,7 +98,7 @@ ExpressionUI <- function(id) { div( class = "col-md-3", expression_plot_boxplot_ui( - id = "plots_boxplot", + id = ns("plots_boxplot"), label = "C", height = c(imgH, imgH), width = c("auto", imgH) From ad3c98d484695395496e15e9a2f0a7a37fb0b0f5 Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Mon, 23 Jan 2023 14:05:20 +0100 Subject: [PATCH 05/32] fix reactive inputs from topfoldchange --- .../R/expression_plot_boxplot.R | 1 - .../R/expression_plot_topfoldchange.R | 28 +++--- .../board.expression/R/expression_server.R | 99 ++++++++++--------- components/board.expression/R/expression_ui.R | 2 +- 4 files changed, 63 insertions(+), 67 deletions(-) diff --git a/components/board.expression/R/expression_plot_boxplot.R b/components/board.expression/R/expression_plot_boxplot.R index a7a332de5..df18a1aaf 100644 --- a/components/board.expression/R/expression_plot_boxplot.R +++ b/components/board.expression/R/expression_plot_boxplot.R @@ -111,7 +111,6 @@ expression_plot_boxplot_server <- function(id, plotly.RENDER <- function() { pd <- plot_data() shiny::req(pd) - browser() par(mfrow = c(1, 1), mar = c(4, 3, 1.5, 1.5), mgp = c(2, 0.8, 0), oma = c(1, 0.5, 0, 0.5)) pgx.plotExpression(pd[["ngs"]], diff --git a/components/board.expression/R/expression_plot_topfoldchange.R b/components/board.expression/R/expression_plot_topfoldchange.R index 1579cbf6f..e13b428e0 100644 --- a/components/board.expression/R/expression_plot_topfoldchange.R +++ b/components/board.expression/R/expression_plot_topfoldchange.R @@ -18,10 +18,6 @@ expression_plot_topfoldchange_ui <- function(id, height, width) { ns <- shiny::NS(id) - options <- tagList( - actionButton(ns("button1"), "some action") - ) - info_text <- "The fold change summary barplot across all contrasts for a gene that is selected from the differential expression analysis table under the Table section." PlotModuleUI(ns("pltmod"), @@ -29,7 +25,6 @@ expression_plot_topfoldchange_ui <- function(id, label = label, plotlib = "base", info.text = info_text, - options = NULL, download.fmt = c("png", "pdf", "csv"), width = width, height = height @@ -41,7 +36,8 @@ expression_plot_topfoldchange_ui <- function(id, #' @description A shiny Module for plotting (server code). #' #' @param id -#' @param inputData +#' @param comp +#' @param ngs #' @param sel #' @param res #' @param watermark @@ -50,7 +46,8 @@ expression_plot_topfoldchange_ui <- function(id, #' #' @export expression_plot_topfoldchange_server <- function(id, - inputData, + comp, + ngs, sel, res, watermark = FALSE) { @@ -58,19 +55,19 @@ expression_plot_topfoldchange_server <- function(id, # #calculate required inputs for plotting --------------------------------- plot_data <- shiny::reactive({ - ngs <- inputData() - shiny::req(ngs) - ## get table - ## sel=1;pp=rownames(ngs$X)[1] + comp <- comp() #input$gx_contrast + ngs <- ngs() sel <- sel() + res <- res() + if (is.null(sel) || length(sel) == 0) { frame() text(0.5, 0.5, "No gene selected", col = "black") return(NULL) } - res <- res() + if (is.null(res) || is.null(sel)) { return(NULL) } @@ -78,8 +75,7 @@ expression_plot_topfoldchange_server <- function(id, gene <- ngs$genes[psel, "gene_name"] ## fc <- res$meta.fx - comp <- 1 - comp <- input$gx_contrast + if (is.null(comp) || length(comp) == 0) { return(NULL) } @@ -95,11 +91,11 @@ expression_plot_topfoldchange_server <- function(id, ## klr.pal <- BLUERED(16)[c(3,14)] klr <- klr.pal[1 + 1 * (sign(fc.top) < 0)] - return( + return(list( fc.top = fc.top, klr = klr, gene = gene - ) + )) }) plotly.RENDER <- function() { diff --git a/components/board.expression/R/expression_server.R b/components/board.expression/R/expression_server.R index f5a26d1d2..9e0b51e0d 100644 --- a/components/board.expression/R/expression_server.R +++ b/components/board.expression/R/expression_server.R @@ -328,7 +328,8 @@ ExpressionBoard <- function(id, inputData) { expression_plot_topfoldchange_server( id = "plots_topfoldchange", - inputData = inputData, + comp = shiny::reactive(input$gx_contrast), + ngs = inputData, sel = genetable$rows_selected, res = filteredDiffExprTable, watermark = FALSE @@ -636,54 +637,54 @@ ExpressionBoard <- function(id, inputData) { # # plots_topfoldchange.RENDER <- shiny::reactive({ # - # ngs = inputData() - # shiny::req(ngs) - # - # ## get table - # ##sel=1;pp=rownames(ngs$X)[1] - # sel = genetable$rows_selected() - # if(is.null(sel) || length(sel)==0) { - # frame() - # text(0.5,0.5, "No gene selected", col='black') - # return(NULL) - # } - # - # res = filteredDiffExprTable() - # if(is.null(res) || is.null(sel)) return(NULL) - # psel <- rownames(res)[sel] - # gene <- ngs$genes[psel,"gene_name"] - # - # ##fc <- res$meta.fx - # comp=1 - # comp = input$gx_contrast - # if(is.null(comp) || length(comp)==0) return(NULL) - # fc <- sapply( ngs$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]) - # fc.top <- fc.top[head(order(-abs(fc.top)),15)] - # fc.top <- sort(fc.top) - # fc.top <- head(c(fc.top, rep(NA,99)),15) - # - # klr.pal <- RColorBrewer::brewer.pal(4,"Paired")[2:1] - # ##klr.pal <- BLUERED(16)[c(3,14)] - # klr <- klr.pal[1 + 1*(sign(fc.top)<0)] - # - # par(mfrow=c(1,1), mar=c(4,4,2,2)*1, mgp=c(2,0.8,0), oma=c(1,1,1,0.5)*0.2) - # par(mfrow=c(1,1), mar=c(6,3,0,1), mgp=c(2,0.8,0), oma=c(1,0,0,0)) - # nch <- max(nchar(names(fc.top))) - # m1 <- ifelse(nch > 12, 12, 8) - # m1 <- ifelse(nch > 30, 16, m1) - # - # ##par( mar=c(4,m1,2,0.5) ) - # par( mar=c(3.2,m1-0.5,1,1) ) - # cex1 <- 0.9 - # nn <- sum(!is.na(fc.top)) - # if(nn>15) cex1 <- 0.8 - # barplot(fc.top, col=klr, horiz=TRUE, las=1, - # xlim=c(-1,1)*max(abs(fc.top),na.rm=TRUE), - # cex.names=cex1, xlab="fold change (log2)") - # title(gene, cex.main=1, line=-0.15) + # ngs = inputData() + # shiny::req(ngs) + # + # ## get table + # ##sel=1;pp=rownames(ngs$X)[1] + # sel = genetable$rows_selected() + # if(is.null(sel) || length(sel)==0) { + # frame() + # text(0.5,0.5, "No gene selected", col='black') + # return(NULL) + # } + # + # res = filteredDiffExprTable() + # if(is.null(res) || is.null(sel)) return(NULL) + # psel <- rownames(res)[sel] + # gene <- ngs$genes[psel,"gene_name"] + # + # ##fc <- res$meta.fx + # comp=1 + # comp = input$gx_contrast + # if(is.null(comp) || length(comp)==0) return(NULL) + # fc <- sapply( ngs$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]) + # fc.top <- fc.top[head(order(-abs(fc.top)),15)] + # fc.top <- sort(fc.top) + # fc.top <- head(c(fc.top, rep(NA,99)),15) + # + # klr.pal <- RColorBrewer::brewer.pal(4,"Paired")[2:1] + # ##klr.pal <- BLUERED(16)[c(3,14)] + # klr <- klr.pal[1 + 1*(sign(fc.top)<0)] + # + # par(mfrow=c(1,1), mar=c(4,4,2,2)*1, mgp=c(2,0.8,0), oma=c(1,1,1,0.5)*0.2) + # par(mfrow=c(1,1), mar=c(6,3,0,1), mgp=c(2,0.8,0), oma=c(1,0,0,0)) + # nch <- max(nchar(names(fc.top))) + # m1 <- ifelse(nch > 12, 12, 8) + # m1 <- ifelse(nch > 30, 16, m1) + # + # ##par( mar=c(4,m1,2,0.5) ) + # par( mar=c(3.2,m1-0.5,1,1) ) + # cex1 <- 0.9 + # nn <- sum(!is.na(fc.top)) + # if(nn>15) cex1 <- 0.8 + # barplot(fc.top, col=klr, horiz=TRUE, las=1, + # xlim=c(-1,1)*max(abs(fc.top),na.rm=TRUE), + # cex.names=cex1, xlab="fold change (log2)") + # title(gene, cex.main=1, line=-0.15) # # }) # diff --git a/components/board.expression/R/expression_ui.R b/components/board.expression/R/expression_ui.R index fdce4337e..ad5145b19 100644 --- a/components/board.expression/R/expression_ui.R +++ b/components/board.expression/R/expression_ui.R @@ -107,7 +107,7 @@ ExpressionUI <- function(id) { div( class = "col-md-3", expression_plot_topfoldchange_ui( - id = "plots_topfoldchange", + id = ns("plots_topfoldchange"), label = "D", height = c(imgH, imgH), width = c("auto", imgH) From a4c3ed338e2e27af487d606d9b0dd3115142a1b6 Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Mon, 23 Jan 2023 14:11:06 +0100 Subject: [PATCH 06/32] fix tag input for plot_boxplot --- components/board.expression/R/expression_plot_boxplot.R | 6 ++---- components/board.expression/R/expression_server.R | 2 -- 2 files changed, 2 insertions(+), 6 deletions(-) diff --git a/components/board.expression/R/expression_plot_boxplot.R b/components/board.expression/R/expression_plot_boxplot.R index df18a1aaf..57f7a8631 100644 --- a/components/board.expression/R/expression_plot_boxplot.R +++ b/components/board.expression/R/expression_plot_boxplot.R @@ -62,8 +62,6 @@ expression_plot_boxplot_ui <- function(id, #' @export expression_plot_boxplot_server <- function(id, comp, - grouped, - logscale, ngs, sel, res, @@ -74,8 +72,8 @@ expression_plot_boxplot_server <- function(id, plot_data <- shiny::reactive({ comp <- comp() #input$gx_contrast - grouped <- grouped() #input$boxplot_grouped - logscale <- logscale() #input$boxplot_logscale + grouped <- input$boxplot_grouped + logscale <- input$boxplot_logscale ngs <- ngs() sel <- sel() res <- res() diff --git a/components/board.expression/R/expression_server.R b/components/board.expression/R/expression_server.R index 9e0b51e0d..059a7d363 100644 --- a/components/board.expression/R/expression_server.R +++ b/components/board.expression/R/expression_server.R @@ -318,8 +318,6 @@ ExpressionBoard <- function(id, inputData) { expression_plot_boxplot_server( id = "plots_boxplot", comp = shiny::reactive(input$gx_contrast), - grouped = shiny::reactive(input$boxplot_grouped), - logscale = shiny::reactive(input$boxplot_logscale), ngs = inputData, sel = genetable$rows_selected, res = filteredDiffExprTable, From 4c8937216e74275cc5af30f7517a95aed11cc77b Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Mon, 23 Jan 2023 15:03:04 +0100 Subject: [PATCH 07/32] fix reactivity for topgenes --- .../R/expression_plot_topgenes.R | 28 ++++++++++++------- .../board.expression/R/expression_server.R | 12 ++++---- components/board.expression/R/expression_ui.R | 6 ++-- 3 files changed, 27 insertions(+), 19 deletions(-) diff --git a/components/board.expression/R/expression_plot_topgenes.R b/components/board.expression/R/expression_plot_topgenes.R index d13d3069d..e44c3e3ba 100644 --- a/components/board.expression/R/expression_plot_topgenes.R +++ b/components/board.expression/R/expression_plot_topgenes.R @@ -18,9 +18,6 @@ expression_plot_topgenes_ui <- function(id, height, width) { ns <- shiny::NS(id) - options <- tagList( - actionButton(ns("button1"), "some action") - ) info_text <- "The Top genes section shows the average expression plots across the samples for the top differentially (both positively and negatively) expressed genes for the selected comparison from the Contrast settings. Under the plot Settings, users can scale the abundance levels (counts) or ungroup the samples in the plot from the log scale and ungroup samples settings, respectively." @@ -56,6 +53,7 @@ expression_plot_topgenes_ui <- function(id, #' @description A shiny Module for plotting (server code). #' #' @param id +#' @param comp #' @param inputData #' @param res #' @param ii @@ -65,6 +63,7 @@ expression_plot_topgenes_ui <- function(id, #' #' @export expression_plot_topgenes_server <- function(id, + comp, inputData, res, ii, @@ -73,6 +72,7 @@ expression_plot_topgenes_server <- function(id, # #calculate required inputs for plotting --------------------------------- plot_data <- shiny::reactive({ + comp <- comp() #input$gx_contrast ngs <- inputData() shiny::req(ngs) @@ -89,10 +89,9 @@ expression_plot_topgenes_server <- function(id, return(NULL) } - comp <- 1 + grouped <- 0 logscale <- 1 - comp <- input$gx_contrast grouped <- !input$gx_ungroup logscale <- input$gx_logscale showothers <- input$gx_showothers @@ -113,7 +112,7 @@ expression_plot_topgenes_server <- function(id, sumlen.grpnames <- sum(nchar(strsplit(sub(".*:", "", comp), split = "_vs_")[[1]])) if (show.names && sumlen.grpnames <= 20) srt <- 0 - return( + return(list( res = res, ngs = ngs, comp = comp, @@ -123,7 +122,7 @@ expression_plot_topgenes_server <- function(id, srt = srt, logscale = logscale, show.names = show.names - ) + )) }) @@ -132,6 +131,7 @@ expression_plot_topgenes_server <- function(id, shiny::req(pd) nc <- 8 + mar1 = 3.5 par(mfrow = c(2, nc), mar = c(mar1, 3.5, 1, 1), mgp = c(2, 0.8, 0), oma = c(0.1, 0.6, 0, 0.6)) i <- 1 @@ -142,7 +142,15 @@ expression_plot_topgenes_server <- function(id, pgx.plotExpression( pd[["ngs"]], pd[["gene"]], - comgscale = pd[["logscale"]], + pd[["comp"]], + pd[["grouped"]], + max.points = 200, + logscale = pd[["logscale"]], + collapse.others = TRUE, + showothers = pd[["showothers"]], + ylab=ylab, + xlab="", + srt=pd[["srt"]], names = show.names, main = "" ) @@ -169,8 +177,8 @@ expression_plot_topgenes_server <- function(id, func = plotly.RENDER, # func2 = modal_plotly.RENDER, csvFunc = plot_data, ## *** downloadable data as CSV - res = c(90, 105), ## resolution of plots - pdf.width = 6, pdf.height = 6, + res = c(90,105), ## resolution of plots + pdf.width=14, pdf.height=3.5, add.watermark = watermark ) }) ## end of moduleServer diff --git a/components/board.expression/R/expression_server.R b/components/board.expression/R/expression_server.R index 059a7d363..5dc12647a 100644 --- a/components/board.expression/R/expression_server.R +++ b/components/board.expression/R/expression_server.R @@ -384,12 +384,12 @@ ExpressionBoard <- function(id, inputData) { ct }) - expression_plot_topgenes_server( - id = "topgenes", - inputData = inputData, - res = filteredDiffExprTable, - ii = genetable$rows_current - ) + expression_plot_topgenes_server(id = "topgenes", + comp = shiny::reactive(input$gx_contrast), + inputData = inputData, + res = filteredDiffExprTable, + ii = genetable$rows_current, + watermark = FALSE) # MA old code refactored into plot module ##### diff --git a/components/board.expression/R/expression_ui.R b/components/board.expression/R/expression_ui.R index ad5145b19..ffecffdc4 100644 --- a/components/board.expression/R/expression_ui.R +++ b/components/board.expression/R/expression_ui.R @@ -124,10 +124,10 @@ ExpressionUI <- function(id) { shiny::tabPanel( "Top genes", expression_plot_topgenes_ui( - id = "topgenes", + id = ns("topgenes"), label = "A", - height = c(0.45 * fullH, 700), # c(imgH,420) - width = c("auto", 1200) + height = c(imgH,420), + width = c('auto',1600) ), # c('auto',1600) shiny::br(), From 619a9b824c3e38408a7c5a6ce47d5308f03f5495 Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Fri, 27 Jan 2023 09:20:58 +0100 Subject: [PATCH 08/32] cleaned plot module template file --- .../board.expression/R/expression_plot.R | 18 +++++++----------- 1 file changed, 7 insertions(+), 11 deletions(-) diff --git a/components/board.expression/R/expression_plot.R b/components/board.expression/R/expression_plot.R index 2624588a8..9ecc8b001 100644 --- a/components/board.expression/R/expression_plot.R +++ b/components/board.expression/R/expression_plot.R @@ -14,21 +14,21 @@ #' #' @export #' expression_plot_FnName_ui <- function(id, #' label='', -#' height=c(600, 800)) { +#' height, +#' width) { #' ns <- shiny::NS(id) +#' #' info_text = "" +#' #' PlotModuleUI(ns(""), #' title = "", #' label = label, #' plotlib = "plotly", -#' ##outputFunc = plotly::plotlyOutput, -#' ##outputFunc2 = plotly::plotlyOutput, #' info.text = info_text, #' options = NULL, #' download.fmt=c("png","pdf","csv"), -#' width = c("auto","100%"), -#' height = height -#' +#' height = height, +#' width = width) #' } #' #' #' Expression plot Server function @@ -43,12 +43,8 @@ #' { #' moduleServer( id, function(input, output, session) { #' -#' #calculate required inputs for plotting -#' serverSideComputation <- function(...){ -#' #code here -#' } #' -#' #reactive function listeninng for changes in input +#' #reactive function listening for changes in input #' plot_data <- shiny::reactive({ #' #code here #' }) From b1cb01a0bbe16db4fbd7f8c06ecf94ad0e865cd7 Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Fri, 27 Jan 2023 09:30:12 +0100 Subject: [PATCH 09/32] added basic layout files for remaining undone plots --- .../R/expression_plot_volcanoAll.R | 98 +++++++++++++++++++ .../R/expression_plot_volcanoMethods.R | 98 +++++++++++++++++++ 2 files changed, 196 insertions(+) create mode 100644 components/board.expression/R/expression_plot_volcanoAll.R create mode 100644 components/board.expression/R/expression_plot_volcanoMethods.R diff --git a/components/board.expression/R/expression_plot_volcanoAll.R b/components/board.expression/R/expression_plot_volcanoAll.R new file mode 100644 index 000000000..d1d8584d5 --- /dev/null +++ b/components/board.expression/R/expression_plot_volcanoAll.R @@ -0,0 +1,98 @@ +## +## This file is part of the Omics Playground project. +## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. +## + +#' Expression plot UI input function +#' +#' @description A shiny Module for plotting (UI code). +#' +#' @param id +#' @param label +#' @param height +#' +#' @export +expression_plot_volcanoAll_ui <- function(id, + label='', + height, + width) { + ns <- shiny::NS(id) + + info_text = "" + + PlotModuleUI(ns("pltmod"), + title = "", + label = label, + plotlib = "plotly", + info.text = info_text, + options = NULL, + download.fmt=c("png","pdf","csv"), + height = height, + width = width) +} + +#' Expression plot Server function +#' +#' @description A shiny Module for plotting (server code). +#' +#' @param id +#' +#' @return +#' @export +expression_plot_volcanoAll_server <- function(id, watermark = FALSE) +{ + moduleServer( id, function(input, output, session) { + + + #reactive function listening for changes in input + plot_data <- shiny::reactive({ + #code here + }) + + plot.RENDER <- function() { + pd <- plot_data() + shiny::req(pd) + + #plot code here + } + + plotly.RENDER <- function() { + pd <- plot_data() + shiny::req(pd) + + df <- pd + + ## plot as regular plot + plotly::plot_ly(data = df, + type = '', + x = "", + y = "", + ## hoverinfo = "text", + hovertext = ~annot, + marker = list(color = ~color) + ) + } + + modal_plotly.RENDER <- function() { + plotly.RENDER() %>% + plotly::layout( + ## showlegend = TRUE, + font = list( + size = 16 + ) + ) + } + + + PlotModuleServer( + "pltmod", + plotlib = "plotly", + func = plotly.RENDER, + func2 = modal_plotly.RENDER, + csvFunc = plot_data, ## *** downloadable data as CSV + res = c(80,170), ## resolution of plots + pdf.width = 6, pdf.height = 6, + add.watermark = watermark + ) + }## end of moduleServer +} diff --git a/components/board.expression/R/expression_plot_volcanoMethods.R b/components/board.expression/R/expression_plot_volcanoMethods.R new file mode 100644 index 000000000..e538eb9c0 --- /dev/null +++ b/components/board.expression/R/expression_plot_volcanoMethods.R @@ -0,0 +1,98 @@ +## +## This file is part of the Omics Playground project. +## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. +## + +#' Expression plot UI input function +#' +#' @description A shiny Module for plotting (UI code). +#' +#' @param id +#' @param label +#' @param height +#' +#' @export +expression_plot_volcanoMethods_ui <- function(id, + label='', + height, + width) { + ns <- shiny::NS(id) + + info_text = "" + + PlotModuleUI(ns("pltmod"), + title = "", + label = label, + plotlib = "plotly", + info.text = info_text, + options = NULL, + download.fmt=c("png","pdf","csv"), + height = height, + width = width) +} + +#' Expression plot Server function +#' +#' @description A shiny Module for plotting (server code). +#' +#' @param id +#' +#' @return +#' @export +expression_plot_volcanoMethods_server <- function(id, watermark = FALSE) +{ + moduleServer( id, function(input, output, session) { + + + #reactive function listening for changes in input + plot_data <- shiny::reactive({ + #code here + }) + + plot.RENDER <- function() { + pd <- plot_data() + shiny::req(pd) + + #plot code here + } + + plotly.RENDER <- function() { + pd <- plot_data() + shiny::req(pd) + + df <- pd + + ## plot as regular plot + plotly::plot_ly(data = df, + type = '', + x = "", + y = "", + ## hoverinfo = "text", + hovertext = ~annot, + marker = list(color = ~color) + ) + } + + modal_plotly.RENDER <- function() { + plotly.RENDER() %>% + plotly::layout( + ## showlegend = TRUE, + font = list( + size = 16 + ) + ) + } + + + PlotModuleServer( + "pltmod", + plotlib = "plotly", + func = plotly.RENDER, + func2 = modal_plotly.RENDER, + csvFunc = plot_data, ## *** downloadable data as CSV + res = c(80,170), ## resolution of plots + pdf.width = 6, pdf.height = 6, + add.watermark = watermark + ) + }## end of moduleServer +} From cbfcab160f819c3d5f075d10fd0e95f544394463 Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Fri, 27 Jan 2023 11:20:38 +0100 Subject: [PATCH 10/32] volcanoAll plot refactored and working --- .../R/expression_plot_topgenes.R | 4 +- .../R/expression_plot_volcanoAll.R | 153 ++++-- .../board.expression/R/expression_server.R | 444 +++++++++--------- components/board.expression/R/expression_ui.R | 7 +- 4 files changed, 355 insertions(+), 253 deletions(-) diff --git a/components/board.expression/R/expression_plot_topgenes.R b/components/board.expression/R/expression_plot_topgenes.R index e44c3e3ba..5a0d7d76b 100644 --- a/components/board.expression/R/expression_plot_topgenes.R +++ b/components/board.expression/R/expression_plot_topgenes.R @@ -16,7 +16,7 @@ expression_plot_topgenes_ui <- function(id, label = "", height, - width) { + width){ ns <- shiny::NS(id) info_text <- "The Top genes section shows the average expression plots across the samples for the top differentially (both positively and negatively) expressed genes for the selected comparison from the Contrast settings. Under the plot Settings, users can scale the abundance levels (counts) or ungroup the samples in the plot from the log scale and ungroup samples settings, respectively." @@ -182,4 +182,4 @@ expression_plot_topgenes_server <- function(id, add.watermark = watermark ) }) ## end of moduleServer -} +} \ No newline at end of file diff --git a/components/board.expression/R/expression_plot_volcanoAll.R b/components/board.expression/R/expression_plot_volcanoAll.R index d1d8584d5..0f3051093 100644 --- a/components/board.expression/R/expression_plot_volcanoAll.R +++ b/components/board.expression/R/expression_plot_volcanoAll.R @@ -18,12 +18,12 @@ expression_plot_volcanoAll_ui <- function(id, width) { ns <- shiny::NS(id) - info_text = "" + info_text = "Under the Volcano (all) tab, the platform simultaneously displays multiple volcano plots for genes across all contrasts. This provides users an overview of the statistics for all comparisons. By comparing multiple volcano plots, the user can immediately see which comparison is statistically weak or strong." PlotModuleUI(ns("pltmod"), - title = "", + title = "Volcano plots for all contrasts", label = label, - plotlib = "plotly", + plotlib = "ggplot", info.text = info_text, options = NULL, download.fmt=c("png","pdf","csv"), @@ -39,42 +39,135 @@ expression_plot_volcanoAll_ui <- function(id, #' #' @return #' @export -expression_plot_volcanoAll_server <- function(id, watermark = FALSE) -{ - moduleServer( id, function(input, output, session) { +expression_plot_volcanoAll_server <- function(id, + inputData, + getAllContrasts, + features, + fdr, + lfc, + watermark = FALSE){ + moduleServer(id, function(input, output, session){ #reactive function listening for changes in input plot_data <- shiny::reactive({ - #code here + + ngs <- inputData() + features = features() + fdr = fdr() + lfc = lfc() + + + if (is.null(ngs)) { + return(NULL) + } + ct <- getAllContrasts() + F <- ct$F + Q <- ct$Q + + ## comp = names(ngs$gx.meta$meta) + comp <- names(F) + if (length(comp) == 0) { + return(NULL) + } + if (is.null(features)) { + return(NULL) + } + + fdr <- 1 + lfc <- 0 + fdr <- as.numeric(fdr) + lfc <- as.numeric(lfc) + + sel.genes <- rownames(ngs$X) + if (features != "") { + gset <- getGSETS(features) + sel.genes <- unique(unlist(gset)) + } + + + return(list( + comp = comp, + fdr = fdr, + lfc = lfc, + sel.genes = sel.genes, + F = F, + Q =Q) + ) + + }) plot.RENDER <- function() { pd <- plot_data() shiny::req(pd) - #plot code here - } + shiny::withProgress(message = "rendering volcano plots ...", value = 0, { + ## plot layout ##### + ng <- length(pd[["comp"]]) + nn <- c(2, max(ceiling(ng / 2), 5)) + ## if(ng>12) nn = c(3,8) + par(mfrow = nn, mar = c(1, 1, 1, 1) * 0.2, mgp = c(2.6, 1, 0), oma = c(1, 1, 0, 0) * 2) + nr <- 2 + nc <- ceiling(sqrt(ng)) + if (ng > 24) { + nc <- max(ceiling(ng / 3), 6) + nr <- 3 + } else if (TRUE && ng <= 4) { + nc <- 4 + nr <- 1 + } else { + nc <- max(ceiling(ng / 2), 6) + nr <- 2 + } + nr + nc + par(mfrow = c(nr, nc)) - plotly.RENDER <- function() { - pd <- plot_data() - shiny::req(pd) + ymax <- 15 + nlq <- -log10(1e-99 + unlist(pd[["Q"]])) + ymax <- max(1.3, 1.2 * quantile(nlq, probs = 0.999, na.rm = TRUE)[1]) ## y-axis + xmax <- max(1, 1.2 * quantile(abs(unlist(pd[["F"]])), probs = 0.999, na.rm = TRUE)[1]) ## x-axis - df <- pd - ## plot as regular plot - plotly::plot_ly(data = df, - type = '', - x = "", - y = "", - ## hoverinfo = "text", - hovertext = ~annot, - marker = list(color = ~color) - ) + plt <- list() + i <- 1 + for (i in 1:length(pd[["comp"]])) { + qval <- pd[["Q"]][[i]] + fx <- pd[["F"]][[i]] + fc.gene <- names(qval) + is.sig <- (qval <= pd[["fdr"]] & abs(fx) >= pd[["lfc"]]) + sig.genes <- fc.gene[which(is.sig)] + genes1 <- sig.genes[which(toupper(sig.genes) %in% toupper(pd[["sel.genes"]]))] + genes2 <- head(genes1[order(-abs(fx[genes1]) * (-log10(qval[genes1])))], 10) + xy <- data.frame(x = fx, y = -log10(qval)) + is.sig2 <- factor(is.sig, levels = c(FALSE, TRUE)) + + plt[[i]] <- pgx.scatterPlotXY.GGPLOT( + xy, + title = pd[["comp"]][i], cex.title = 0.85, + var = is.sig2, type = "factor", + col = c("#bbbbbb", "#1e60bb"), + legend.pos = "none", ## plotlib="ggplot", + hilight = NULL, hilight2 = genes2, + xlim = xmax * c(-1, 1), ylim = c(0, ymax), + xlab = "difference (log2FC)", + ylab = "significance (-log10q)", + hilight.lwd = 0, hilight.col = "#1e60bb", hilight.cex = 1.5, + cex = 0.45, cex.lab = 0.62 + ) + ## ggplot2::theme(legend.position='none') + ## ggplot2::theme_bw(base_size=11) + + if (!interactive()) shiny::incProgress(1 / length(comp)) + } + }) ## progress + + gridExtra::grid.arrange(grobs = plt, nrow = nr, ncol = nc) } - modal_plotly.RENDER <- function() { - plotly.RENDER() %>% + modal_plot.RENDER <- function() { + plot.RENDER() %>% plotly::layout( ## showlegend = TRUE, font = list( @@ -86,13 +179,13 @@ expression_plot_volcanoAll_server <- function(id, watermark = FALSE) PlotModuleServer( "pltmod", - plotlib = "plotly", - func = plotly.RENDER, - func2 = modal_plotly.RENDER, + plotlib = "ggplot", + func = plot.RENDER, + func2 = modal_plot.RENDER, csvFunc = plot_data, ## *** downloadable data as CSV - res = c(80,170), ## resolution of plots + res = c(70, 90), ## resolution of plots pdf.width = 6, pdf.height = 6, add.watermark = watermark ) - }## end of moduleServer -} + })## end of moduleServer +} \ No newline at end of file diff --git a/components/board.expression/R/expression_server.R b/components/board.expression/R/expression_server.R index 5dc12647a..5e4fa0bd8 100644 --- a/components/board.expression/R/expression_server.R +++ b/components/board.expression/R/expression_server.R @@ -391,6 +391,18 @@ ExpressionBoard <- function(id, inputData) { ii = genetable$rows_current, watermark = FALSE) + # tab differential expression > Volcano All #### + + expression_plot_volcanoAll_server(id = "volcanoAll", + inputData = inputData, + getAllContrasts = getAllContrasts, + features = shiny::reactive(input$gx_features), + fdr = shiny::reactive(input$gx_fdr), + lfc = shiny::reactive(input$gx_lfc), + watermark = FALSE) + + + # MA old code refactored into plot module ##### # plots_maplot.RENDER <- shiny::reactive({ @@ -850,233 +862,222 @@ ExpressionBoard <- function(id, inputData) { # end topgenes old code refactor into plotmodule ##### - ## ================================================================================ - ## Volcano (all contrasts) - ## ================================================================================ - - - volcanoAll.RENDER <- shiny::reactive({ - ## volcanoAll.RENDER <- shiny::reactive({ - - ngs <- inputData() - if (is.null(ngs)) { - return(NULL) - } - ct <- getAllContrasts() - F <- ct$F - Q <- ct$Q - - ## comp = names(ngs$gx.meta$meta) - comp <- names(F) - if (length(comp) == 0) { - return(NULL) - } - if (is.null(input$gx_features)) { - return(NULL) - } - - fdr <- 1 - lfc <- 0 - fdr <- as.numeric(input$gx_fdr) - lfc <- as.numeric(input$gx_lfc) - - sel.genes <- rownames(ngs$X) - if (input$gx_features != "") { - gset <- getGSETS(input$gx_features) - sel.genes <- unique(unlist(gset)) - } - - ## ------------------------------------------------- - ## plot layout - ## ------------------------------------------------- - ng <- length(comp) - nn <- c(2, max(ceiling(ng / 2), 5)) - ## if(ng>12) nn = c(3,8) - par(mfrow = nn, mar = c(1, 1, 1, 1) * 0.2, mgp = c(2.6, 1, 0), oma = c(1, 1, 0, 0) * 2) - nr <- 2 - nc <- ceiling(sqrt(ng)) - if (ng > 24) { - nc <- max(ceiling(ng / 3), 6) - nr <- 3 - } else if (TRUE && ng <= 4) { - nc <- 4 - nr <- 1 - } else { - nc <- max(ceiling(ng / 2), 6) - nr <- 2 - } - nr - nc - par(mfrow = c(nr, nc)) - - ymax <- 15 - nlq <- -log10(1e-99 + unlist(Q)) - ymax <- max(1.3, 1.2 * quantile(nlq, probs = 0.999, na.rm = TRUE)[1]) ## y-axis - xmax <- max(1, 1.2 * quantile(abs(unlist(F)), probs = 0.999, na.rm = TRUE)[1]) ## x-axis - - shiny::withProgress(message = "rendering volcano plots ...", value = 0, { - plt <- list() - i <- 1 - for (i in 1:length(comp)) { - qval <- Q[[i]] - fx <- F[[i]] - fc.gene <- names(qval) - is.sig <- (qval <= fdr & abs(fx) >= lfc) - sig.genes <- fc.gene[which(is.sig)] - genes1 <- sig.genes[which(toupper(sig.genes) %in% toupper(sel.genes))] - genes2 <- head(genes1[order(-abs(fx[genes1]) * (-log10(qval[genes1])))], 10) - xy <- data.frame(x = fx, y = -log10(qval)) - is.sig2 <- factor(is.sig, levels = c(FALSE, TRUE)) - - plt[[i]] <- pgx.scatterPlotXY.GGPLOT( - xy, - title = comp[i], cex.title = 0.85, - var = is.sig2, type = "factor", - col = c("#bbbbbb", "#1e60bb"), - legend.pos = "none", ## plotlib="ggplot", - hilight = NULL, hilight2 = genes2, - xlim = xmax * c(-1, 1), ylim = c(0, ymax), - xlab = "difference (log2FC)", - ylab = "significance (-log10q)", - hilight.lwd = 0, hilight.col = "#1e60bb", hilight.cex = 1.5, - cex = 0.45, cex.lab = 0.62 - ) - ## ggplot2::theme(legend.position='none') - ## ggplot2::theme_bw(base_size=11) - - if (!interactive()) shiny::incProgress(1 / length(comp)) - } - }) ## progress - - ## patchwork::wrap_plots(plt, nrow=nr, ncol=nc) & - ## ggplot2::theme_bw(base_size=11) & - ## ggplot2::theme(legend.position='none') - - - gridExtra::grid.arrange(grobs = plt, nrow = nr, ncol = nc) - }) - - volcanoAll_text <- "Under the Volcano (all) tab, the platform simultaneously displays multiple volcano plots for genes across all contrasts. This provides users an overview of the statistics for all comparisons. By comparing multiple volcano plots, the user can immediately see which comparison is statistically weak or strong." - - shiny::callModule(plotModule, - id = "volcanoAll", - func = volcanoAll.RENDER, - func2 = volcanoAll.RENDER, - info.text = volcanoAll_text, - pdf.width = 16, pdf.height = 5, - height = c(imgH, 500), width = c("auto", 1600), - res = c(70, 90), - title = "Volcano plots for all contrasts", - add.watermark = WATERMARK - ) - - - ## ================================================================================ - ## Volcano (all2 contrasts) - ## ================================================================================ - - ## !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ## PLOTS SEEMS NOT TO REFRESH/DRAW CORRECTLY. Maybe viz.Contrast is isolated???? - ## !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + # Volcano (all contrasts) start code refactored to plotmodule ######## +# +# +# volcanoAll.RENDER <- shiny::reactive({ +# +# ngs <- inputData() +# if (is.null(ngs)) { +# return(NULL) +# } +# ct <- getAllContrasts() +# F <- ct$F +# Q <- ct$Q +# +# ## comp = names(ngs$gx.meta$meta) +# comp <- names(F) +# if (length(comp) == 0) { +# return(NULL) +# } +# if (is.null(input$gx_features)) { +# return(NULL) +# } +# +# fdr <- 1 +# lfc <- 0 +# fdr <- as.numeric(input$gx_fdr) +# lfc <- as.numeric(input$gx_lfc) +# +# sel.genes <- rownames(ngs$X) +# if (input$gx_features != "") { +# gset <- getGSETS(input$gx_features) +# sel.genes <- unique(unlist(gset)) +# } +# +# ng <- length(comp) +# nn <- c(2, max(ceiling(ng / 2), 5)) +# ## if(ng>12) nn = c(3,8) +# par(mfrow = nn, mar = c(1, 1, 1, 1) * 0.2, mgp = c(2.6, 1, 0), oma = c(1, 1, 0, 0) * 2) +# nr <- 2 +# nc <- ceiling(sqrt(ng)) +# if (ng > 24) { +# nc <- max(ceiling(ng / 3), 6) +# nr <- 3 +# } else if (TRUE && ng <= 4) { +# nc <- 4 +# nr <- 1 +# } else { +# nc <- max(ceiling(ng / 2), 6) +# nr <- 2 +# } +# nr +# nc +# par(mfrow = c(nr, nc)) +# +# ymax <- 15 +# nlq <- -log10(1e-99 + unlist(Q)) +# ymax <- max(1.3, 1.2 * quantile(nlq, probs = 0.999, na.rm = TRUE)[1]) ## y-axis +# xmax <- max(1, 1.2 * quantile(abs(unlist(F)), probs = 0.999, na.rm = TRUE)[1]) ## x-axis +# +# shiny::withProgress(message = "rendering volcano plots ...", value = 0, { +# plt <- list() +# i <- 1 +# for (i in 1:length(comp)) { +# qval <- Q[[i]] +# fx <- F[[i]] +# fc.gene <- names(qval) +# is.sig <- (qval <= fdr & abs(fx) >= lfc) +# sig.genes <- fc.gene[which(is.sig)] +# genes1 <- sig.genes[which(toupper(sig.genes) %in% toupper(sel.genes))] +# genes2 <- head(genes1[order(-abs(fx[genes1]) * (-log10(qval[genes1])))], 10) +# xy <- data.frame(x = fx, y = -log10(qval)) +# is.sig2 <- factor(is.sig, levels = c(FALSE, TRUE)) +# +# plt[[i]] <- pgx.scatterPlotXY.GGPLOT( +# xy, +# title = comp[i], cex.title = 0.85, +# var = is.sig2, type = "factor", +# col = c("#bbbbbb", "#1e60bb"), +# legend.pos = "none", ## plotlib="ggplot", +# hilight = NULL, hilight2 = genes2, +# xlim = xmax * c(-1, 1), ylim = c(0, ymax), +# xlab = "difference (log2FC)", +# ylab = "significance (-log10q)", +# hilight.lwd = 0, hilight.col = "#1e60bb", hilight.cex = 1.5, +# cex = 0.45, cex.lab = 0.62 +# ) +# ## ggplot2::theme(legend.position='none') +# ## ggplot2::theme_bw(base_size=11) +# +# if (!interactive()) shiny::incProgress(1 / length(comp)) +# } +# }) ## progress +# +# +# ## patchwork::wrap_plots(plt, nrow=nr, ncol=nc) & +# ## ggplot2::theme_bw(base_size=11) & +# ## ggplot2::theme(legend.position='none') +# +# +# gridExtra::grid.arrange(grobs = plt, nrow = nr, ncol = nc) +# }) +# +# # volcanoAll_text <- "Under the Volcano (all) tab, the platform simultaneously displays multiple volcano plots for genes across all contrasts. This provides users an overview of the statistics for all comparisons. By comparing multiple volcano plots, the user can immediately see which comparison is statistically weak or strong." +# +# shiny::callModule(plotModule, +# id = "volcanoAll", +# func = volcanoAll.RENDER, +# func2 = volcanoAll.RENDER, +# info.text = volcanoAll_text, +# pdf.width = 16, pdf.height = 5, +# height = c(imgH, 500), width = c("auto", 1600), +# res = c(70, 90), +# title = "Volcano plots for all contrasts", +# add.watermark = WATERMARK +# ) + + # END Volcano (all contrasts) start code ######## + + # volcanoAll2 not used code ########### ## volcanoAll2.RENDER <- shiny::reactive({ - volcanoAll2.RENDER <- shiny::reactive({ - ngs <- inputData() - if (is.null(ngs)) { - return(NULL) - } - - - fdr <- 1 - lfc <- 0 - fdr <- as.numeric(input$gx_fdr) - lfc <- as.numeric(input$gx_lfc) - - sel.genes <- rownames(ngs$X) - if (input$gx_features != "") { - ## gset <- GSETS[input$gx_features] - gset <- getGSETS(input$gx_features) - sel.genes <- unique(unlist(gset)) - } - - ## ------------------------------------------------- - ## plot layout - ## ------------------------------------------------- - comp <- names(ngs$gx.meta$meta) - ng <- length(comp) - nn <- c(2, max(ceiling(ng / 2), 5)) - ## if(ng>12) nn = c(3,8) - par(mfrow = nn, mar = c(1, 1, 1, 1) * 0.2, mgp = c(2.6, 1, 0), oma = c(1, 1, 0, 0) * 2) - nr <- 2 - nc <- ceiling(sqrt(ng)) - if (ng > 24) { - nc <- max(ceiling(ng / 3), 6) - nr <- 3 - } else if (TRUE && ng <= 4) { - nc <- 4 - nr <- 1 - } else { - nc <- max(ceiling(ng / 2), 6) - nr <- 2 - } - nr - nc - ## par(mfrow=c(nr,nc)) - - tests <- "meta" - methods <- NULL - methods <- selected_gxmethods() - plist <- viz.Contrasts( - pgx = ngs, ## pgxRT=inputData, - methods = methods, type = "volcano", fixed.axis = TRUE, - psig = fdr, fc = lfc, ntop = 10, cex = 0.5, cex.lab = 0.7, - plots.only = TRUE, title = NULL, subtitle = NULL, caption = NULL - ) - - fig <- viz.showFigure(plist) + plot_layout(nrow = nr, ncol = nc) & - ggplot2::theme_bw(base_size = 11) & - ## ggplot2::theme_bw(base_size=16) & - ggplot2::theme(legend.position = "none") - - fig - }) - - volcanoAll2_text <- "Under the Volcano (all) tab, the platform simultaneously displays multiple volcano plots for genes across all contrasts. This provides users an overview of the statistics for all comparisons. By comparing multiple volcano plots, the user can immediately see which comparison is statistically weak or strong." - - volcanoAll2_caption <- "Volcano plot for all contrasts. Simultaneous visualisation of volcano plots of genes for all contrasts. Experimental contrasts with better statistical significance will show volcano plots with 'higher' wings." + # volcanoAll2.RENDER <- shiny::reactive({ + # ngs <- inputData() + # if (is.null(ngs)) { + # return(NULL) + # } + # + # + # fdr <- 1 + # lfc <- 0 + # fdr <- as.numeric(input$gx_fdr) + # lfc <- as.numeric(input$gx_lfc) + # + # sel.genes <- rownames(ngs$X) + # if (input$gx_features != "") { + # ## gset <- GSETS[input$gx_features] + # gset <- getGSETS(input$gx_features) + # sel.genes <- unique(unlist(gset)) + # } + # + # comp <- names(ngs$gx.meta$meta) + # ng <- length(comp) + # nn <- c(2, max(ceiling(ng / 2), 5)) + # ## if(ng>12) nn = c(3,8) + # par(mfrow = nn, mar = c(1, 1, 1, 1) * 0.2, mgp = c(2.6, 1, 0), oma = c(1, 1, 0, 0) * 2) + # nr <- 2 + # nc <- ceiling(sqrt(ng)) + # if (ng > 24) { + # nc <- max(ceiling(ng / 3), 6) + # nr <- 3 + # } else if (TRUE && ng <= 4) { + # nc <- 4 + # nr <- 1 + # } else { + # nc <- max(ceiling(ng / 2), 6) + # nr <- 2 + # } + # nr + # nc + # ## par(mfrow=c(nr,nc)) + # + # tests <- "meta" + # methods <- NULL + # methods <- selected_gxmethods() + # plist <- viz.Contrasts( + # pgx = ngs, ## pgxRT=inputData, + # methods = methods, type = "volcano", fixed.axis = TRUE, + # psig = fdr, fc = lfc, ntop = 10, cex = 0.5, cex.lab = 0.7, + # plots.only = TRUE, title = NULL, subtitle = NULL, caption = NULL + # ) + # + # fig <- viz.showFigure(plist) + plot_layout(nrow = nr, ncol = nc) & + # ggplot2::theme_bw(base_size = 11) & + # ## ggplot2::theme_bw(base_size=16) & + # ggplot2::theme(legend.position = "none") + # + # fig + # }) + # + # volcanoAll2_text <- "Under the Volcano (all) tab, the platform simultaneously displays multiple volcano plots for genes across all contrasts. This provides users an overview of the statistics for all comparisons. By comparing multiple volcano plots, the user can immediately see which comparison is statistically weak or strong." + # + # volcanoAll2_caption <- "Volcano plot for all contrasts. Simultaneous visualisation of volcano plots of genes for all contrasts. Experimental contrasts with better statistical significance will show volcano plots with 'higher' wings." + # + # shiny::callModule( + # plotModule, + # id = "volcanoAll2", + # func = volcanoAll2.RENDER, + # func2 = volcanoAll2.RENDER, + # ## plotlib = 'ggplot', + # info.text = volcanoAll2_text, + # ## caption = volcanoAll_caption, + # pdf.width = 16, pdf.height = 5, + # ## height = imgH, res=75, + # height = c(imgH, 500), width = c("auto", 1600), + # res = c(75, 95), + # title = "Volcano plots for all contrasts", + # add.watermark = WATERMARK + # ) + # + # + # output$volcanoAll2_UI <- shiny::renderUI({ + # shiny::fillCol( + # ## id = ns("topgenes"), + # height = rowH, + # flex = c(1, NA, NA), ## height = 370, + # plotWidget(ns("volcanoAll2")), + # shiny::br(), + # shiny::div(shiny::HTML(volcanoAll_caption), class = "caption") + # ) + # }) - shiny::callModule( - plotModule, - id = "volcanoAll2", - func = volcanoAll2.RENDER, - func2 = volcanoAll2.RENDER, - ## plotlib = 'ggplot', - info.text = volcanoAll2_text, - ## caption = volcanoAll_caption, - pdf.width = 16, pdf.height = 5, - ## height = imgH, res=75, - height = c(imgH, 500), width = c("auto", 1600), - res = c(75, 95), - title = "Volcano plots for all contrasts", - add.watermark = WATERMARK - ) + # end volcanoAll2 not used code ########### - output$volcanoAll2_UI <- shiny::renderUI({ - shiny::fillCol( - ## id = ns("topgenes"), - height = rowH, - flex = c(1, NA, NA), ## height = 370, - plotWidget(ns("volcanoAll2")), - shiny::br(), - shiny::div(shiny::HTML(volcanoAll_caption), class = "caption") - ) - }) + # Volcano (all methods) code refactored to plotmodule ######## - ## ================================================================================ - ## Volcano (all methods) - ## ================================================================================ volcanoMethods.RENDER <- shiny::reactive({ comp <- input$gx_contrast @@ -1172,6 +1173,9 @@ ExpressionBoard <- function(id, inputData) { add.watermark = WATERMARK ) + # end Volcano (all methods) code refactored to plotmodule ######## + + ## ================================================================================ ## Statistics Table ## ================================================================================ diff --git a/components/board.expression/R/expression_ui.R b/components/board.expression/R/expression_ui.R index ffecffdc4..e08475d54 100644 --- a/components/board.expression/R/expression_ui.R +++ b/components/board.expression/R/expression_ui.R @@ -138,7 +138,12 @@ ExpressionUI <- function(id) { ), shiny::tabPanel( "Volcano (all)", - plotWidget(ns("volcanoAll")), + expression_plot_volcanoAll_ui(ns("volcanoAll"), + label='A', + height = c(imgH, 500), + width = c("auto", 1600)), + # plotWidget(ns("volcanoAll")), + shiny::br(), tags$div( HTML("Volcano plot for all contrasts. Simultaneous visualisation of volcano From ea2acee34097d3b4248cc7c1cedba299cf753117 Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Fri, 27 Jan 2023 12:09:09 +0100 Subject: [PATCH 11/32] fix volcanoAll values being changes within fn --- components/board.expression/R/expression_plot_volcanoAll.R | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/components/board.expression/R/expression_plot_volcanoAll.R b/components/board.expression/R/expression_plot_volcanoAll.R index 0f3051093..033621ad2 100644 --- a/components/board.expression/R/expression_plot_volcanoAll.R +++ b/components/board.expression/R/expression_plot_volcanoAll.R @@ -54,8 +54,6 @@ expression_plot_volcanoAll_server <- function(id, ngs <- inputData() features = features() - fdr = fdr() - lfc = lfc() if (is.null(ngs)) { @@ -76,8 +74,8 @@ expression_plot_volcanoAll_server <- function(id, fdr <- 1 lfc <- 0 - fdr <- as.numeric(fdr) - lfc <- as.numeric(lfc) + fdr <- as.numeric(fdr()) + lfc <- as.numeric(lfc()) sel.genes <- rownames(ngs$X) if (features != "") { From 58726fdbae763ae34221402faa1e2b6b44f4fcfe Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Fri, 27 Jan 2023 12:09:34 +0100 Subject: [PATCH 12/32] volcanoMethod refactored --- .../R/expression_plot_volcanoMethods.R | 131 +++++++++--- .../board.expression/R/expression_server.R | 196 +++++++++--------- components/board.expression/R/expression_ui.R | 7 +- 3 files changed, 211 insertions(+), 123 deletions(-) diff --git a/components/board.expression/R/expression_plot_volcanoMethods.R b/components/board.expression/R/expression_plot_volcanoMethods.R index e538eb9c0..120dc511c 100644 --- a/components/board.expression/R/expression_plot_volcanoMethods.R +++ b/components/board.expression/R/expression_plot_volcanoMethods.R @@ -10,6 +10,7 @@ #' @param id #' @param label #' @param height +#' @param width #' #' @export expression_plot_volcanoMethods_ui <- function(id, @@ -18,10 +19,10 @@ expression_plot_volcanoMethods_ui <- function(id, width) { ns <- shiny::NS(id) - info_text = "" + info_text = "Under the Volcano (methods) tab, the platform displays the volcano plots provided by multiple differential expression calculation methods for the selected contrast. This provides users an overview of the statistics of all methods at the same time." PlotModuleUI(ns("pltmod"), - title = "", + title = "Volcano plots for all methods", label = label, plotlib = "plotly", info.text = info_text, @@ -39,42 +40,118 @@ expression_plot_volcanoMethods_ui <- function(id, #' #' @return #' @export -expression_plot_volcanoMethods_server <- function(id, watermark = FALSE) +expression_plot_volcanoMethods_server <- function(id, + inputData, + comp, #input$gx_contrast + features, #input$gx_features + fdr, #input$gx_fdr + lfc, #input$gx_lfc + watermark = FALSE) { - moduleServer( id, function(input, output, session) { + moduleServer(id, function(input, output, session) { #reactive function listening for changes in input plot_data <- shiny::reactive({ - #code here + + comp <- comp() + features <- features() + + if (is.null(comp)) { + return(NULL) + } + ngs <- inputData() + shiny::req(ngs) + if (is.null(features)) { + return(NULL) + } + + comp <- names(ngs$gx.meta$meta)[1] + fdr <- as.numeric(fdr()) #fdr <- 1 + lfc <- as.numeric(lfc()) #lfc <- 1 + genes <- NULL + + gset <- getGSETS(features) + sel.genes <- unique(unlist(gset)) + + return( + list( + ngs = ngs, + fdr = fdr, + lfc = lfc, + comp = comp, + sel.genes = sel.genes + )) + }) - plot.RENDER <- function() { + plot.RENDER <- function(){ pd <- plot_data() shiny::req(pd) - #plot code here - } + ## meta tables + mx <- pd[["ngs"]]$gx.meta$meta[[pd[["comp"]]]] + fc <- unclass(mx$fc) + ## pv = unclass(mx$p) + qv <- unclass(mx$q) + nlq <- -log10(1e-99 + qv) + 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"] + nplots <- min(24, ncol(qv)) - plotly.RENDER <- function() { - pd <- plot_data() - shiny::req(pd) + ## methods = names(ngs$gx.meta$output) + methods <- colnames(pd[["ngs"]]$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) { + nplots <- min(nplots, 24) + par(mfrow = c(3, 8), mar = c(4, 4, 2, 2) * 0) + nc <- 8 + } + + shiny::withProgress(message = "computing volcano plots ...", value = 0, { + i <- 1 + for (i in 1:nplots) { + fx <- fc[, i] + ## pval = pv[,i] + qval <- qv[, i] + sig.genes <- fc.genes[which(qval <= pd[["fdr"]] & abs(fx) >= pd[["lfc"]])] + ## genes1 = intersect(sig.genes, sel.genes) + genes1 <- sig.genes[which(toupper(sig.genes) %in% toupper(pd[["sel.genes"]]))] + gx.volcanoPlot.XY( + x = fx, pv = qval, gene = fc.genes, + render = "canvas", n = 5000, nlab = 5, + xlim = xlim, ylim = c(0, ymax), axes = FALSE, + use.fdr = TRUE, p.sig = pd[["fdr"]], lfc = pd[["lfc"]], + ## main=comp[i], + ## ma.plot=TRUE, use.rpkm=TRUE, + cex = 0.6, lab.cex = 1.5, highlight = genes1 + ) - df <- pd - - ## plot as regular plot - plotly::plot_ly(data = df, - type = '', - x = "", - y = "", - ## hoverinfo = "text", - hovertext = ~annot, - marker = list(color = ~color) - ) + is.first <- (i %% nc == 1) + last.row <- ((i - 1) %/% nc == (nplots - 1) %/% nc) + is.first + last.row + if (is.first) axis(2, mgp = c(2, 0.7, 0), cex.axis = 0.8) + if (last.row) axis(1, mgp = c(2, 0.7, 0), cex.axis = 0.8) + graphics::box(lwd = 1, col = "black", lty = "solid") + legend("top", + legend = colnames(fc)[i], cex = 1.2, + bg = "white", box.lty = 0, inset = c(0, 0.01), + x.intersp = 0.1, y.intersp = 0.1 + ) + shiny::incProgress(1 / length(nplots)) + } + + }) } - modal_plotly.RENDER <- function() { - plotly.RENDER() %>% + + + modal_plot.RENDER <- function() { + plot.RENDER() %>% plotly::layout( ## showlegend = TRUE, font = list( @@ -87,12 +164,12 @@ expression_plot_volcanoMethods_server <- function(id, watermark = FALSE) PlotModuleServer( "pltmod", plotlib = "plotly", - func = plotly.RENDER, - func2 = modal_plotly.RENDER, + func = plot.RENDER, + func2 = modal_plot.RENDER, csvFunc = plot_data, ## *** downloadable data as CSV res = c(80,170), ## resolution of plots pdf.width = 6, pdf.height = 6, add.watermark = watermark ) - }## end of moduleServer + })## end of moduleServer } diff --git a/components/board.expression/R/expression_server.R b/components/board.expression/R/expression_server.R index 5e4fa0bd8..f06e7c747 100644 --- a/components/board.expression/R/expression_server.R +++ b/components/board.expression/R/expression_server.R @@ -401,6 +401,16 @@ ExpressionBoard <- function(id, inputData) { lfc = shiny::reactive(input$gx_lfc), watermark = FALSE) + # tab differential expression > Volcano Methods #### + + expression_plot_volcanoMethods_server(id = "volcanoMethods", + inputData = inputData, + comp = shiny::reactive(input$gx_contrast), + features = shiny::reactive(input$gx_features), + fdr = shiny::reactive(input$gx_fdr), + lfc = shiny::reactive(input$gx_lfc), + watermark = FALSE) + @@ -1079,99 +1089,99 @@ ExpressionBoard <- function(id, inputData) { # Volcano (all methods) code refactored to plotmodule ######## - volcanoMethods.RENDER <- shiny::reactive({ - comp <- input$gx_contrast - if (is.null(comp)) { - return(NULL) - } - ngs <- inputData() - shiny::req(ngs) - if (is.null(input$gx_features)) { - return(NULL) - } - - fdr <- 1 - lfc <- 1 - comp <- names(ngs$gx.meta$meta)[1] - fdr <- as.numeric(input$gx_fdr) - lfc <- as.numeric(input$gx_lfc) - genes <- NULL - - gset <- getGSETS(input$gx_features) - sel.genes <- unique(unlist(gset)) - - ## meta tables - mx <- ngs$gx.meta$meta[[comp]] - fc <- unclass(mx$fc) - ## pv = unclass(mx$p) - qv <- unclass(mx$q) - nlq <- -log10(1e-99 + qv) - 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 <- ngs$genes[rownames(mx), "gene_name"] - nplots <- min(24, ncol(qv)) - - ## methods = names(ngs$gx.meta$output) - methods <- colnames(ngs$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) { - nplots <- min(nplots, 24) - par(mfrow = c(3, 8), mar = c(4, 4, 2, 2) * 0) - nc <- 8 - } - - shiny::withProgress(message = "computing volcano plots ...", value = 0, { - i <- 1 - for (i in 1:nplots) { - fx <- fc[, i] - ## pval = pv[,i] - qval <- qv[, i] - sig.genes <- fc.genes[which(qval <= fdr & abs(fx) >= lfc)] - ## genes1 = intersect(sig.genes, sel.genes) - genes1 <- sig.genes[which(toupper(sig.genes) %in% toupper(sel.genes))] - gx.volcanoPlot.XY( - x = fx, pv = qval, gene = fc.genes, - render = "canvas", n = 5000, nlab = 5, - xlim = xlim, ylim = c(0, ymax), axes = FALSE, - use.fdr = TRUE, p.sig = fdr, lfc = lfc, - ## main=comp[i], - ## ma.plot=TRUE, use.rpkm=TRUE, - cex = 0.6, lab.cex = 1.5, highlight = genes1 - ) - - is.first <- (i %% nc == 1) - last.row <- ((i - 1) %/% nc == (nplots - 1) %/% nc) - is.first - last.row - if (is.first) axis(2, mgp = c(2, 0.7, 0), cex.axis = 0.8) - if (last.row) axis(1, mgp = c(2, 0.7, 0), cex.axis = 0.8) - graphics::box(lwd = 1, col = "black", lty = "solid") - legend("top", - legend = colnames(fc)[i], cex = 1.2, - bg = "white", box.lty = 0, inset = c(0, 0.01), - x.intersp = 0.1, y.intersp = 0.1 - ) - shiny::incProgress(1 / length(nplots)) - } - }) - }) - - volcanoMethods_text <- "Under the Volcano (methods) tab, the platform displays the volcano plots provided by multiple differential expression calculation methods for the selected contrast. This provides users an overview of the statistics of all methods at the same time." - - shiny::callModule(plotModule, - id = "volcanoMethods", - func = volcanoMethods.RENDER, - func2 = volcanoMethods.RENDER, - title = "Volcano plots for all methods", - info.text = volcanoMethods_text, - ## caption = volcanoMethods_caption, - height = c(imgH, 450), width = c("auto", 1600), - res = c(75, 95), - pdf.width = 18, pdf.height = 6, - add.watermark = WATERMARK - ) + # volcanoMethods.RENDER <- shiny::reactive({ + # comp <- input$gx_contrast + # if (is.null(comp)) { + # return(NULL) + # } + # ngs <- inputData() + # shiny::req(ngs) + # if (is.null(input$gx_features)) { + # return(NULL) + # } + # + # fdr <- 1 + # lfc <- 1 + # comp <- names(ngs$gx.meta$meta)[1] + # fdr <- as.numeric(input$gx_fdr) + # lfc <- as.numeric(input$gx_lfc) + # genes <- NULL + # + # gset <- getGSETS(input$gx_features) + # sel.genes <- unique(unlist(gset)) + # + # ## meta tables + # mx <- ngs$gx.meta$meta[[comp]] + # fc <- unclass(mx$fc) + # ## pv = unclass(mx$p) + # qv <- unclass(mx$q) + # nlq <- -log10(1e-99 + qv) + # 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 <- ngs$genes[rownames(mx), "gene_name"] + # nplots <- min(24, ncol(qv)) + # + # ## methods = names(ngs$gx.meta$output) + # methods <- colnames(ngs$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) { + # nplots <- min(nplots, 24) + # par(mfrow = c(3, 8), mar = c(4, 4, 2, 2) * 0) + # nc <- 8 + # } + # + # shiny::withProgress(message = "computing volcano plots ...", value = 0, { + # i <- 1 + # for (i in 1:nplots) { + # fx <- fc[, i] + # ## pval = pv[,i] + # qval <- qv[, i] + # sig.genes <- fc.genes[which(qval <= fdr & abs(fx) >= lfc)] + # ## genes1 = intersect(sig.genes, sel.genes) + # genes1 <- sig.genes[which(toupper(sig.genes) %in% toupper(sel.genes))] + # gx.volcanoPlot.XY( + # x = fx, pv = qval, gene = fc.genes, + # render = "canvas", n = 5000, nlab = 5, + # xlim = xlim, ylim = c(0, ymax), axes = FALSE, + # use.fdr = TRUE, p.sig = fdr, lfc = lfc, + # ## main=comp[i], + # ## ma.plot=TRUE, use.rpkm=TRUE, + # cex = 0.6, lab.cex = 1.5, highlight = genes1 + # ) + # + # is.first <- (i %% nc == 1) + # last.row <- ((i - 1) %/% nc == (nplots - 1) %/% nc) + # is.first + # last.row + # if (is.first) axis(2, mgp = c(2, 0.7, 0), cex.axis = 0.8) + # if (last.row) axis(1, mgp = c(2, 0.7, 0), cex.axis = 0.8) + # graphics::box(lwd = 1, col = "black", lty = "solid") + # legend("top", + # legend = colnames(fc)[i], cex = 1.2, + # bg = "white", box.lty = 0, inset = c(0, 0.01), + # x.intersp = 0.1, y.intersp = 0.1 + # ) + # shiny::incProgress(1 / length(nplots)) + # } + # }) + # }) + # + # volcanoMethods_text <- "Under the Volcano (methods) tab, the platform displays the volcano plots provided by multiple differential expression calculation methods for the selected contrast. This provides users an overview of the statistics of all methods at the same time." + # + # shiny::callModule(plotModule, + # id = "volcanoMethods", + # func = volcanoMethods.RENDER, + # func2 = volcanoMethods.RENDER, + # title = "Volcano plots for all methods", + # info.text = volcanoMethods_text, + # ## caption = volcanoMethods_caption, + # height = c(imgH, 450), width = c("auto", 1600), + # res = c(75, 95), + # pdf.width = 18, pdf.height = 6, + # add.watermark = WATERMARK + # ) # end Volcano (all methods) code refactored to plotmodule ######## diff --git a/components/board.expression/R/expression_ui.R b/components/board.expression/R/expression_ui.R index e08475d54..e04fdc863 100644 --- a/components/board.expression/R/expression_ui.R +++ b/components/board.expression/R/expression_ui.R @@ -142,8 +142,6 @@ ExpressionUI <- function(id) { label='A', height = c(imgH, 500), width = c("auto", 1600)), - # plotWidget(ns("volcanoAll")), - shiny::br(), tags$div( HTML("Volcano plot for all contrasts. Simultaneous visualisation of volcano @@ -153,7 +151,10 @@ ExpressionUI <- function(id) { ), shiny::tabPanel( "Volcano (methods)", - plotWidget(ns("volcanoMethods")), + expression_plot_volcanoMethods_ui(id = ns("volcanoMethods"), + label ='A', + height = c(imgH, 450), + width = c("auto", 1600)), shiny::br(), tags$div( HTML("Volcano plot for all statistical methods. Simultaneous visualisation of volcano plots From 7cf6853e61a2ecb24456cbf411f024c17e667427 Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Sat, 28 Jan 2023 13:26:43 +0100 Subject: [PATCH 13/32] template for table refactoring --- .../board.expression/R/expression_table.R | 55 +++++++++++++++++++ 1 file changed, 55 insertions(+) create mode 100644 components/board.expression/R/expression_table.R diff --git a/components/board.expression/R/expression_table.R b/components/board.expression/R/expression_table.R new file mode 100644 index 000000000..b2ead83e3 --- /dev/null +++ b/components/board.expression/R/expression_table.R @@ -0,0 +1,55 @@ +## +## This file is part of the Omics Playground project. +## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. +## + +#' UI code for table code: expression board +#' +#' @param id +#' @param label +#' @param height +#' @param width +#' +#' @export +compare_table_corr_score_ui <- function(id, + label='', + height, + width) { + + ns <- shiny::NS(id) + + tableWidget(ns("table")) + +} + +#' Server side table code: expression board +#' +#' @param id +#' @param watermark +#' +#' @export +compare_table_corr_score_server <- function(id, + watermark=FALSE){ + moduleServer( id, function(input, output, session) { + + score_table.RENDER <- shiny::reactive({ + + #code here + + }) + + score_table_info = "" + + score_table <- shiny::callModule( + tableModule, id = "table", + func = "", ## ns=ns, + info.text = table_info, + title = tags$div( + HTML('')), + height = c(,), + width = c(,) + ) + return(score_table) + } + ) +} \ No newline at end of file From 2868f18f8d8d2ad4b3f56d025e6399d8ee15d7e1 Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Sat, 28 Jan 2023 13:27:29 +0100 Subject: [PATCH 14/32] comment out code expression_table to avoid crashes --- .../board.expression/R/expression_table.R | 110 +++++++++--------- 1 file changed, 55 insertions(+), 55 deletions(-) diff --git a/components/board.expression/R/expression_table.R b/components/board.expression/R/expression_table.R index b2ead83e3..4f8220097 100644 --- a/components/board.expression/R/expression_table.R +++ b/components/board.expression/R/expression_table.R @@ -1,55 +1,55 @@ -## -## This file is part of the Omics Playground project. -## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. -## - -#' UI code for table code: expression board -#' -#' @param id -#' @param label -#' @param height -#' @param width -#' -#' @export -compare_table_corr_score_ui <- function(id, - label='', - height, - width) { - - ns <- shiny::NS(id) - - tableWidget(ns("table")) - -} - -#' Server side table code: expression board -#' -#' @param id -#' @param watermark -#' -#' @export -compare_table_corr_score_server <- function(id, - watermark=FALSE){ - moduleServer( id, function(input, output, session) { - - score_table.RENDER <- shiny::reactive({ - - #code here - - }) - - score_table_info = "" - - score_table <- shiny::callModule( - tableModule, id = "table", - func = "", ## ns=ns, - info.text = table_info, - title = tags$div( - HTML('')), - height = c(,), - width = c(,) - ) - return(score_table) - } - ) -} \ No newline at end of file +#' ## +#' ## This file is part of the Omics Playground project. +#' ## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. +#' ## +#' +#' #' UI code for table code: expression board +#' #' +#' #' @param id +#' #' @param label +#' #' @param height +#' #' @param width +#' #' +#' #' @export +#' compare_table_corr_score_ui <- function(id, +#' label='', +#' height, +#' width) { +#' +#' ns <- shiny::NS(id) +#' +#' tableWidget(ns("table")) +#' +#' } +#' +#' #' Server side table code: expression board +#' #' +#' #' @param id +#' #' @param watermark +#' #' +#' #' @export +#' compare_table_corr_score_server <- function(id, +#' watermark=FALSE){ +#' moduleServer( id, function(input, output, session) { +#' +#' score_table.RENDER <- shiny::reactive({ +#' +#' #code here +#' +#' }) +#' +#' score_table_info = "" +#' +#' score_table <- shiny::callModule( +#' tableModule, id = "table", +#' func = "", ## ns=ns, +#' info.text = table_info, +#' title = tags$div( +#' HTML('')), +#' height = c(,), +#' width = c(,) +#' ) +#' return(score_table) +#' } +#' ) +#' } \ No newline at end of file From 4fb62ac3a510865d50fb8b9c65007b5f3c6d18dd Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Sat, 28 Jan 2023 13:35:02 +0100 Subject: [PATCH 15/32] remove old plot code --- .../board.expression/R/expression_server.R | 774 ------------------ 1 file changed, 774 deletions(-) diff --git a/components/board.expression/R/expression_server.R b/components/board.expression/R/expression_server.R index f06e7c747..991765f0b 100644 --- a/components/board.expression/R/expression_server.R +++ b/components/board.expression/R/expression_server.R @@ -412,780 +412,6 @@ ExpressionBoard <- function(id, inputData) { watermark = FALSE) - - - # MA old code refactored into plot module ##### - # plots_maplot.RENDER <- shiny::reactive({ - # comp1 = input$gx_contrast - # if(length(comp1)==0) return(NULL) - # - # ngs <- inputData() - # shiny::req(ngs) - # - # fdr=1;lfc=1 - # fdr = as.numeric(input$gx_fdr) - # lfc = as.numeric(input$gx_lfc) - # - # res = fullDiffExprTable() - # if(is.null(res)) return(NULL) - # fc.genes = as.character(res[,grep("^gene$|gene_name",colnames(res))]) - # ##pval = res$P.Value - # ##pval = res[,grep("P.Value|meta.p|pval|p.val",colnames(res))[1]] - # - # ## filter genes by gene family or gene set - # fam.genes = unique(unlist(ngs$families[10])) - # ##fam.genes = unique(unlist(ngs$families[input$gx_features])) - # fam.genes = res$gene_name - # if(input$gx_features!="") { - # ##gset <- GSETS[input$gx_features] - # gset <- getGSETS( input$gx_features ) - # fam.genes = unique(unlist(gset)) - # } - # jj <- match(toupper(fam.genes),toupper(res$gene_name)) - # sel.genes <- res$gene_name[setdiff(jj,NA)] - # - # qval = res[,grep("adj.P.Val|meta.q|qval|padj",colnames(res))[1]] - # fx = res[,grep("logFC|meta.fx|fc",colnames(res))[1]] - # - # sig.genes = fc.genes[which(qval <= fdr & abs(fx) > lfc )] - # sel.genes = intersect(sig.genes, sel.genes) - # - # xlim = c(-1,1)*max(abs(fx),na.rm=TRUE) - # ma = rowMeans(ngs$X[rownames(res),], na.rm=TRUE) - # - # par(mfrow=c(1,1), mar=c(4,3,2,1.5), mgp=c(2,0.8,0), oma=c(1,0,0.5,0)) - # par(mfrow=c(1,1), mar=c(4,3,1,1.5), mgp=c(2,0.8,0), oma=c(0,0,0,0)) - # gx.volcanoPlot.XY( x=fx, pv=qval, gene=fc.genes, lfc=lfc, - # render="canvas", n=5000, nlab=12, - # xlim=xlim, ylim=c(0,15), - # xlab="average expression (log2CPM)", - # ylab="effect size (log2FC)", - # ma_plot=TRUE, ma = ma, ## hi.col="#222222", - # use.fdr=TRUE, p.sig=fdr, ##main=comp1, - # highlight = sel.genes, - # lab.cex = lab.cex, - # ## highlight = sel.genes, - # ## main="MA plot", - # cex=0.9, lab.cex=1.4, cex.main=1.0 ) - # }) - # - # plots_maplot.PLOTLY <- shiny::reactive({ - # comp1 = input$gx_contrast - # if(length(comp1)==0) return(NULL) - # - # ngs <- inputData() - # shiny::req(ngs) - # - # dbg("[plots_maplot.PLOTLY] reacted") - # - # fdr=1;lfc=1 - # fdr = as.numeric(input$gx_fdr) - # lfc = as.numeric(input$gx_lfc) - # - # res = fullDiffExprTable() - # if(is.null(res)) return(NULL) - # fc.genes = as.character(res[,grep("^gene$|gene_name",colnames(res))]) - # ##pval = res$P.Value - # ##pval = res[,grep("P.Value|meta.p|pval|p.val",colnames(res))[1]] - # - # ## filter genes by gene family or gene set - # fam.genes = unique(unlist(ngs$families[10])) - # ##fam.genes = unique(unlist(ngs$families[input$gx_features])) - # fam.genes = res$gene_name - # if(input$gx_features!="") { - # ##gset <- GSETS[input$gx_features] - # gset <- getGSETS( input$gx_features ) - # fam.genes = unique(unlist(gset)) - # } - # jj <- match(toupper(fam.genes),toupper(res$gene_name)) - # sel.genes <- res$gene_name[setdiff(jj,NA)] - # - # qval = res[,grep("adj.P.Val|meta.q|qval|padj",colnames(res))[1]] - # y = res[,grep("logFC|meta.fx|fc",colnames(res))[1]] - # - # scaled.x <- scale(-log10(qval),center=FALSE) - # scaled.y <- scale(y,center=FALSE) - # fc.genes <- rownames(res) - # impt <- function(g) { - # j = match(g, fc.genes) - # x1 = scaled.x[j] - # y1 = scaled.y[j] - # x = sign(x1)*(0.25*x1**2 + y1**2) - # names(x)=g - # x - # } - # - # sig.genes = fc.genes[which(qval <= fdr & abs(y) > lfc )] - # sel.genes = intersect(sig.genes, sel.genes) - # - # ## are there any genes/genesets selected? - # sel1 = genetable$rows_selected() - # df1 = filteredDiffExprTable() - # sel2 = gsettable$rows_selected() - # df2 <- gx_related_genesets() - # lab.cex = 1 - # gene.selected <- !is.null(sel1) && !is.null(df1) - # gset.selected <- !is.null(sel2) && !is.null(df2) - # if(gene.selected && !gset.selected) { - # lab.genes = rownames(df1)[sel1] - # sel.genes = lab.genes - # lab.cex = 1.3 - # } else if(gene.selected && gset.selected) { - # gs <- rownames(df2)[sel2] - # dbg("[plots_maplot.PLOTLY] gs = ",gs) - # ##gset <- GSETS[[gs]] - # gset <- unlist(getGSETS(gs)) - # sel.genes = intersect(sel.genes, gset) - # lab.genes = c( head(sel.genes[order(impt(sel.genes))],10), - # head(sel.genes[order(-impt(sel.genes))],10) ) - # lab.cex = 1 - # } else { - # lab.genes = c( head(sel.genes[order(impt(sel.genes))],10), - # head(sel.genes[order(-impt(sel.genes))],10) ) - # lab.cex = 1 - # } - # - # ylim = c(-1,1)*max(abs(y),na.rm=TRUE) - # x = rowMeans( ngs$X[rownames(res),], na.rm=TRUE) - # - # impt <- function(g) { - # j = match(g, fc.genes) - # x1 = scale(x,center=FALSE)[j] - # y1 = scale(y,center=FALSE)[j] - # x = sign(y1)*(1.0*x1**2 + 1.0*y1**2) - # names(x)=g - # x - # } - # lab.genes = c( head(sel.genes[order(impt(sel.genes))],10), - # head(sel.genes[order(-impt(sel.genes))],10) ) - # - # highlight=sel.genes;label=lab.genes;names=fc.genes - # plt <- plotlyMA( - # x=x, y=y, names=fc.genes, - # source = "plot1", marker.type = "scattergl", - # highlight = sel.genes, - # label = lab.genes, label.cex = lab.cex, - # group.names = c("group1","group0"), - # ##xlim=xlim, ylim=ylim, ## hi.col="#222222", - # ##use.fdr=TRUE, - # psig = fdr, lfc = lfc, - # xlab = "average expression (log2.CPM)", - # ylab = "effect size (log2.FC)", - # marker.size = 4, - # displayModeBar = FALSE, - # showlegend = FALSE) %>% - # plotly::layout( margin = list(b=65) ) - # - # dbg("[plots_maplot.PLOTLY] done!") - # - # return(plt) - # }) - # - # shiny::callModule( plotModule, - # id="plots_maplot", - # ##func = plots_maplot.RENDER, - # ##func2 = plots_maplot.RENDER, - # func = plots_maplot.PLOTLY, plotlib="plotly", - # info.text = plots_maplot_text, label="b", - # title = "MA plot", - # height = imgH, - # pdf.width=6, pdf.height=6, res=75, - # add.watermark = WATERMARK - # ) - - # MA end of old code refactored into plot module ##### - - # topgenesbarplot old code NOT refactored into plot module #### - - # plots_topgenesbarplot.RENDER <- shiny::reactive({ - # - # ngs = inputData() - # shiny::req(ngs) - # comp1 = input$gx_contrast - # - # dbg("plots_topgenesbarplot.RENDER: reacted") - # - # if(length(comp1)==0) return(NULL) - # - # ## get table - # ##sel.row=1;pp=rownames(ngs$X)[1] - # ##sel.row = input$genetable_rows_selected - # - # res = filteredDiffExprTable() - # if(is.null(res)) return(NULL) - # - # ##fc <- res$meta.fx - # fc <- res$logFC - # names(fc) <- rownames(res) - # 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]) - # klr.pal <- RColorBrewer::brewer.pal(4,"Paired")[2:1] - # klr <- c( rep(klr.pal[1],length(top.up)), rep(klr.pal[2],length(top.dn)) ) - # names(fc.top) <- sub(".*:","",names(fc.top)) - # - # ii <- order(fc.top) - # par(mfrow=c(1,1), mar=c(5,3,1,1), mgp=c(2,0.8,0), oma=c(0,0,0,0)) - # barplot(fc.top[ii], las=3, cex.names=0.75, ylab="fold change", - # col=klr[ii], ylim=c(-1.1,1.2)*max(abs(fc.top),na.rm=TRUE) ) - # - # ## warning A_vs_B or B_vs_A not checked!!! - # groups <- strsplit(comp1,split="[._ ]vs[._ ]")[[1]] - # if(is.POSvsNEG(ngs)) groups <- rev(groups) - # groups <- gsub("@.*","",gsub(".*[:]","",groups)) - # tt <- c( paste("up in",groups[2]), paste("up in",groups[1]) ) - # ##tt <- c( paste("up in",groups[1]), paste("down in",groups[1]) ) - # legend("topleft", legend=tt, fill=klr.pal, cex=0.9, y.intersp=0.85, bty="n") - # ##title("top DE genes",cex.main=1) - # - # dbg("plots_topgenesbarplot.RENDER: done\n") - # - # }) - # - # shiny::callModule( - # plotModule, - # id="plots_topgenesbarplot", ## ns=ns, - # func = plots_topgenesbarplot.RENDER, - # func2 = plots_topgenesbarplot.RENDER, - # info.text = plots_topgenesbarplot_text, label="c", - # title = "top DE genes", - # height = c(imgH,500), width=c('auto',800), - # pdf.width=6, pdf.height=6, res=75, - # add.watermark = WATERMARK - # ) - # - # - # plots_topfoldchange.RENDER <- shiny::reactive({ - # - # ngs = inputData() - # shiny::req(ngs) - # - # ## get table - # ##sel=1;pp=rownames(ngs$X)[1] - # sel = genetable$rows_selected() - # if(is.null(sel) || length(sel)==0) { - # frame() - # text(0.5,0.5, "No gene selected", col='black') - # return(NULL) - # } - # - # res = filteredDiffExprTable() - # if(is.null(res) || is.null(sel)) return(NULL) - # psel <- rownames(res)[sel] - # gene <- ngs$genes[psel,"gene_name"] - # - # ##fc <- res$meta.fx - # comp=1 - # comp = input$gx_contrast - # if(is.null(comp) || length(comp)==0) return(NULL) - # fc <- sapply( ngs$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]) - # fc.top <- fc.top[head(order(-abs(fc.top)),15)] - # fc.top <- sort(fc.top) - # fc.top <- head(c(fc.top, rep(NA,99)),15) - # - # klr.pal <- RColorBrewer::brewer.pal(4,"Paired")[2:1] - # ##klr.pal <- BLUERED(16)[c(3,14)] - # klr <- klr.pal[1 + 1*(sign(fc.top)<0)] - # - # par(mfrow=c(1,1), mar=c(4,4,2,2)*1, mgp=c(2,0.8,0), oma=c(1,1,1,0.5)*0.2) - # par(mfrow=c(1,1), mar=c(6,3,0,1), mgp=c(2,0.8,0), oma=c(1,0,0,0)) - # nch <- max(nchar(names(fc.top))) - # m1 <- ifelse(nch > 12, 12, 8) - # m1 <- ifelse(nch > 30, 16, m1) - # - # ##par( mar=c(4,m1,2,0.5) ) - # par( mar=c(3.2,m1-0.5,1,1) ) - # cex1 <- 0.9 - # nn <- sum(!is.na(fc.top)) - # if(nn>15) cex1 <- 0.8 - # barplot(fc.top, col=klr, horiz=TRUE, las=1, - # xlim=c(-1,1)*max(abs(fc.top),na.rm=TRUE), - # cex.names=cex1, xlab="fold change (log2)") - # title(gene, cex.main=1, line=-0.15) - # - # }) - # - # shiny::callModule( plotModule, - # id = "plots_topfoldchange", - # func = plots_topfoldchange.RENDER, - # func2 = plots_topfoldchange.RENDER, - # info.text = plots_topfoldchange_text, - # title = "Gene in contrasts", label = "d", - # height = c(imgH,500), width=c('auto',700), - # pdf.width=6, pdf.height=6, res=74, - # add.watermark = WATERMARK - # ) - # - # # end of topgenesbarplot old code NOT into plot module #### - - - # # boxplot old code refactored into plot module #### - # - # plots_boxplot.RENDER <- shiny::reactive({ - # - # ngs = inputData() - # shiny::req(ngs) - # - # ## get table - # ##sel=1 - # sel = genetable$rows_selected() - # if(is.null(sel) || length(sel)==0) { - # frame() - # text(0.5,0.5, "No gene selected", col='black') - # return(NULL) - # } - # - # res = filteredDiffExprTable() - # if(is.null(res) || is.null(sel)) return(NULL) - # - # psel <- rownames(res)[sel] - # gene=ngs$genes[1,"gene_name"];comp=1;grouped=TRUE;logscale=TRUE;srt=45 - # gene = ngs$genes[psel,"gene_name"] - # comp = input$gx_contrast - # shiny::req(comp) - # grouped <- input$boxplot_grouped - # logscale <- input$boxplot_logscale - # srt <- ifelse(grouped, 0, 35) - # - # par(mfrow=c(1,1), mar=c(4,3,1.5,1.5), mgp=c(2,0.8,0), oma=c(1,0.5,0,0.5)) - # pgx.plotExpression(ngs, gene, comp=comp, grouped=grouped, - # max.points = 200, ## slow!! - # names = TRUE, - # logscale=logscale, srt=srt) - # - # }) - # - # ##plots_boxplot - # plots_boxplot_opts = shiny::tagList( - # withTooltip( shiny::checkboxInput(ns('boxplot_grouped'),'grouped',TRUE), - # "Group expression values by conditions.", - # placement="right", options = list(container = "body")), - # withTooltip( shiny::checkboxInput(ns('boxplot_logscale'),'log scale',TRUE), - # "Show logarithmic (log2CPM) expression values.", - # placement="right", options = list(container = "body")) - # ) - # - # shiny::callModule( plotModule, - # id = "plots_boxplot", label = "c", - # func = plots_boxplot.RENDER, - # func2 = plots_boxplot.RENDER, - # options = plots_boxplot_opts, - # info.text = "Differential expression boxplot for selected gene.", - # info.width = "150px", - # title = "Differential expression", - # height = imgH, - # pdf.width=6, pdf.height=6, res=75, - # add.watermark = WATERMARK - # ) - - - # end boxplot old code refactored into plot module #### - - - # topgenes old code refactor into plotmodule ##### - - # topgenes.RENDER <- shiny::reactive({ - # - # ngs <- inputData() - # shiny::req(ngs) - # - # res <- filteredDiffExprTable() - # if(is.null(res) || nrow(res)==0) return(NULL) - # - # ## filter on active rows (using search) - # ##ii <- genetable$rows_all() - # ii <- genetable$rows_current() - # res <- res[ii,,drop=FALSE] - # if(nrow(res)==0) return(NULL) - # - # comp=1;grouped=0;logscale=1 - # comp = input$gx_contrast - # grouped <- !input$gx_ungroup - # logscale <- input$gx_logscale - # showothers <- input$gx_showothers - # - # mar1 = 3.5 - # ylab = ifelse(logscale, "log2CPM", "CPM") - # - # ny <- nrow(ngs$samples) ## ???!! - # show.names <- ifelse(!grouped & ny>25, FALSE, TRUE) - # ##nx = ifelse(grouped, ngrp, length(y)) - # nx = ifelse(grouped, 3, ny) - # nc = 4 - # nc = 8 - # if( nx <= 3) nc <- 10 - # if( nx > 10) nc <- 5 - # if( nx > 25) nc <- 4 - # srt = 35 - # sumlen.grpnames <- sum(nchar(strsplit(sub(".*:","",comp),split="_vs_")[[1]])) - # if(show.names && sumlen.grpnames <= 20) srt <- 0 - # - # nc <- 8 - # par(mfrow=c(2,nc), mar=c(mar1,3.5,1,1), mgp=c(2,0.8,0), oma=c(0.1,0.6,0,0.6) ) - # i=1 - # for(i in 1:nrow(res)) { - # ## if(i > length(top.up)) { frame() } - # ##gene = sub(".*:","",top.up[i]) - # gene = rownames(res)[i] - # pgx.plotExpression( - # ngs, gene, comp=comp, grouped=grouped, - # max.points = 200, ## slow!! - # collapse.others=TRUE, showothers=showothers, - # ylab = ylab, xlab="", srt=srt, - # logscale=logscale, names=show.names, main="") - # title( gene, cex.main=1, line=-0.6) - # } - # }) - # - # topgenes_opts = shiny::tagList( - # withTooltip( shiny::checkboxInput(ns('gx_logscale'),'log scale',TRUE), - # "Logarithmic scale the counts (abundance levels).", - # placement="right", options = list(container = "body")), - # withTooltip( shiny::checkboxInput(ns('gx_ungroup'),'ungroup samples',FALSE), - # "Ungroup samples in the plot", - # placement="right", options = list(container = "body")), - # withTooltip( shiny::checkboxInput(ns('gx_showothers'),'show others',FALSE), - # "Show the 'others' class (if any)", - # placement="right", options = list(container = "body")) - # ) - # - # topgenes_text = "The Top genes section shows the average expression plots across the samples for the top differentially (both positively and negatively) expressed genes for the selected comparison from the Contrast settings. Under the plot Settings, users can scale the abundance levels (counts) or ungroup the samples in the plot from the log scale and ungroup samples settings, respectively." - # - # topgenes_caption = "Top differentially expressed genes. Expression barplots of the top most differentially (both positively and negatively) expressed genes for the selected contrast." - # - # shiny::callModule( plotModule, - # id = "topgenes", - # func = topgenes.RENDER, - # func2 = topgenes.RENDER, - # options = topgenes_opts, - # info.text = topgenes_text, - # ##caption = topgenes_caption, - # height = c(imgH,420), width = c('auto',1600), - # res = c(90,105), - # pdf.width=14, pdf.height=3.5, - # title="Expression of top differentially expressed genes", - # add.watermark = WATERMARK - # ) - - # end topgenes old code refactor into plotmodule ##### - - - # Volcano (all contrasts) start code refactored to plotmodule ######## -# -# -# volcanoAll.RENDER <- shiny::reactive({ -# -# ngs <- inputData() -# if (is.null(ngs)) { -# return(NULL) -# } -# ct <- getAllContrasts() -# F <- ct$F -# Q <- ct$Q -# -# ## comp = names(ngs$gx.meta$meta) -# comp <- names(F) -# if (length(comp) == 0) { -# return(NULL) -# } -# if (is.null(input$gx_features)) { -# return(NULL) -# } -# -# fdr <- 1 -# lfc <- 0 -# fdr <- as.numeric(input$gx_fdr) -# lfc <- as.numeric(input$gx_lfc) -# -# sel.genes <- rownames(ngs$X) -# if (input$gx_features != "") { -# gset <- getGSETS(input$gx_features) -# sel.genes <- unique(unlist(gset)) -# } -# -# ng <- length(comp) -# nn <- c(2, max(ceiling(ng / 2), 5)) -# ## if(ng>12) nn = c(3,8) -# par(mfrow = nn, mar = c(1, 1, 1, 1) * 0.2, mgp = c(2.6, 1, 0), oma = c(1, 1, 0, 0) * 2) -# nr <- 2 -# nc <- ceiling(sqrt(ng)) -# if (ng > 24) { -# nc <- max(ceiling(ng / 3), 6) -# nr <- 3 -# } else if (TRUE && ng <= 4) { -# nc <- 4 -# nr <- 1 -# } else { -# nc <- max(ceiling(ng / 2), 6) -# nr <- 2 -# } -# nr -# nc -# par(mfrow = c(nr, nc)) -# -# ymax <- 15 -# nlq <- -log10(1e-99 + unlist(Q)) -# ymax <- max(1.3, 1.2 * quantile(nlq, probs = 0.999, na.rm = TRUE)[1]) ## y-axis -# xmax <- max(1, 1.2 * quantile(abs(unlist(F)), probs = 0.999, na.rm = TRUE)[1]) ## x-axis -# -# shiny::withProgress(message = "rendering volcano plots ...", value = 0, { -# plt <- list() -# i <- 1 -# for (i in 1:length(comp)) { -# qval <- Q[[i]] -# fx <- F[[i]] -# fc.gene <- names(qval) -# is.sig <- (qval <= fdr & abs(fx) >= lfc) -# sig.genes <- fc.gene[which(is.sig)] -# genes1 <- sig.genes[which(toupper(sig.genes) %in% toupper(sel.genes))] -# genes2 <- head(genes1[order(-abs(fx[genes1]) * (-log10(qval[genes1])))], 10) -# xy <- data.frame(x = fx, y = -log10(qval)) -# is.sig2 <- factor(is.sig, levels = c(FALSE, TRUE)) -# -# plt[[i]] <- pgx.scatterPlotXY.GGPLOT( -# xy, -# title = comp[i], cex.title = 0.85, -# var = is.sig2, type = "factor", -# col = c("#bbbbbb", "#1e60bb"), -# legend.pos = "none", ## plotlib="ggplot", -# hilight = NULL, hilight2 = genes2, -# xlim = xmax * c(-1, 1), ylim = c(0, ymax), -# xlab = "difference (log2FC)", -# ylab = "significance (-log10q)", -# hilight.lwd = 0, hilight.col = "#1e60bb", hilight.cex = 1.5, -# cex = 0.45, cex.lab = 0.62 -# ) -# ## ggplot2::theme(legend.position='none') -# ## ggplot2::theme_bw(base_size=11) -# -# if (!interactive()) shiny::incProgress(1 / length(comp)) -# } -# }) ## progress -# -# -# ## patchwork::wrap_plots(plt, nrow=nr, ncol=nc) & -# ## ggplot2::theme_bw(base_size=11) & -# ## ggplot2::theme(legend.position='none') -# -# -# gridExtra::grid.arrange(grobs = plt, nrow = nr, ncol = nc) -# }) -# -# # volcanoAll_text <- "Under the Volcano (all) tab, the platform simultaneously displays multiple volcano plots for genes across all contrasts. This provides users an overview of the statistics for all comparisons. By comparing multiple volcano plots, the user can immediately see which comparison is statistically weak or strong." -# -# shiny::callModule(plotModule, -# id = "volcanoAll", -# func = volcanoAll.RENDER, -# func2 = volcanoAll.RENDER, -# info.text = volcanoAll_text, -# pdf.width = 16, pdf.height = 5, -# height = c(imgH, 500), width = c("auto", 1600), -# res = c(70, 90), -# title = "Volcano plots for all contrasts", -# add.watermark = WATERMARK -# ) - - # END Volcano (all contrasts) start code ######## - - # volcanoAll2 not used code ########### - - ## volcanoAll2.RENDER <- shiny::reactive({ - # volcanoAll2.RENDER <- shiny::reactive({ - # ngs <- inputData() - # if (is.null(ngs)) { - # return(NULL) - # } - # - # - # fdr <- 1 - # lfc <- 0 - # fdr <- as.numeric(input$gx_fdr) - # lfc <- as.numeric(input$gx_lfc) - # - # sel.genes <- rownames(ngs$X) - # if (input$gx_features != "") { - # ## gset <- GSETS[input$gx_features] - # gset <- getGSETS(input$gx_features) - # sel.genes <- unique(unlist(gset)) - # } - # - # comp <- names(ngs$gx.meta$meta) - # ng <- length(comp) - # nn <- c(2, max(ceiling(ng / 2), 5)) - # ## if(ng>12) nn = c(3,8) - # par(mfrow = nn, mar = c(1, 1, 1, 1) * 0.2, mgp = c(2.6, 1, 0), oma = c(1, 1, 0, 0) * 2) - # nr <- 2 - # nc <- ceiling(sqrt(ng)) - # if (ng > 24) { - # nc <- max(ceiling(ng / 3), 6) - # nr <- 3 - # } else if (TRUE && ng <= 4) { - # nc <- 4 - # nr <- 1 - # } else { - # nc <- max(ceiling(ng / 2), 6) - # nr <- 2 - # } - # nr - # nc - # ## par(mfrow=c(nr,nc)) - # - # tests <- "meta" - # methods <- NULL - # methods <- selected_gxmethods() - # plist <- viz.Contrasts( - # pgx = ngs, ## pgxRT=inputData, - # methods = methods, type = "volcano", fixed.axis = TRUE, - # psig = fdr, fc = lfc, ntop = 10, cex = 0.5, cex.lab = 0.7, - # plots.only = TRUE, title = NULL, subtitle = NULL, caption = NULL - # ) - # - # fig <- viz.showFigure(plist) + plot_layout(nrow = nr, ncol = nc) & - # ggplot2::theme_bw(base_size = 11) & - # ## ggplot2::theme_bw(base_size=16) & - # ggplot2::theme(legend.position = "none") - # - # fig - # }) - # - # volcanoAll2_text <- "Under the Volcano (all) tab, the platform simultaneously displays multiple volcano plots for genes across all contrasts. This provides users an overview of the statistics for all comparisons. By comparing multiple volcano plots, the user can immediately see which comparison is statistically weak or strong." - # - # volcanoAll2_caption <- "Volcano plot for all contrasts. Simultaneous visualisation of volcano plots of genes for all contrasts. Experimental contrasts with better statistical significance will show volcano plots with 'higher' wings." - # - # shiny::callModule( - # plotModule, - # id = "volcanoAll2", - # func = volcanoAll2.RENDER, - # func2 = volcanoAll2.RENDER, - # ## plotlib = 'ggplot', - # info.text = volcanoAll2_text, - # ## caption = volcanoAll_caption, - # pdf.width = 16, pdf.height = 5, - # ## height = imgH, res=75, - # height = c(imgH, 500), width = c("auto", 1600), - # res = c(75, 95), - # title = "Volcano plots for all contrasts", - # add.watermark = WATERMARK - # ) - # - # - # output$volcanoAll2_UI <- shiny::renderUI({ - # shiny::fillCol( - # ## id = ns("topgenes"), - # height = rowH, - # flex = c(1, NA, NA), ## height = 370, - # plotWidget(ns("volcanoAll2")), - # shiny::br(), - # shiny::div(shiny::HTML(volcanoAll_caption), class = "caption") - # ) - # }) - - # end volcanoAll2 not used code ########### - - - # Volcano (all methods) code refactored to plotmodule ######## - - - # volcanoMethods.RENDER <- shiny::reactive({ - # comp <- input$gx_contrast - # if (is.null(comp)) { - # return(NULL) - # } - # ngs <- inputData() - # shiny::req(ngs) - # if (is.null(input$gx_features)) { - # return(NULL) - # } - # - # fdr <- 1 - # lfc <- 1 - # comp <- names(ngs$gx.meta$meta)[1] - # fdr <- as.numeric(input$gx_fdr) - # lfc <- as.numeric(input$gx_lfc) - # genes <- NULL - # - # gset <- getGSETS(input$gx_features) - # sel.genes <- unique(unlist(gset)) - # - # ## meta tables - # mx <- ngs$gx.meta$meta[[comp]] - # fc <- unclass(mx$fc) - # ## pv = unclass(mx$p) - # qv <- unclass(mx$q) - # nlq <- -log10(1e-99 + qv) - # 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 <- ngs$genes[rownames(mx), "gene_name"] - # nplots <- min(24, ncol(qv)) - # - # ## methods = names(ngs$gx.meta$output) - # methods <- colnames(ngs$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) { - # nplots <- min(nplots, 24) - # par(mfrow = c(3, 8), mar = c(4, 4, 2, 2) * 0) - # nc <- 8 - # } - # - # shiny::withProgress(message = "computing volcano plots ...", value = 0, { - # i <- 1 - # for (i in 1:nplots) { - # fx <- fc[, i] - # ## pval = pv[,i] - # qval <- qv[, i] - # sig.genes <- fc.genes[which(qval <= fdr & abs(fx) >= lfc)] - # ## genes1 = intersect(sig.genes, sel.genes) - # genes1 <- sig.genes[which(toupper(sig.genes) %in% toupper(sel.genes))] - # gx.volcanoPlot.XY( - # x = fx, pv = qval, gene = fc.genes, - # render = "canvas", n = 5000, nlab = 5, - # xlim = xlim, ylim = c(0, ymax), axes = FALSE, - # use.fdr = TRUE, p.sig = fdr, lfc = lfc, - # ## main=comp[i], - # ## ma.plot=TRUE, use.rpkm=TRUE, - # cex = 0.6, lab.cex = 1.5, highlight = genes1 - # ) - # - # is.first <- (i %% nc == 1) - # last.row <- ((i - 1) %/% nc == (nplots - 1) %/% nc) - # is.first - # last.row - # if (is.first) axis(2, mgp = c(2, 0.7, 0), cex.axis = 0.8) - # if (last.row) axis(1, mgp = c(2, 0.7, 0), cex.axis = 0.8) - # graphics::box(lwd = 1, col = "black", lty = "solid") - # legend("top", - # legend = colnames(fc)[i], cex = 1.2, - # bg = "white", box.lty = 0, inset = c(0, 0.01), - # x.intersp = 0.1, y.intersp = 0.1 - # ) - # shiny::incProgress(1 / length(nplots)) - # } - # }) - # }) - # - # volcanoMethods_text <- "Under the Volcano (methods) tab, the platform displays the volcano plots provided by multiple differential expression calculation methods for the selected contrast. This provides users an overview of the statistics of all methods at the same time." - # - # shiny::callModule(plotModule, - # id = "volcanoMethods", - # func = volcanoMethods.RENDER, - # func2 = volcanoMethods.RENDER, - # title = "Volcano plots for all methods", - # info.text = volcanoMethods_text, - # ## caption = volcanoMethods_caption, - # height = c(imgH, 450), width = c("auto", 1600), - # res = c(75, 95), - # pdf.width = 18, pdf.height = 6, - # add.watermark = WATERMARK - # ) - - # end Volcano (all methods) code refactored to plotmodule ######## - - ## ================================================================================ ## Statistics Table ## ================================================================================ From 88ee2ad3c6cb4bb0e4e5cd851d164cfa10c8f733 Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Sat, 28 Jan 2023 15:10:52 +0100 Subject: [PATCH 16/32] update expression_table to expression board --- .../board.expression/R/expression_table.R | 110 +++++++++--------- 1 file changed, 55 insertions(+), 55 deletions(-) diff --git a/components/board.expression/R/expression_table.R b/components/board.expression/R/expression_table.R index 4f8220097..b716af3be 100644 --- a/components/board.expression/R/expression_table.R +++ b/components/board.expression/R/expression_table.R @@ -1,55 +1,55 @@ -#' ## -#' ## This file is part of the Omics Playground project. -#' ## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. -#' ## -#' -#' #' UI code for table code: expression board -#' #' -#' #' @param id -#' #' @param label -#' #' @param height -#' #' @param width -#' #' -#' #' @export -#' compare_table_corr_score_ui <- function(id, -#' label='', -#' height, -#' width) { -#' -#' ns <- shiny::NS(id) -#' -#' tableWidget(ns("table")) -#' -#' } -#' -#' #' Server side table code: expression board -#' #' -#' #' @param id -#' #' @param watermark -#' #' -#' #' @export -#' compare_table_corr_score_server <- function(id, -#' watermark=FALSE){ -#' moduleServer( id, function(input, output, session) { -#' -#' score_table.RENDER <- shiny::reactive({ -#' -#' #code here -#' -#' }) -#' -#' score_table_info = "" -#' -#' score_table <- shiny::callModule( -#' tableModule, id = "table", -#' func = "", ## ns=ns, -#' info.text = table_info, -#' title = tags$div( -#' HTML('')), -#' height = c(,), -#' width = c(,) -#' ) -#' return(score_table) -#' } -#' ) -#' } \ No newline at end of file +## +## This file is part of the Omics Playground project. +## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. +## + +#' UI code for table code: expression board +#' +#' @param id +#' @param label +#' @param height +#' @param width +#' +#' @export +expression_table_TableName_ui <- function(id, + label='', + height, + width) { + + ns <- shiny::NS(id) + + tableWidget(ns("table")) + +} + +#' Server side table code: expression board +#' +#' @param id +#' @param watermark +#' +#' @export +expression_table_TableName_server <- function(id, + watermark=FALSE){ + moduleServer( id, function(input, output, session) { + + table.RENDER <- shiny::reactive({ + + #code here + + }) + + table_info = "" + + score_table <- shiny::callModule( + tableModule, id = "table", + func = "table.RENDER", ## ns=ns, + info.text = table_info, + title = tags$div( + HTML('')), + height = c(,), + width = c(,) + ) + return(score_table) + } + ) +} \ No newline at end of file From 9494562517cd5ac0b0bbc1aad9b09575cd0ac8d8 Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Sat, 28 Jan 2023 15:13:55 +0100 Subject: [PATCH 17/32] refactor genetable, add templates for tables --- .../board.expression/R/expression_server.R | 199 +++++++++--------- .../board.expression/R/expression_table.R | 110 +++++----- .../R/expression_table_FDRtable.R | 55 +++++ .../R/expression_table_fctable.R | 55 +++++ .../R/expression_table_genetable.R | 125 +++++++++++ .../R/expression_table_gsettable.R | 55 +++++ components/board.expression/R/expression_ui.R | 2 +- 7 files changed, 443 insertions(+), 158 deletions(-) create mode 100644 components/board.expression/R/expression_table_FDRtable.R create mode 100644 components/board.expression/R/expression_table_fctable.R create mode 100644 components/board.expression/R/expression_table_genetable.R create mode 100644 components/board.expression/R/expression_table_gsettable.R diff --git a/components/board.expression/R/expression_server.R b/components/board.expression/R/expression_server.R index 991765f0b..6e5ca24ad 100644 --- a/components/board.expression/R/expression_server.R +++ b/components/board.expression/R/expression_server.R @@ -411,110 +411,105 @@ ExpressionBoard <- function(id, inputData) { lfc = shiny::reactive(input$gx_lfc), watermark = FALSE) - - ## ================================================================================ - ## Statistics Table - ## ================================================================================ - - gene_selected <- shiny::reactive({ - i <- as.integer(genetable$rows_selected()) - if (is.null(i) || length(i) == 0) { - return(NULL) - } - res <- filteredDiffExprTable() - gene <- rownames(res)[i] - return(gene) - }) - - genetable.RENDER <- shiny::reactive({ - - res <- filteredDiffExprTable() - ## res <- fullDiffExprTable() - - if (is.null(res) || nrow(res) == 0) { - return(NULL) - } - - fx.col <- grep("fc|fx|mean.diff|logfc|foldchange", tolower(colnames(res)))[1] - fx.col - fx <- res[, fx.col] - - if ("gene_title" %in% colnames(res)) res$gene_title <- shortstring(res$gene_title, 50) - rownames(res) <- sub(".*:", "", rownames(res)) - - if (!DEV) { - kk <- grep("meta.fx|meta.fc|meta.p", colnames(res), invert = TRUE) - res <- res[, kk, drop = FALSE] - } - if (!input$gx_showqvalues) { - kk <- grep("^q[.]", colnames(res), invert = TRUE) - res <- res[, kk, drop = FALSE] - } - - numeric.cols <- which(sapply(res, is.numeric)) - numeric.cols <- colnames(res)[numeric.cols] - - DT::datatable(res, - rownames = FALSE, - ## class = 'compact cell-border stripe hover', - class = "compact hover", - extensions = c("Scroller"), - selection = list(mode = "single", target = "row", selected = 1), - fillContainer = TRUE, - options = list( - dom = "frtip", - paging = TRUE, - pageLength = 16, ## lengthMenu = c(20, 30, 40, 60, 100, 250), - scrollX = TRUE, - scrollY = FALSE, - scroller = FALSE, - deferRender = TRUE, - search = list( - regex = TRUE, - caseInsensitive = TRUE - ## , search = 'M[ae]' - ) - ) ## end of options.list - ) %>% - DT::formatSignif(numeric.cols, 4) %>% - DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") %>% - DT::formatStyle(colnames(res)[fx.col], - ## background = DT::styleColorBar(c(0,3), 'lightblue'), - background = color_from_middle(fx, "lightblue", "#f5aeae"), - backgroundSize = "98% 88%", - backgroundRepeat = "no-repeat", - backgroundPosition = "center" - ) - }) %>% - bindCache(filteredDiffExprTable(), input$gx_showqvalues) - - genetable_text <- "Table I shows the results of the statistical tests. To increase the statistical reliability of the Omics Playground, we perform the DE analysis using four commonly accepted methods in the literature, namely, T-test (standard, Welch), limma (no trend, trend, voom), edgeR (QLF, LRT), and DESeq2 (Wald, LRT), and merge the results. -

For a selected comparison under the Contrast setting, the results of the selected methods are combined and reported under the table, where meta.q for a gene represents the highest q value among the methods and the number of stars for a gene indicate how many methods identified significant q values (q < 0.05). The table is interactive (scrollable, clickable); users can sort genes by logFC, meta.q, or average expression in either conditions. Users can filter top N = {10} differently expressed genes in the table by clicking the top 10 genes from the table Settings." - - genetable_opts <- shiny::tagList( - withTooltip(shiny::checkboxInput(ns("gx_top10"), "top 10 up/down genes", FALSE), - "Display only top 10 differentially (positively and negatively) expressed genes in the table.", - placement = "top", options = list(container = "body") - ), - withTooltip(shiny::checkboxInput(ns("gx_showqvalues"), "show indivivual q-values", FALSE), - "Show q-values of each indivivual statistical method in the table.", - placement = "top", options = list(container = "body") - ) - ) - - genetable <- shiny::callModule( - tableModule, - id = "genetable", - func = genetable.RENDER, - info.text = genetable_text, - label = "I", info.width = "500px", - options = genetable_opts, - server = TRUE, - title = "Differential expression analysis", - height = c(tabH - 10, 700) - ) + expression_table_genetable_server(id = "genetable", + res = filteredDiffExprTable, + height=c(tabH - 10, 700)) + + + #genetable table refactoring ######### + + # gene_selected <- shiny::reactive({ #THIS FN IS NOT USED ANYWHERE! + # i <- as.integer(genetable$rows_selected()) + # if (is.null(i) || length(i) == 0) { + # return(NULL) + # } + # res <- filteredDiffExprTable() + # gene <- rownames(res)[i] + # return(gene) + # }) +# +# genetable.RENDER <- shiny::reactive({ +# +# res <- filteredDiffExprTable() +# ## res <- fullDiffExprTable() +# +# if (is.null(res) || nrow(res) == 0) { +# return(NULL) +# } +# +# fx.col <- grep("fc|fx|mean.diff|logfc|foldchange", tolower(colnames(res)))[1] +# fx.col +# fx <- res[, fx.col] +# +# if ("gene_title" %in% colnames(res)) res$gene_title <- shortstring(res$gene_title, 50) +# rownames(res) <- sub(".*:", "", rownames(res)) +# +# if (!DEV) { +# kk <- grep("meta.fx|meta.fc|meta.p", colnames(res), invert = TRUE) +# res <- res[, kk, drop = FALSE] +# } +# if (!input$gx_showqvalues) { +# kk <- grep("^q[.]", colnames(res), invert = TRUE) +# res <- res[, kk, drop = FALSE] +# } +# +# numeric.cols <- which(sapply(res, is.numeric)) +# numeric.cols <- colnames(res)[numeric.cols] +# +# DT::datatable(res, +# rownames = FALSE, +# ## class = 'compact cell-border stripe hover', +# class = "compact hover", +# extensions = c("Scroller"), +# selection = list(mode = "single", target = "row", selected = 1), +# fillContainer = TRUE, +# options = list( +# dom = "frtip", +# paging = TRUE, +# pageLength = 16, ## lengthMenu = c(20, 30, 40, 60, 100, 250), +# scrollX = TRUE, +# scrollY = FALSE, +# scroller = FALSE, +# deferRender = TRUE, +# search = list( +# regex = TRUE, +# caseInsensitive = TRUE +# ## , search = 'M[ae]' +# ) +# ) ## end of options.list +# ) %>% +# DT::formatSignif(numeric.cols, 4) %>% +# DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") %>% +# DT::formatStyle(colnames(res)[fx.col], +# ## background = DT::styleColorBar(c(0,3), 'lightblue'), +# background = color_from_middle(fx, "lightblue", "#f5aeae"), +# backgroundSize = "98% 88%", +# backgroundRepeat = "no-repeat", +# backgroundPosition = "center" +# ) +# }) %>% +# bindCache(filteredDiffExprTable(), input$gx_showqvalues) + +# genetable_text <- "Table I shows the results of the statistical tests. To increase the statistical reliability of the Omics Playground, we perform the DE analysis using four commonly accepted methods in the literature, namely, T-test (standard, Welch), limma (no trend, trend, voom), edgeR (QLF, LRT), and DESeq2 (Wald, LRT), and merge the results. +#

For a selected comparison under the Contrast setting, the results of the selected methods are combined and reported under the table, where meta.q for a gene represents the highest q value among the methods and the number of stars for a gene indicate how many methods identified significant q values (q < 0.05). The table is interactive (scrollable, clickable); users can sort genes by logFC, meta.q, or average expression in either conditions. Users can filter top N = {10} differently expressed genes in the table by clicking the top 10 genes from the table Settings." + + + + # genetable <- shiny::callModule( + # tableModule, + # id = "genetable", + # func = genetable.RENDER, + # info.text = genetable_text, + # label = "I", info.width = "500px", + # options = genetable_opts, + # server = TRUE, + # title = "Differential expression analysis", + # height = c(tabH - 10, 700) + # ) ## output$genetable <- genetable_module$render + #end genetable table refactoring ######### + ## NEED RETHINK: reacts too often gx_related_genesets <- shiny::reactive({ diff --git a/components/board.expression/R/expression_table.R b/components/board.expression/R/expression_table.R index b716af3be..5d8fcddb1 100644 --- a/components/board.expression/R/expression_table.R +++ b/components/board.expression/R/expression_table.R @@ -1,55 +1,55 @@ -## -## This file is part of the Omics Playground project. -## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. -## - -#' UI code for table code: expression board -#' -#' @param id -#' @param label -#' @param height -#' @param width -#' -#' @export -expression_table_TableName_ui <- function(id, - label='', - height, - width) { - - ns <- shiny::NS(id) - - tableWidget(ns("table")) - -} - -#' Server side table code: expression board -#' -#' @param id -#' @param watermark -#' -#' @export -expression_table_TableName_server <- function(id, - watermark=FALSE){ - moduleServer( id, function(input, output, session) { - - table.RENDER <- shiny::reactive({ - - #code here - - }) - - table_info = "" - - score_table <- shiny::callModule( - tableModule, id = "table", - func = "table.RENDER", ## ns=ns, - info.text = table_info, - title = tags$div( - HTML('')), - height = c(,), - width = c(,) - ) - return(score_table) - } - ) -} \ No newline at end of file +#' ## +#' ## This file is part of the Omics Playground project. +#' ## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. +#' ## +#' +#' #' UI code for table code: expression board +#' #' +#' #' @param id +#' #' @param label +#' #' @param height +#' #' @param width +#' #' +#' #' @export +#' expression_table_TableName_ui <- function(id, +#' label='', +#' height, +#' width) { +#' +#' ns <- shiny::NS(id) +#' +#' tableWidget(ns("table")) +#' +#' } +#' +#' #' Server side table code: expression board +#' #' +#' #' @param id +#' #' @param watermark +#' #' +#' #' @export +#' expression_table_TableName_server <- function(id, +#' watermark=FALSE){ +#' moduleServer( id, function(input, output, session) { +#' +#' table.RENDER <- shiny::reactive({ +#' +#' #code here +#' +#' }) +#' +#' table_info = "" +#' +#' score_table <- shiny::callModule( +#' tableModule, id = "table", +#' func = "table.RENDER", ## ns=ns, +#' info.text = table_info, +#' title = tags$div( +#' HTML('')), +#' height = c(,), +#' width = c(,) +#' ) +#' return(score_table) +#' } +#' ) +#' } \ No newline at end of file diff --git a/components/board.expression/R/expression_table_FDRtable.R b/components/board.expression/R/expression_table_FDRtable.R new file mode 100644 index 000000000..4014939a0 --- /dev/null +++ b/components/board.expression/R/expression_table_FDRtable.R @@ -0,0 +1,55 @@ +#' ## +#' ## This file is part of the Omics Playground project. +#' ## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. +#' ## +#' +#' #' UI code for table code: expression board +#' #' +#' #' @param id +#' #' @param label +#' #' @param height +#' #' @param width +#' #' +#' #' @export +#' expression_table_TableName_ui <- function(id, +#' label='', +#' height, +#' width) { +#' +#' ns <- shiny::NS(id) +#' +#' tableWidget(ns("table")) +#' +#' } +#' +#' #' Server side table code: expression board +#' #' +#' #' @param id +#' #' @param watermark +#' #' +#' #' @export +#' expression_table_TableName_server <- function(id, +#' watermark=FALSE){ +#' moduleServer( id, function(input, output, session) { +#' +#' table.RENDER <- shiny::reactive({ +#' +#' #code here +#' +#' }) +#' +#' table_info = "" +#' +#' score_table <- shiny::callModule( +#' tableModule, id = "table", +#' func = "table.RENDER", ## ns=ns, +#' info.text = table_info, +#' title = tags$div( +#' HTML('')), +#' height = c(,), +#' width = c(,) +#' ) +#' return(score_table) +#' } +#' ) +#' } \ No newline at end of file diff --git a/components/board.expression/R/expression_table_fctable.R b/components/board.expression/R/expression_table_fctable.R new file mode 100644 index 000000000..4014939a0 --- /dev/null +++ b/components/board.expression/R/expression_table_fctable.R @@ -0,0 +1,55 @@ +#' ## +#' ## This file is part of the Omics Playground project. +#' ## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. +#' ## +#' +#' #' UI code for table code: expression board +#' #' +#' #' @param id +#' #' @param label +#' #' @param height +#' #' @param width +#' #' +#' #' @export +#' expression_table_TableName_ui <- function(id, +#' label='', +#' height, +#' width) { +#' +#' ns <- shiny::NS(id) +#' +#' tableWidget(ns("table")) +#' +#' } +#' +#' #' Server side table code: expression board +#' #' +#' #' @param id +#' #' @param watermark +#' #' +#' #' @export +#' expression_table_TableName_server <- function(id, +#' watermark=FALSE){ +#' moduleServer( id, function(input, output, session) { +#' +#' table.RENDER <- shiny::reactive({ +#' +#' #code here +#' +#' }) +#' +#' table_info = "" +#' +#' score_table <- shiny::callModule( +#' tableModule, id = "table", +#' func = "table.RENDER", ## ns=ns, +#' info.text = table_info, +#' title = tags$div( +#' HTML('')), +#' height = c(,), +#' width = c(,) +#' ) +#' return(score_table) +#' } +#' ) +#' } \ No newline at end of file diff --git a/components/board.expression/R/expression_table_genetable.R b/components/board.expression/R/expression_table_genetable.R new file mode 100644 index 000000000..0f8d29f1f --- /dev/null +++ b/components/board.expression/R/expression_table_genetable.R @@ -0,0 +1,125 @@ +## +## This file is part of the Omics Playground project. +## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. +## + +#' UI code for table code: expression board +#' +#' @param id +#' @param label +#' @param height +#' @param width +#' +#' @export +expression_table_genetable_ui <- function(id) { + + ns <- shiny::NS(id) + + tableWidget(ns("table")) + +} + +#' Server side table code: expression board +#' +#' @param id +#' @param watermark +#' +#' @export +expression_table_genetable_server <- function(id, + res, #filteredDiffExprTable + height, + watermark=FALSE){ + moduleServer(id, function(input, output, session) { + + + score_table.RENDER <- shiny::reactive({ + + res <- res() + ## res <- fullDiffExprTable() + + if (is.null(res) || nrow(res) == 0) { + return(NULL) + } + + fx.col <- grep("fc|fx|mean.diff|logfc|foldchange", tolower(colnames(res)))[1] + fx.col + fx <- res[, fx.col] + + if ("gene_title" %in% colnames(res)) res$gene_title <- shortstring(res$gene_title, 50) + rownames(res) <- sub(".*:", "", rownames(res)) + + if (!DEV) { + kk <- grep("meta.fx|meta.fc|meta.p", colnames(res), invert = TRUE) + res <- res[, kk, drop = FALSE] + } + if (!input$gx_showqvalues) { + kk <- grep("^q[.]", colnames(res), invert = TRUE) + res <- res[, kk, drop = FALSE] + } + + numeric.cols <- which(sapply(res, is.numeric)) + numeric.cols <- colnames(res)[numeric.cols] + + DT::datatable(res, + rownames = FALSE, + ## class = 'compact cell-border stripe hover', + class = "compact hover", + extensions = c("Scroller"), + selection = list(mode = "single", target = "row", selected = 1), + fillContainer = TRUE, + options = list( + dom = "frtip", + paging = TRUE, + pageLength = 16, ## lengthMenu = c(20, 30, 40, 60, 100, 250), + scrollX = TRUE, + scrollY = FALSE, + scroller = FALSE, + deferRender = TRUE, + search = list( + regex = TRUE, + caseInsensitive = TRUE + ## , search = 'M[ae]' + ) + ) ## end of options.list + ) %>% + DT::formatSignif(numeric.cols, 4) %>% + DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") %>% + DT::formatStyle(colnames(res)[fx.col], + ## background = DT::styleColorBar(c(0,3), 'lightblue'), + background = color_from_middle(fx, "lightblue", "#f5aeae"), + backgroundSize = "98% 88%", + backgroundRepeat = "no-repeat", + backgroundPosition = "center" + ) + }) %>% + bindCache(filteredDiffExprTable(), input$gx_showqvalues) + + genetable_text = "Table I shows the results of the statistical tests. To increase the statistical reliability of the Omics Playground, we perform the DE analysis using four commonly accepted methods in the literature, namely, T-test (standard, Welch), limma (no trend, trend, voom), edgeR (QLF, LRT), and DESeq2 (Wald, LRT), and merge the results. +

For a selected comparison under the Contrast setting, the results of the selected methods are combined and reported under the table, where meta.q for a gene represents the highest q value among the methods and the number of stars for a gene indicate how many methods identified significant q values (q < 0.05). The table is interactive (scrollable, clickable); users can sort genes by logFC, meta.q, or average expression in either conditions. Users can filter top N = {10} differently expressed genes in the table by clicking the top 10 genes from the table Settings." + + genetable_opts <- shiny::tagList( + withTooltip(shiny::checkboxInput(ns("gx_top10"), "top 10 up/down genes", FALSE), + "Display only top 10 differentially (positively and negatively) expressed genes in the table.", + placement = "top", options = list(container = "body") + ), + withTooltip(shiny::checkboxInput(ns("gx_showqvalues"), "show indivivual q-values", FALSE), + "Show q-values of each indivivual statistical method in the table.", + placement = "top", options = list(container = "body") + ) + ) + + genetable <- shiny::callModule( + tableModule, + id = "table", + func = genetable.RENDER, + info.text = genetable_text, + label = "I", info.width = "500px", + options = genetable_opts, + server = TRUE, + title = "Differential expression analysis" + ) + + return(score_table) + } + ) +} \ No newline at end of file diff --git a/components/board.expression/R/expression_table_gsettable.R b/components/board.expression/R/expression_table_gsettable.R new file mode 100644 index 000000000..4014939a0 --- /dev/null +++ b/components/board.expression/R/expression_table_gsettable.R @@ -0,0 +1,55 @@ +#' ## +#' ## This file is part of the Omics Playground project. +#' ## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. +#' ## +#' +#' #' UI code for table code: expression board +#' #' +#' #' @param id +#' #' @param label +#' #' @param height +#' #' @param width +#' #' +#' #' @export +#' expression_table_TableName_ui <- function(id, +#' label='', +#' height, +#' width) { +#' +#' ns <- shiny::NS(id) +#' +#' tableWidget(ns("table")) +#' +#' } +#' +#' #' Server side table code: expression board +#' #' +#' #' @param id +#' #' @param watermark +#' #' +#' #' @export +#' expression_table_TableName_server <- function(id, +#' watermark=FALSE){ +#' moduleServer( id, function(input, output, session) { +#' +#' table.RENDER <- shiny::reactive({ +#' +#' #code here +#' +#' }) +#' +#' table_info = "" +#' +#' score_table <- shiny::callModule( +#' tableModule, id = "table", +#' func = "table.RENDER", ## ns=ns, +#' info.text = table_info, +#' title = tags$div( +#' HTML('')), +#' height = c(,), +#' width = c(,) +#' ) +#' return(score_table) +#' } +#' ) +#' } \ No newline at end of file diff --git a/components/board.expression/R/expression_ui.R b/components/board.expression/R/expression_ui.R index e04fdc863..32bc93294 100644 --- a/components/board.expression/R/expression_ui.R +++ b/components/board.expression/R/expression_ui.R @@ -179,7 +179,7 @@ ExpressionUI <- function(id) { class = "row", div( class = "col-md-8", - tableWidget(ns("genetable")) + expression_table_genetable_ui(id = ns("genetable")) ), div( class = "col-md-4", From a00a7fc594a1f69fc55eda4329c84443912ac365 Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Sun, 29 Jan 2023 11:27:11 +0100 Subject: [PATCH 18/32] fix genetable missing ns and fn names --- .../board.expression/R/expression_server.R | 10 +++-- .../R/expression_table_genetable.R | 38 ++++++++++++------- 2 files changed, 30 insertions(+), 18 deletions(-) diff --git a/components/board.expression/R/expression_server.R b/components/board.expression/R/expression_server.R index 6e5ca24ad..93fce18f4 100644 --- a/components/board.expression/R/expression_server.R +++ b/components/board.expression/R/expression_server.R @@ -284,7 +284,9 @@ ExpressionBoard <- function(id, inputData) { # Plotting ### - # tab differential expression > Plots #### + # tab differential expression > Plot #### + + expression_plot_volcano_server( id = "plots_volcano", @@ -411,9 +413,9 @@ ExpressionBoard <- function(id, inputData) { lfc = shiny::reactive(input$gx_lfc), watermark = FALSE) - expression_table_genetable_server(id = "genetable", - res = filteredDiffExprTable, - height=c(tabH - 10, 700)) + genetable <- expression_table_genetable_server(id = "genetable", + res = filteredDiffExprTable, + height=c(tabH - 10, 700)) #genetable table refactoring ######### diff --git a/components/board.expression/R/expression_table_genetable.R b/components/board.expression/R/expression_table_genetable.R index 0f8d29f1f..7cf434148 100644 --- a/components/board.expression/R/expression_table_genetable.R +++ b/components/board.expression/R/expression_table_genetable.R @@ -13,10 +13,14 @@ #' @export expression_table_genetable_ui <- function(id) { + message("expression_table_genetable_ui called") + ns <- shiny::NS(id) tableWidget(ns("table")) + message("expression_table_genetable_ui done") + } #' Server side table code: expression board @@ -31,11 +35,24 @@ expression_table_genetable_server <- function(id, watermark=FALSE){ moduleServer(id, function(input, output, session) { + message("expression_table_genetable_server called") + + ns <- session$ns + + genetable_opts <- shiny::tagList( + withTooltip(shiny::checkboxInput(ns("gx_top10"), "top 10 up/down genes", FALSE), + "Display only top 10 differentially (positively and negatively) expressed genes in the table.", + placement = "top", options = list(container = "body") + ), + withTooltip(shiny::checkboxInput(ns("gx_showqvalues"), "show indivivual q-values", FALSE), + "Show q-values of each indivivual statistical method in the table.", + placement = "top", options = list(container = "body") + ) + ) - score_table.RENDER <- shiny::reactive({ + table.RENDER <- shiny::reactive({ res <- res() - ## res <- fullDiffExprTable() if (is.null(res) || nrow(res) == 0) { return(NULL) @@ -97,21 +114,12 @@ expression_table_genetable_server <- function(id, genetable_text = "Table I shows the results of the statistical tests. To increase the statistical reliability of the Omics Playground, we perform the DE analysis using four commonly accepted methods in the literature, namely, T-test (standard, Welch), limma (no trend, trend, voom), edgeR (QLF, LRT), and DESeq2 (Wald, LRT), and merge the results.

For a selected comparison under the Contrast setting, the results of the selected methods are combined and reported under the table, where meta.q for a gene represents the highest q value among the methods and the number of stars for a gene indicate how many methods identified significant q values (q < 0.05). The table is interactive (scrollable, clickable); users can sort genes by logFC, meta.q, or average expression in either conditions. Users can filter top N = {10} differently expressed genes in the table by clicking the top 10 genes from the table Settings." - genetable_opts <- shiny::tagList( - withTooltip(shiny::checkboxInput(ns("gx_top10"), "top 10 up/down genes", FALSE), - "Display only top 10 differentially (positively and negatively) expressed genes in the table.", - placement = "top", options = list(container = "body") - ), - withTooltip(shiny::checkboxInput(ns("gx_showqvalues"), "show indivivual q-values", FALSE), - "Show q-values of each indivivual statistical method in the table.", - placement = "top", options = list(container = "body") - ) - ) + genetable <- shiny::callModule( tableModule, id = "table", - func = genetable.RENDER, + func = table.RENDER, info.text = genetable_text, label = "I", info.width = "500px", options = genetable_opts, @@ -119,7 +127,9 @@ expression_table_genetable_server <- function(id, title = "Differential expression analysis" ) - return(score_table) + message("expression_table_genetable_server done") + + return(genetable) } ) } \ No newline at end of file From ab5f1f56396f77cfd6b79a29963f67db53cfb5de Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Sun, 29 Jan 2023 12:11:22 +0100 Subject: [PATCH 19/32] gsettable refactoring --- .../board.expression/R/expression_server.R | 241 +++++++++++------- .../R/expression_table_gsettable.R | 133 ++++++---- components/board.expression/R/expression_ui.R | 3 +- 3 files changed, 234 insertions(+), 143 deletions(-) diff --git a/components/board.expression/R/expression_server.R b/components/board.expression/R/expression_server.R index 93fce18f4..ad396f7fb 100644 --- a/components/board.expression/R/expression_server.R +++ b/components/board.expression/R/expression_server.R @@ -413,10 +413,65 @@ ExpressionBoard <- function(id, inputData) { lfc = shiny::reactive(input$gx_lfc), watermark = FALSE) + # tab differential expression > Volcano Methods #### + + # tables #### + + gx_related_genesets <- shiny::reactive({ + + ngs <- inputData() + res <- filteredDiffExprTable() + if (is.null(res) || nrow(res) == 0) { + return(NULL) + } + contr <- input$gx_contrast + if (is.null(contr)) { + return(NULL) + } + ## get table + sel.row <- 1 + ## sel.row = input$genetable_rows_selected + sel.row <- genetable$rows_selected() + if (is.null(sel.row)) { + return(NULL) + } + 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)) + if (length(gset) == 0) { + return(NULL) + } + + fx <- ngs$gset.meta$meta[[contr]]$meta.fx + names(fx) <- rownames(ngs$gset.meta$meta[[contr]]) + fx <- round(fx[gset], digits = 4) + + rho <- cor(t(ngs$gsetX[gset, ]), ngs$X[gene0, ])[, 1] + rho <- round(rho, digits = 3) + gset1 <- substring(gset, 1, 60) + + df <- data.frame(geneset = gset1, rho = rho, fx = fx, check.names = FALSE) + rownames(df) <- gset + df <- df[order(-abs(df$fx)), ] + + return(df) + }) + genetable <- expression_table_genetable_server(id = "genetable", res = filteredDiffExprTable, height=c(tabH - 10, 700)) + gsettable <- expression_table_gsettable_server(id = "gsettable", + gx_related_genesets = gx_related_genesets, + height = c(tabH - 10, 700), + width = c("100%", 800), + watermark=FALSE) + + + #genetable table refactoring ######### @@ -512,98 +567,102 @@ ExpressionBoard <- function(id, inputData) { #end genetable table refactoring ######### - ## NEED RETHINK: reacts too often - gx_related_genesets <- shiny::reactive({ - - ngs <- inputData() - res <- filteredDiffExprTable() - if (is.null(res) || nrow(res) == 0) { - return(NULL) - } - contr <- input$gx_contrast - if (is.null(contr)) { - return(NULL) - } - ## get table - sel.row <- 1 - ## sel.row = input$genetable_rows_selected - sel.row <- genetable$rows_selected() - if (is.null(sel.row)) { - return(NULL) - } - 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)) - if (length(gset) == 0) { - return(NULL) - } - - fx <- ngs$gset.meta$meta[[contr]]$meta.fx - names(fx) <- rownames(ngs$gset.meta$meta[[contr]]) - fx <- round(fx[gset], digits = 4) - - rho <- cor(t(ngs$gsetX[gset, ]), ngs$X[gene0, ])[, 1] - rho <- round(rho, digits = 3) - gset1 <- substring(gset, 1, 60) - - df <- data.frame(geneset = gset1, rho = rho, fx = fx, check.names = FALSE) - rownames(df) <- gset - df <- df[order(-abs(df$fx)), ] - - return(df) - }) - - gsettable.RENDER <- shiny::reactive({ - df <- gx_related_genesets() - if (is.null(df)) { - return(NULL) - } - - df$geneset <- wrapHyperLink(df$geneset, rownames(df)) - - DT::datatable(df, - ## class = 'compact cell-border stripe', - class = "compact", - rownames = FALSE, escape = c(-1, -2), - extensions = c("Scroller"), - fillContainer = TRUE, - options = list( - ## dom = 'lfrtip', - dom = "frtip", - paging = TRUE, - pageLength = 16, ## lengthMenu = c(20, 30, 40, 60, 100, 250), - scrollX = TRUE, - ## scrollY = tabV, - scrollY = FALSE, - scroller = FALSE, - deferRender = TRUE, - search = list( - regex = TRUE, - caseInsensitive = TRUE - ## search = 'GOBP:' - ) - ), ## end of options.list - selection = list(mode = "single", target = "row", selected = NULL) - ) %>% - ## formatSignif(1:ncol(df),4) %>% - DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") %>% - DT::formatStyle("fx", background = color_from_middle(df$fx, "lightblue", "#f5aeae")) - # }, server=FALSE) - }) - - gsettable_text <- "By clicking on a gene in the Table I, it is possible to see which genesets contain that gene in this table, and check the differential expression status in other comparisons from the Gene in contrasts plot under the Plots tab." + # #gsettable refactoring ######## + # + # ## NEED RETHINK: reacts too often + # gx_related_genesets <- shiny::reactive({ + # + # ngs <- inputData() + # res <- filteredDiffExprTable() + # if (is.null(res) || nrow(res) == 0) { + # return(NULL) + # } + # contr <- input$gx_contrast + # if (is.null(contr)) { + # return(NULL) + # } + # ## get table + # sel.row <- 1 + # ## sel.row = input$genetable_rows_selected + # sel.row <- genetable$rows_selected() + # if (is.null(sel.row)) { + # return(NULL) + # } + # 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)) + # if (length(gset) == 0) { + # return(NULL) + # } + # + # fx <- ngs$gset.meta$meta[[contr]]$meta.fx + # names(fx) <- rownames(ngs$gset.meta$meta[[contr]]) + # fx <- round(fx[gset], digits = 4) + # + # rho <- cor(t(ngs$gsetX[gset, ]), ngs$X[gene0, ])[, 1] + # rho <- round(rho, digits = 3) + # gset1 <- substring(gset, 1, 60) + # + # df <- data.frame(geneset = gset1, rho = rho, fx = fx, check.names = FALSE) + # rownames(df) <- gset + # df <- df[order(-abs(df$fx)), ] + # + # return(df) + # }) + # + # gsettable.RENDER <- shiny::reactive({ + # df <- gx_related_genesets() + # if (is.null(df)) { + # return(NULL) + # } + # + # df$geneset <- wrapHyperLink(df$geneset, rownames(df)) + # + # DT::datatable(df, + # ## class = 'compact cell-border stripe', + # class = "compact", + # rownames = FALSE, escape = c(-1, -2), + # extensions = c("Scroller"), + # fillContainer = TRUE, + # options = list( + # ## dom = 'lfrtip', + # dom = "frtip", + # paging = TRUE, + # pageLength = 16, ## lengthMenu = c(20, 30, 40, 60, 100, 250), + # scrollX = TRUE, + # ## scrollY = tabV, + # scrollY = FALSE, + # scroller = FALSE, + # deferRender = TRUE, + # search = list( + # regex = TRUE, + # caseInsensitive = TRUE + # ## search = 'GOBP:' + # ) + # ), ## end of options.list + # selection = list(mode = "single", target = "row", selected = NULL) + # ) %>% + # ## formatSignif(1:ncol(df),4) %>% + # DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") %>% + # DT::formatStyle("fx", background = color_from_middle(df$fx, "lightblue", "#f5aeae")) + # # }, server=FALSE) + # }) + # + # gsettable_text <- "By clicking on a gene in the Table I, it is possible to see which genesets contain that gene in this table, and check the differential expression status in other comparisons from the Gene in contrasts plot under the Plots tab." + # + # gsettable <- shiny::callModule( + # tableModule, + # id = "gsettable", + # func = gsettable.RENDER, + # info.text = gsettable_text, label = "II", + # title = "Gene sets with gene", + # height = c(tabH - 10, 700), width = c("100%", 800) + # ) - gsettable <- shiny::callModule( - tableModule, - id = "gsettable", - func = gsettable.RENDER, - info.text = gsettable_text, label = "II", - title = "Gene sets with gene", - height = c(tabH - 10, 700), width = c("100%", 800) - ) + #end gsettable refactoring ######## ## ================================================================================ ## Foldchange (all) diff --git a/components/board.expression/R/expression_table_gsettable.R b/components/board.expression/R/expression_table_gsettable.R index 4014939a0..e5a5a6bb2 100644 --- a/components/board.expression/R/expression_table_gsettable.R +++ b/components/board.expression/R/expression_table_gsettable.R @@ -1,55 +1,86 @@ -#' ## -#' ## This file is part of the Omics Playground project. -#' ## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. -#' ## +## +## This file is part of the Omics Playground project. +## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. +## + +#' UI code for table code: expression board #' -#' #' UI code for table code: expression board -#' #' -#' #' @param id -#' #' @param label -#' #' @param height -#' #' @param width -#' #' -#' #' @export -#' expression_table_TableName_ui <- function(id, -#' label='', -#' height, -#' width) { +#' @param id +#' @param label +#' @param height +#' @param width #' -#' ns <- shiny::NS(id) +#' @export +expression_table_gsettable_ui <- function(id, + label='') { + + ns <- shiny::NS(id) + + tableWidget(ns("table")) + +} + +#' Server side table code: expression board #' -#' tableWidget(ns("table")) +#' @param id +#' @param watermark #' -#' } -#' -#' #' Server side table code: expression board -#' #' -#' #' @param id -#' #' @param watermark -#' #' -#' #' @export -#' expression_table_TableName_server <- function(id, -#' watermark=FALSE){ -#' moduleServer( id, function(input, output, session) { -#' -#' table.RENDER <- shiny::reactive({ -#' -#' #code here -#' -#' }) -#' -#' table_info = "" -#' -#' score_table <- shiny::callModule( -#' tableModule, id = "table", -#' func = "table.RENDER", ## ns=ns, -#' info.text = table_info, -#' title = tags$div( -#' HTML('')), -#' height = c(,), -#' width = c(,) -#' ) -#' return(score_table) -#' } -#' ) -#' } \ No newline at end of file +#' @export +expression_table_gsettable_server <- function(id, + gx_related_genesets, + height, + width, + watermark=FALSE){ + moduleServer( id, function(input, output, session) { + + gsettable.RENDER <- shiny::reactive({ + df <- gx_related_genesets() + if (is.null(df)) { + return(NULL) + } + + df$geneset <- wrapHyperLink(df$geneset, rownames(df)) + + DT::datatable(df, + ## class = 'compact cell-border stripe', + class = "compact", + rownames = FALSE, escape = c(-1, -2), + extensions = c("Scroller"), + fillContainer = TRUE, + options = list( + ## dom = 'lfrtip', + dom = "frtip", + paging = TRUE, + pageLength = 16, ## lengthMenu = c(20, 30, 40, 60, 100, 250), + scrollX = TRUE, + ## scrollY = tabV, + scrollY = FALSE, + scroller = FALSE, + deferRender = TRUE, + search = list( + regex = TRUE, + caseInsensitive = TRUE + ## search = 'GOBP:' + ) + ), ## end of options.list + selection = list(mode = "single", target = "row", selected = NULL) + ) %>% + ## formatSignif(1:ncol(df),4) %>% + DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") %>% + DT::formatStyle("fx", background = color_from_middle(df$fx, "lightblue", "#f5aeae")) + # }, server=FALSE) + }) + + gsettable_text <- "By clicking on a gene in the Table I, it is possible to see which genesets contain that gene in this table, and check the differential expression status in other comparisons from the Gene in contrasts plot under the Plots tab." + + gsettable <- shiny::callModule( + tableModule, + id = "gsettable", + func = gsettable.RENDER, + info.text = gsettable_text, label = "II", + title = "Gene sets with gene", + height = height, width = width + ) + return(gsettable) + }) #end module server +} #end server \ No newline at end of file diff --git a/components/board.expression/R/expression_ui.R b/components/board.expression/R/expression_ui.R index 32bc93294..331ac280c 100644 --- a/components/board.expression/R/expression_ui.R +++ b/components/board.expression/R/expression_ui.R @@ -183,7 +183,8 @@ ExpressionUI <- function(id) { ), div( class = "col-md-4", - tableWidget(ns("gsettable")) + expression_table_gsettable_ui(id = ns("gsettable"), + label = "II") ) ) ), From 401fd6ce52e2627e13b4df699d3e32b38d801398 Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Sun, 29 Jan 2023 23:16:26 +0100 Subject: [PATCH 20/32] fctable refactored --- .../board.expression/R/expression_server.R | 207 +++++++++--------- .../R/expression_table_fctable.R | 188 +++++++++++----- .../R/expression_table_gsettable.R | 5 +- components/board.expression/R/expression_ui.R | 5 +- 4 files changed, 251 insertions(+), 154 deletions(-) diff --git a/components/board.expression/R/expression_server.R b/components/board.expression/R/expression_server.R index ad396f7fb..eb213d6e4 100644 --- a/components/board.expression/R/expression_server.R +++ b/components/board.expression/R/expression_server.R @@ -415,7 +415,7 @@ ExpressionBoard <- function(id, inputData) { # tab differential expression > Volcano Methods #### - # tables #### + # rendering tables #### gx_related_genesets <- shiny::reactive({ @@ -470,6 +470,12 @@ ExpressionBoard <- function(id, inputData) { width = c("100%", 800), watermark=FALSE) + expression_table_fctable_server(id = "fctable", + ngs = inputData, + res = filteredDiffExprTable, + height = c(tabH, 700), + watermark=FALSE) + @@ -668,106 +674,111 @@ ExpressionBoard <- function(id, inputData) { ## Foldchange (all) ## ================================================================================ - fctable.RENDER <- shiny::reactive({ - ngs <- inputData() - res <- filteredDiffExprTable() - 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 <- metaFC() - Q <- metaQ() - - fc.rms <- sqrt(F[, 1]**2) - if (NCOL(F) > 1) { - fc.rms <- round(sqrt(rowMeans(F**2)), digits = 4) - } - - show.q <- TRUE - show.q <- input$fctable_showq - df <- NULL - if (show.q) { - F1 <- do.call(cbind, lapply(1:ncol(F), function(i) cbind(F[, i], Q[, i]))) - colnames(F1) <- as.vector(rbind(paste0("FC.", colnames(F)), paste0("q.", colnames(Q)))) - ## colnames(F1) <- sub("q.*","q",colnames(F1)) - df <- data.frame(gene = rownames(F), rms.FC = fc.rms, F1, check.names = FALSE) - } else { - F1 <- F - colnames(F1) <- paste0("FC.", colnames(F)) - df <- data.frame(gene = rownames(F), rms.FC = fc.rms, F1, check.names = FALSE) - } - - df <- df[intersect(rownames(df), rownames(res)), ] ## take intersection of current comparison - df <- df[order(-df$rms.FC), ] - colnames(df) <- gsub("_", " ", colnames(df)) ## so it allows wrap line - colnames(F1) <- gsub("_", " ", colnames(F1)) ## so it allows wrap line - qv.cols <- grep("^q", colnames(F1)) - fc.cols <- setdiff(which(colnames(df) %in% colnames(F1)), qv.cols) - ## if(length(qv.cols)==0) qv = 0 - - dt <- DT::datatable(df, - rownames = FALSE, - # class = 'compact cell-border stripe hover', - class = "compact hover", - extensions = c("Scroller"), - selection = list(mode = "single", target = "row", selected = c(1)), - fillContainer = TRUE, - options = list( - dom = "lfrtip", - ## pageLength = 20,## lengthMenu = c(20, 30, 40, 60, 100, 250), - scrollX = TRUE, - scrollY = tabV, - scroller = TRUE, deferRender = TRUE - ) ## end of options.list - ) %>% - DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") %>% - DT::formatSignif(columns = fc.cols, digits = 3) %>% - DT::formatStyle("rms.FC", - ## background = DT::styleColorBar(c(0,3), 'lightblue'), - background = color_from_middle(fc.rms, "lightblue", "#f5aeae"), - backgroundSize = "98% 88%", backgroundRepeat = "no-repeat", - backgroundPosition = "center" - ) %>% - DT::formatStyle(fc.cols, - ## background = DT::styleColorBar(c(0,3), 'lightblue'), - background = color_from_middle(F, "lightblue", "#f5aeae"), - backgroundSize = "98% 88%", backgroundRepeat = "no-repeat", - backgroundPosition = "center" - ) - - if (length(qv.cols) > 0) { - dt <- dt %>% - DT::formatSignif(columns = qv.cols, digits = 3) - } - - dt - }) - - fctable_text <- "The Foldchange (all) tab reports the gene fold changes for all contrasts in the selected dataset." - fctable_caption <- "Differential expression (fold-change) across all contrasts. The column `rms.FC` corresponds to the root-mean-square fold-change across all contrasts." + #fctable table refactoring ###### - fctable_opts <- shiny::tagList( - withTooltip(shiny::checkboxInput(ns("fctable_showq"), "show q-values", TRUE), - "Show q-values next to FC values.", - placement = "right", options = list(container = "body") - ) - ) + # fctable.RENDER <- shiny::reactive({ + # ngs <- inputData() + # res <- filteredDiffExprTable() + # 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 <- metaFC() + # Q <- metaQ() + # + # fc.rms <- sqrt(F[, 1]**2) + # if (NCOL(F) > 1) { + # fc.rms <- round(sqrt(rowMeans(F**2)), digits = 4) + # } + # + # show.q <- TRUE + # show.q <- input$fctable_showq + # df <- NULL + # if (show.q) { + # F1 <- do.call(cbind, lapply(1:ncol(F), function(i) cbind(F[, i], Q[, i]))) + # colnames(F1) <- as.vector(rbind(paste0("FC.", colnames(F)), paste0("q.", colnames(Q)))) + # ## colnames(F1) <- sub("q.*","q",colnames(F1)) + # df <- data.frame(gene = rownames(F), rms.FC = fc.rms, F1, check.names = FALSE) + # } else { + # F1 <- F + # colnames(F1) <- paste0("FC.", colnames(F)) + # df <- data.frame(gene = rownames(F), rms.FC = fc.rms, F1, check.names = FALSE) + # } + # + # df <- df[intersect(rownames(df), rownames(res)), ] ## take intersection of current comparison + # df <- df[order(-df$rms.FC), ] + # colnames(df) <- gsub("_", " ", colnames(df)) ## so it allows wrap line + # colnames(F1) <- gsub("_", " ", colnames(F1)) ## so it allows wrap line + # qv.cols <- grep("^q", colnames(F1)) + # fc.cols <- setdiff(which(colnames(df) %in% colnames(F1)), qv.cols) + # ## if(length(qv.cols)==0) qv = 0 + # + # dt <- DT::datatable(df, + # rownames = FALSE, + # # class = 'compact cell-border stripe hover', + # class = "compact hover", + # extensions = c("Scroller"), + # selection = list(mode = "single", target = "row", selected = c(1)), + # fillContainer = TRUE, + # options = list( + # dom = "lfrtip", + # ## pageLength = 20,## lengthMenu = c(20, 30, 40, 60, 100, 250), + # scrollX = TRUE, + # scrollY = tabV, + # scroller = TRUE, deferRender = TRUE + # ) ## end of options.list + # ) %>% + # DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") %>% + # DT::formatSignif(columns = fc.cols, digits = 3) %>% + # DT::formatStyle("rms.FC", + # ## background = DT::styleColorBar(c(0,3), 'lightblue'), + # background = color_from_middle(fc.rms, "lightblue", "#f5aeae"), + # backgroundSize = "98% 88%", backgroundRepeat = "no-repeat", + # backgroundPosition = "center" + # ) %>% + # DT::formatStyle(fc.cols, + # ## background = DT::styleColorBar(c(0,3), 'lightblue'), + # background = color_from_middle(F, "lightblue", "#f5aeae"), + # backgroundSize = "98% 88%", backgroundRepeat = "no-repeat", + # backgroundPosition = "center" + # ) + # + # if (length(qv.cols) > 0) { + # dt <- dt %>% + # DT::formatSignif(columns = qv.cols, digits = 3) + # } + # + # dt + # }) + # + # fctable_text <- "The Foldchange (all) tab reports the gene fold changes for all contrasts in the selected dataset." + # + # fctable_caption <- "Differential expression (fold-change) across all contrasts. The column `rms.FC` corresponds to the root-mean-square fold-change across all contrasts." + # + # fctable_opts <- shiny::tagList( + # withTooltip(shiny::checkboxInput(ns("fctable_showq"), "show q-values", TRUE), + # "Show q-values next to FC values.", + # placement = "right", options = list(container = "body") + # ) + # ) + # + # shiny::callModule( + # tableModule, + # id = "fctable", + # func = fctable.RENDER, + # title = "Gene fold changes for all contrasts", + # info.text = fctable_text, + # options = fctable_opts, + # caption = fctable_caption, + # height = c(tabH, 700) + # ) - shiny::callModule( - tableModule, - id = "fctable", - func = fctable.RENDER, - title = "Gene fold changes for all contrasts", - info.text = fctable_text, - options = fctable_opts, - caption = fctable_caption, - height = c(tabH, 700) - ) + #end fctable table refactoring ####### ## ================================================================================ ## FDR table diff --git a/components/board.expression/R/expression_table_fctable.R b/components/board.expression/R/expression_table_fctable.R index 4014939a0..5bb5bb9fa 100644 --- a/components/board.expression/R/expression_table_fctable.R +++ b/components/board.expression/R/expression_table_fctable.R @@ -1,55 +1,141 @@ -#' ## -#' ## This file is part of the Omics Playground project. -#' ## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. -#' ## +## +## This file is part of the Omics Playground project. +## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. +## + +#' UI code for table code: expression board #' -#' #' UI code for table code: expression board -#' #' -#' #' @param id -#' #' @param label -#' #' @param height -#' #' @param width -#' #' -#' #' @export -#' expression_table_TableName_ui <- function(id, -#' label='', -#' height, -#' width) { +#' @param id +#' @param label +#' @param height +#' @param width #' -#' ns <- shiny::NS(id) +#' @export +expression_table_fctable_ui <- function(id) { + + ns <- shiny::NS(id) + + tableWidget(ns("table")) + +} + +#' Server side table code: expression board #' -#' tableWidget(ns("table")) +#' @param id +#' @param watermark #' -#' } -#' -#' #' Server side table code: expression board -#' #' -#' #' @param id -#' #' @param watermark -#' #' -#' #' @export -#' expression_table_TableName_server <- function(id, -#' watermark=FALSE){ -#' moduleServer( id, function(input, output, session) { -#' -#' table.RENDER <- shiny::reactive({ -#' -#' #code here -#' -#' }) -#' -#' table_info = "" -#' -#' score_table <- shiny::callModule( -#' tableModule, id = "table", -#' func = "table.RENDER", ## ns=ns, -#' info.text = table_info, -#' title = tags$div( -#' HTML('')), -#' height = c(,), -#' width = c(,) -#' ) -#' return(score_table) -#' } -#' ) -#' } \ No newline at end of file +#' @export +expression_table_fctable_server <- function(id, + ngs, #inputData() + res, #filteredDiffExprTable + height, + watermark=FALSE){ + moduleServer( id, function(input, output, session) { + + ns <- session$ns + + message("expression_table_fctable_server called") + + 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 <- metaFC() + Q <- metaQ() + + fc.rms <- sqrt(F[, 1]**2) + if (NCOL(F) > 1) { + fc.rms <- round(sqrt(rowMeans(F**2)), digits = 4) + } + + show.q <- TRUE + show.q <- input$fctable_showq + df <- NULL + if (show.q) { + F1 <- do.call(cbind, lapply(1:ncol(F), function(i) cbind(F[, i], Q[, i]))) + colnames(F1) <- as.vector(rbind(paste0("FC.", colnames(F)), paste0("q.", colnames(Q)))) + ## colnames(F1) <- sub("q.*","q",colnames(F1)) + df <- data.frame(gene = rownames(F), rms.FC = fc.rms, F1, check.names = FALSE) + } else { + F1 <- F + colnames(F1) <- paste0("FC.", colnames(F)) + df <- data.frame(gene = rownames(F), rms.FC = fc.rms, F1, check.names = FALSE) + } + + df <- df[intersect(rownames(df), rownames(res)), ] ## take intersection of current comparison + df <- df[order(-df$rms.FC), ] + colnames(df) <- gsub("_", " ", colnames(df)) ## so it allows wrap line + colnames(F1) <- gsub("_", " ", colnames(F1)) ## so it allows wrap line + qv.cols <- grep("^q", colnames(F1)) + fc.cols <- setdiff(which(colnames(df) %in% colnames(F1)), qv.cols) + ## if(length(qv.cols)==0) qv = 0 + + dt <- DT::datatable(df, + rownames = FALSE, + # class = 'compact cell-border stripe hover', + class = "compact hover", + extensions = c("Scroller"), + selection = list(mode = "single", target = "row", selected = c(1)), + fillContainer = TRUE, + options = list( + dom = "lfrtip", + ## pageLength = 20,## lengthMenu = c(20, 30, 40, 60, 100, 250), + scrollX = TRUE, + scrollY = tabV, + scroller = TRUE, deferRender = TRUE + ) ## end of options.list + ) %>% + DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") %>% + DT::formatSignif(columns = fc.cols, digits = 3) %>% + DT::formatStyle("rms.FC", + ## background = DT::styleColorBar(c(0,3), 'lightblue'), + background = color_from_middle(fc.rms, "lightblue", "#f5aeae"), + backgroundSize = "98% 88%", backgroundRepeat = "no-repeat", + backgroundPosition = "center" + ) %>% + DT::formatStyle(fc.cols, + ## background = DT::styleColorBar(c(0,3), 'lightblue'), + background = color_from_middle(F, "lightblue", "#f5aeae"), + backgroundSize = "98% 88%", backgroundRepeat = "no-repeat", + backgroundPosition = "center" + ) + + if (length(qv.cols) > 0) { + dt <- dt %>% + DT::formatSignif(columns = qv.cols, digits = 3) + } + + dt + }) + + fctable_text <- "The Foldchange (all) tab reports the gene fold changes for all contrasts in the selected dataset." + + fctable_caption <- "Differential expression (fold-change) across all contrasts. The column `rms.FC` corresponds to the root-mean-square fold-change across all contrasts." + + fctable_opts <- shiny::tagList( + withTooltip(shiny::checkboxInput(ns("fctable_showq"), "show q-values", TRUE), + "Show q-values next to FC values.", + placement = "right", options = list(container = "body") + ) + ) + + shiny::callModule( + tableModule, + id = "fctable", + func = fctable.RENDER, + title = "Gene fold changes for all contrasts", + info.text = fctable_text, + options = fctable_opts, + caption = fctable_caption, + height = height + ) + + })#end module server +}#end server \ No newline at end of file diff --git a/components/board.expression/R/expression_table_gsettable.R b/components/board.expression/R/expression_table_gsettable.R index e5a5a6bb2..ac38e7db2 100644 --- a/components/board.expression/R/expression_table_gsettable.R +++ b/components/board.expression/R/expression_table_gsettable.R @@ -11,8 +11,7 @@ #' @param width #' #' @export -expression_table_gsettable_ui <- function(id, - label='') { +expression_table_gsettable_ui <- function(id) { ns <- shiny::NS(id) @@ -33,6 +32,8 @@ expression_table_gsettable_server <- function(id, watermark=FALSE){ moduleServer( id, function(input, output, session) { + ns <- session$ns + gsettable.RENDER <- shiny::reactive({ df <- gx_related_genesets() if (is.null(df)) { diff --git a/components/board.expression/R/expression_ui.R b/components/board.expression/R/expression_ui.R index 331ac280c..87fc8b5ea 100644 --- a/components/board.expression/R/expression_ui.R +++ b/components/board.expression/R/expression_ui.R @@ -183,14 +183,13 @@ ExpressionUI <- function(id) { ), div( class = "col-md-4", - expression_table_gsettable_ui(id = ns("gsettable"), - label = "II") + expression_table_gsettable_ui(id = ns("gsettable")) ) ) ), shiny::tabPanel( "Foldchange (all)", - tableWidget(ns("fctable")) + expression_table_fctable_ui(ns("fctable")) ), shiny::tabPanel( "FDR table", From f33d5b692f3fcd85a76a74645909611d4352f5ab Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Sun, 29 Jan 2023 23:27:03 +0100 Subject: [PATCH 21/32] FDRtable refactored --- .../board.expression/R/expression_server.R | 10 ++ .../R/expression_table_FDRtable.R | 166 ++++++++++++------ components/board.expression/R/expression_ui.R | 2 +- 3 files changed, 126 insertions(+), 52 deletions(-) diff --git a/components/board.expression/R/expression_server.R b/components/board.expression/R/expression_server.R index eb213d6e4..92fea0b7e 100644 --- a/components/board.expression/R/expression_server.R +++ b/components/board.expression/R/expression_server.R @@ -476,6 +476,12 @@ ExpressionBoard <- function(id, inputData) { height = c(tabH, 700), watermark=FALSE) + expression_table_FDRtable_server(id = "FDRtable", + ngs = inputData, + GX.DEFAULTTEST = GX.DEFAULTTEST, + height = c(tabH, 700), + watermark=FALSE) + @@ -780,6 +786,8 @@ ExpressionBoard <- function(id, inputData) { #end fctable table refactoring ####### + #FDRtable table code ######### + ## ================================================================================ ## FDR table ## ================================================================================ @@ -866,6 +874,8 @@ ExpressionBoard <- function(id, inputData) { height = c(tabH, 700) ) + #end FDRtable table code ######### + ## ---------------------------------------------------------------------- ## reactive values to return to parent environment ## ---------------------------------------------------------------------- diff --git a/components/board.expression/R/expression_table_FDRtable.R b/components/board.expression/R/expression_table_FDRtable.R index 4014939a0..c8a994c48 100644 --- a/components/board.expression/R/expression_table_FDRtable.R +++ b/components/board.expression/R/expression_table_FDRtable.R @@ -1,55 +1,119 @@ -#' ## -#' ## This file is part of the Omics Playground project. -#' ## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. -#' ## +## +## This file is part of the Omics Playground project. +## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. +## + +#' UI code for table code: expression board #' -#' #' UI code for table code: expression board -#' #' -#' #' @param id -#' #' @param label -#' #' @param height -#' #' @param width -#' #' -#' #' @export -#' expression_table_TableName_ui <- function(id, -#' label='', -#' height, -#' width) { +#' @param id +#' @param label +#' @param height +#' @param width #' -#' ns <- shiny::NS(id) +#' @export +expression_table_FDRtable_ui <- function(id) { + + ns <- shiny::NS(id) + + tableWidget(ns("table")) + +} + +#' Server side table code: expression board #' -#' tableWidget(ns("table")) +#' @param id +#' @param watermark #' -#' } -#' -#' #' Server side table code: expression board -#' #' -#' #' @param id -#' #' @param watermark -#' #' -#' #' @export -#' expression_table_TableName_server <- function(id, -#' watermark=FALSE){ -#' moduleServer( id, function(input, output, session) { -#' -#' table.RENDER <- shiny::reactive({ -#' -#' #code here -#' -#' }) -#' -#' table_info = "" -#' -#' score_table <- shiny::callModule( -#' tableModule, id = "table", -#' func = "table.RENDER", ## ns=ns, -#' info.text = table_info, -#' title = tags$div( -#' HTML('')), -#' height = c(,), -#' width = c(,) -#' ) -#' return(score_table) -#' } -#' ) -#' } \ No newline at end of file +#' @export +expression_table_FDRtable_server <- function(id, + ngs, + GX.DEFAULTTEST, + height, #c(tabH, 700) + watermark=FALSE){ + moduleServer( id, function(input, output, session) { + + ns <- session$ns + + FDRtable.RENDER <- shiny::reactive({ + + methods <- GX.DEFAULTTEST + methods <- input$gx_statmethod + ## methods = input$gx_statmethod + if (is.null(methods)) { + return(NULL) + } + + ## 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 + 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)) { + rownames(counts.up[[i]]) <- paste0(names(counts.up)[i], "::", rownames(counts.up[[i]])) + rownames(counts.down[[i]]) <- paste0(names(counts.down)[i], "::", rownames(counts.down[[i]])) + } + sig.up <- do.call(rbind, counts.up) + sig.down <- do.call(rbind, counts.down) + + sig.up <- sig.up[order(rownames(sig.up)), , drop = FALSE] + sig.down <- sig.down[order(rownames(sig.down)), , drop = FALSE] + colnames(sig.up)[1] <- paste("UP FDR = ", colnames(sig.up)[1]) + colnames(sig.down)[1] <- paste("DOWN FDR = ", colnames(sig.down)[1]) + colnames(sig.down) <- paste0(" ", colnames(sig.down)) + sigcount <- cbind(sig.down, sig.up[rownames(sig.down), , drop = FALSE]) + dim(sigcount) + maxsig <- 0.99 * max(sigcount, na.rm = TRUE) + + contr <- sub("::.*", "", rownames(sigcount)) + ## contr = rownames(sigcount) + metd <- sub(".*::", "", rownames(sigcount)) + D <- data.frame(method = metd, contrast = contr, sigcount, check.names = FALSE) + + DT::datatable(D, + rownames = FALSE, + # class = 'compact cell-border stripe hover', + class = "compact hover", + fillContainer = TRUE, + extensions = c("Scroller"), + options = list( + dom = "lfrtip", + pageLength = 999, ## lengthMenu = c(20, 30, 40, 60, 100, 250), + scrollX = TRUE, + scrollY = tabV, + scroller = TRUE, deferRender = TRUE + ) ## end of options.list + ) %>% + DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") %>% + DT::formatStyle(colnames(sig.up), + background = DT::styleColorBar(c(0, maxsig), "#f5aeae"), + backgroundSize = "98% 88%", + backgroundRepeat = "no-repeat", + backgroundPosition = "center" + ) %>% + DT::formatStyle(colnames(sig.down), + background = DT::styleColorBar(c(0, maxsig), "lightblue"), + backgroundSize = "98% 88%", + backgroundRepeat = "no-repeat", + backgroundPosition = "center" + ) + }) + + FDRtable_text <- "The FDR table tab reports the number of significant genes at different FDR thresholds for all contrasts within the dataset." + + FDRtable_caption <- "Number of significant genes versus FDR. This table reports the number of significant genes at different FDR thresholds for all contrasts and methods. This enables to quickly see which methods are more sensitive. The left part of the table (in blue) correspond to the number of significant down-regulated genes, the right part (in red) correspond to the number of significant overexpressed genes." + + shiny::callModule( + tableModule, + id = "FDRtable", + func = FDRtable.RENDER, + info.text = FDRtable_text, + title = "Number of significant genes", + caption = FDRtable_caption, + height = height + ) + })#end module server +}#end server \ No newline at end of file diff --git a/components/board.expression/R/expression_ui.R b/components/board.expression/R/expression_ui.R index 87fc8b5ea..88f7970c3 100644 --- a/components/board.expression/R/expression_ui.R +++ b/components/board.expression/R/expression_ui.R @@ -193,7 +193,7 @@ ExpressionUI <- function(id) { ), shiny::tabPanel( "FDR table", - tableWidget(ns("FDRtable")) + expression_table_FDRtable_ui(ns("FDRtable")) ) ) ) From ef0f5c7fa7b2125e1c4b92a4e810d500343a2c3d Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Sun, 29 Jan 2023 23:39:19 +0100 Subject: [PATCH 22/32] add missing reactives metaFC and metaQ to fctable --- .../board.expression/R/expression_server.R | 178 +++++++++--------- .../R/expression_table_fctable.R | 2 + 2 files changed, 87 insertions(+), 93 deletions(-) diff --git a/components/board.expression/R/expression_server.R b/components/board.expression/R/expression_server.R index 92fea0b7e..653489166 100644 --- a/components/board.expression/R/expression_server.R +++ b/components/board.expression/R/expression_server.R @@ -473,6 +473,8 @@ ExpressionBoard <- function(id, inputData) { expression_table_fctable_server(id = "fctable", ngs = inputData, res = filteredDiffExprTable, + metaFC = metaFC, + metaQ = metaQ, height = c(tabH, 700), watermark=FALSE) @@ -676,11 +678,6 @@ ExpressionBoard <- function(id, inputData) { #end gsettable refactoring ######## - ## ================================================================================ - ## Foldchange (all) - ## ================================================================================ - - #fctable table refactoring ###### # fctable.RENDER <- shiny::reactive({ @@ -788,97 +785,92 @@ ExpressionBoard <- function(id, inputData) { #FDRtable table code ######### - ## ================================================================================ - ## FDR table - ## ================================================================================ - - FDRtable.RENDER <- shiny::reactive({ - - methods <- GX.DEFAULTTEST - methods <- input$gx_statmethod - ## methods = input$gx_statmethod - if (is.null(methods)) { - return(NULL) - } - - ## comp <- input$gx_contrast - ngs <- inputData() - - 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 - 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)) { - rownames(counts.up[[i]]) <- paste0(names(counts.up)[i], "::", rownames(counts.up[[i]])) - rownames(counts.down[[i]]) <- paste0(names(counts.down)[i], "::", rownames(counts.down[[i]])) - } - sig.up <- do.call(rbind, counts.up) - sig.down <- do.call(rbind, counts.down) - - sig.up <- sig.up[order(rownames(sig.up)), , drop = FALSE] - sig.down <- sig.down[order(rownames(sig.down)), , drop = FALSE] - colnames(sig.up)[1] <- paste("UP FDR = ", colnames(sig.up)[1]) - colnames(sig.down)[1] <- paste("DOWN FDR = ", colnames(sig.down)[1]) - colnames(sig.down) <- paste0(" ", colnames(sig.down)) - sigcount <- cbind(sig.down, sig.up[rownames(sig.down), , drop = FALSE]) - dim(sigcount) - maxsig <- 0.99 * max(sigcount, na.rm = TRUE) - - contr <- sub("::.*", "", rownames(sigcount)) - ## contr = rownames(sigcount) - metd <- sub(".*::", "", rownames(sigcount)) - D <- data.frame(method = metd, contrast = contr, sigcount, check.names = FALSE) - - DT::datatable(D, - rownames = FALSE, - # class = 'compact cell-border stripe hover', - class = "compact hover", - fillContainer = TRUE, - extensions = c("Scroller"), - options = list( - dom = "lfrtip", - pageLength = 999, ## lengthMenu = c(20, 30, 40, 60, 100, 250), - scrollX = TRUE, - scrollY = tabV, - scroller = TRUE, deferRender = TRUE - ) ## end of options.list - ) %>% - DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") %>% - DT::formatStyle(colnames(sig.up), - background = DT::styleColorBar(c(0, maxsig), "#f5aeae"), - backgroundSize = "98% 88%", - backgroundRepeat = "no-repeat", - backgroundPosition = "center" - ) %>% - DT::formatStyle(colnames(sig.down), - background = DT::styleColorBar(c(0, maxsig), "lightblue"), - backgroundSize = "98% 88%", - backgroundRepeat = "no-repeat", - backgroundPosition = "center" - ) - }) - - FDRtable_text <- "The FDR table tab reports the number of significant genes at different FDR thresholds for all contrasts within the dataset." - - FDRtable_caption <- "Number of significant genes versus FDR. This table reports the number of significant genes at different FDR thresholds for all contrasts and methods. This enables to quickly see which methods are more sensitive. The left part of the table (in blue) correspond to the number of significant down-regulated genes, the right part (in red) correspond to the number of significant overexpressed genes." - - shiny::callModule( - tableModule, - id = "FDRtable", - func = FDRtable.RENDER, - info.text = FDRtable_text, - title = "Number of significant genes", - caption = FDRtable_caption, - height = c(tabH, 700) - ) + # FDRtable.RENDER <- shiny::reactive({ + # + # methods <- GX.DEFAULTTEST + # methods <- input$gx_statmethod + # ## methods = input$gx_statmethod + # if (is.null(methods)) { + # return(NULL) + # } + # + # ## comp <- input$gx_contrast + # ngs <- inputData() + # + # 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 + # 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)) { + # rownames(counts.up[[i]]) <- paste0(names(counts.up)[i], "::", rownames(counts.up[[i]])) + # rownames(counts.down[[i]]) <- paste0(names(counts.down)[i], "::", rownames(counts.down[[i]])) + # } + # sig.up <- do.call(rbind, counts.up) + # sig.down <- do.call(rbind, counts.down) + # + # sig.up <- sig.up[order(rownames(sig.up)), , drop = FALSE] + # sig.down <- sig.down[order(rownames(sig.down)), , drop = FALSE] + # colnames(sig.up)[1] <- paste("UP FDR = ", colnames(sig.up)[1]) + # colnames(sig.down)[1] <- paste("DOWN FDR = ", colnames(sig.down)[1]) + # colnames(sig.down) <- paste0(" ", colnames(sig.down)) + # sigcount <- cbind(sig.down, sig.up[rownames(sig.down), , drop = FALSE]) + # dim(sigcount) + # maxsig <- 0.99 * max(sigcount, na.rm = TRUE) + # + # contr <- sub("::.*", "", rownames(sigcount)) + # ## contr = rownames(sigcount) + # metd <- sub(".*::", "", rownames(sigcount)) + # D <- data.frame(method = metd, contrast = contr, sigcount, check.names = FALSE) + # + # DT::datatable(D, + # rownames = FALSE, + # # class = 'compact cell-border stripe hover', + # class = "compact hover", + # fillContainer = TRUE, + # extensions = c("Scroller"), + # options = list( + # dom = "lfrtip", + # pageLength = 999, ## lengthMenu = c(20, 30, 40, 60, 100, 250), + # scrollX = TRUE, + # scrollY = tabV, + # scroller = TRUE, deferRender = TRUE + # ) ## end of options.list + # ) %>% + # DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") %>% + # DT::formatStyle(colnames(sig.up), + # background = DT::styleColorBar(c(0, maxsig), "#f5aeae"), + # backgroundSize = "98% 88%", + # backgroundRepeat = "no-repeat", + # backgroundPosition = "center" + # ) %>% + # DT::formatStyle(colnames(sig.down), + # background = DT::styleColorBar(c(0, maxsig), "lightblue"), + # backgroundSize = "98% 88%", + # backgroundRepeat = "no-repeat", + # backgroundPosition = "center" + # ) + # }) + # + # FDRtable_text <- "The FDR table tab reports the number of significant genes at different FDR thresholds for all contrasts within the dataset." + # + # FDRtable_caption <- "Number of significant genes versus FDR. This table reports the number of significant genes at different FDR thresholds for all contrasts and methods. This enables to quickly see which methods are more sensitive. The left part of the table (in blue) correspond to the number of significant down-regulated genes, the right part (in red) correspond to the number of significant overexpressed genes." + # + # shiny::callModule( + # tableModule, + # id = "FDRtable", + # func = FDRtable.RENDER, + # info.text = FDRtable_text, + # title = "Number of significant genes", + # caption = FDRtable_caption, + # height = c(tabH, 700) + # ) #end FDRtable table code ######### - ## ---------------------------------------------------------------------- - ## reactive values to return to parent environment - ## ---------------------------------------------------------------------- + + # reactive values to return to parent environment ######### metaQ <- shiny::reactive({ ngs <- inputData() diff --git a/components/board.expression/R/expression_table_fctable.R b/components/board.expression/R/expression_table_fctable.R index 5bb5bb9fa..72e9e9d57 100644 --- a/components/board.expression/R/expression_table_fctable.R +++ b/components/board.expression/R/expression_table_fctable.R @@ -28,6 +28,8 @@ expression_table_fctable_ui <- function(id) { expression_table_fctable_server <- function(id, ngs, #inputData() res, #filteredDiffExprTable + metaFC, + metaQ, height, watermark=FALSE){ moduleServer( id, function(input, output, session) { From dc2fe9e7f77dcc38b6f3b37d4e9813355811b6cf Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Mon, 30 Jan 2023 11:05:50 +0100 Subject: [PATCH 23/32] added board header --- components/board.expression/R/expression_ui.R | 227 +++++++++--------- 1 file changed, 117 insertions(+), 110 deletions(-) diff --git a/components/board.expression/R/expression_ui.R b/components/board.expression/R/expression_ui.R index 88f7970c3..a77454a4c 100644 --- a/components/board.expression/R/expression_ui.R +++ b/components/board.expression/R/expression_ui.R @@ -69,133 +69,140 @@ ExpressionUI <- function(id) { rowH <- 340 ## full height of page imgH <- 340 ## height of images - tagList( + div( + boardHeader(title = "Differential expression", info_link = ns("gx_info")), div( - style = "max-height:50vh;", - shiny::tabsetPanel( - id = ns("tabs1"), - shiny::tabPanel( - "Plot", - div( - class = "row", - div( - class = "col-md-3", - expression_plot_volcano_ui(ns("plots_volcano"), - label = "A", - height = c(imgH, imgH), - width = c("auto", imgH) - ), - ), - div( - class = "col-md-3", - expression_plot_maplot_ui( - id = ns("plots_maplot"), - label = "B", - height = c(imgH, imgH), - width = c("auto", imgH) - ), - ), - div( - class = "col-md-3", - expression_plot_boxplot_ui( - id = ns("plots_boxplot"), - label = "C", - height = c(imgH, imgH), - width = c("auto", imgH) - ), - ), - div( - class = "col-md-3", - expression_plot_topfoldchange_ui( - id = ns("plots_topfoldchange"), - label = "D", - height = c(imgH, imgH), - width = c("auto", imgH) + tagList( + + div( + style = "max-height:50vh;", + shiny::tabsetPanel( + id = ns("tabs1"), + shiny::tabPanel( + "Plot", + div( + class = "row", + div( + class = "col-md-3", + expression_plot_volcano_ui(ns("plots_volcano"), + label = "A", + height = c(imgH, imgH), + width = c("auto", imgH) + ), + ), + div( + class = "col-md-3", + expression_plot_maplot_ui( + id = ns("plots_maplot"), + label = "B", + height = c(imgH, imgH), + width = c("auto", imgH) + ), + ), + div( + class = "col-md-3", + expression_plot_boxplot_ui( + id = ns("plots_boxplot"), + label = "C", + height = c(imgH, imgH), + width = c("auto", imgH) + ), + ), + div( + class = "col-md-3", + expression_plot_topfoldchange_ui( + id = ns("plots_topfoldchange"), + label = "D", + height = c(imgH, imgH), + width = c("auto", imgH) + ), + ) ), - ) - ), - tags$div( - HTML("Expression plots associated with the selected contrast. (a) Volcano-plot plotting fold-change versuson + tags$div( + HTML("Expression plots associated with the selected contrast. (a) Volcano-plot plotting fold-change versuson significance the x and y axes, respectively. (b) MA-plot plotting signal intensity versus fold-change on the x and y axes, respectively. (c) Sorted barplot of the top diffentially expressed genes with largest (absolute) fold-change for selected contrast. (d) Sorted barplot of the differential expression of the selected gene across all contrasts.") - ) - ), - shiny::tabPanel( - "Top genes", - expression_plot_topgenes_ui( - id = ns("topgenes"), - label = "A", - height = c(imgH,420), - width = c('auto',1600) - ), # c('auto',1600) + ) + ), + shiny::tabPanel( + "Top genes", + expression_plot_topgenes_ui( + id = ns("topgenes"), + label = "A", + height = c(imgH,420), + width = c('auto',1600) + ), - shiny::br(), - tags$div( - HTML("Top differentially expressed genes. Expression barplots of the top most differentially + shiny::br(), + tags$div( + HTML("Top differentially expressed genes. Expression barplots of the top most differentially (both positively and negatively) expressed genes for the selected contrast.") - ) - ), - shiny::tabPanel( - "Volcano (all)", - expression_plot_volcanoAll_ui(ns("volcanoAll"), - label='A', - height = c(imgH, 500), - width = c("auto", 1600)), - shiny::br(), - tags$div( - HTML("Volcano plot for all contrasts. Simultaneous visualisation of volcano + ) + ), + shiny::tabPanel( + "Volcano (all)", + expression_plot_volcanoAll_ui(ns("volcanoAll"), + label='A', + height = c(imgH, 500), + width = c("auto", 1600)), + shiny::br(), + tags$div( + HTML("Volcano plot for all contrasts. Simultaneous visualisation of volcano plots of genes for all contrasts. Experimental contrasts with better statistical significance will show volcano plots with 'higher' wings.") - ) - ), - shiny::tabPanel( - "Volcano (methods)", - expression_plot_volcanoMethods_ui(id = ns("volcanoMethods"), - label ='A', - height = c(imgH, 450), - width = c("auto", 1600)), - shiny::br(), - tags$div( - HTML("Volcano plot for all statistical methods. Simultaneous visualisation of volcano plots + ) + ), + shiny::tabPanel( + "Volcano (methods)", + expression_plot_volcanoMethods_ui(id = ns("volcanoMethods"), + label ='A', + height = c(imgH, 450), + width = c("auto", 1600)), + shiny::br(), + tags$div( + HTML("Volcano plot for all statistical methods. Simultaneous visualisation of volcano plots of genes by multiple differential expression methods for the selected contrast. Methods showing better statistical significance will show volcano plots with 'higher' wings.") + ) + ) ) - ) - ) - ), - div( - style = "max-height: 50vh", - shiny::tabsetPanel( - id = ns("tabs2"), - shiny::tabPanel( - "Table", - tags$div( - HTML("Differential Expression Analysis. Compare expression between + ), + div( + style = "max-height: 50vh", + shiny::tabsetPanel( + id = ns("tabs2"), + shiny::tabPanel( + "Table", + tags$div( + HTML("Differential Expression Analysis. Compare expression between two conditions. Determine which genes are significantly downregulated or overexpressed in one of the groups.") - ), - shiny::br(), - div( - class = "row", - div( - class = "col-md-8", - expression_table_genetable_ui(id = ns("genetable")) + ), + shiny::br(), + div( + class = "row", + div( + class = "col-md-8", + expression_table_genetable_ui(id = ns("genetable")) + ), + div( + class = "col-md-4", + expression_table_gsettable_ui(id = ns("gsettable")) + ) + ) ), - div( - class = "col-md-4", - expression_table_gsettable_ui(id = ns("gsettable")) + shiny::tabPanel( + "Foldchange (all)", + expression_table_fctable_ui(ns("fctable")) + ), + shiny::tabPanel( + "FDR table", + expression_table_FDRtable_ui(ns("FDRtable")) ) ) - ), - shiny::tabPanel( - "Foldchange (all)", - expression_table_fctable_ui(ns("fctable")) - ), - shiny::tabPanel( - "FDR table", - expression_table_FDRtable_ui(ns("FDRtable")) ) + + ) ) ) - ) } From 51b496b2f3f1eb681d4d767ebcc8ad8a1159b886 Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Mon, 30 Jan 2023 11:14:08 +0100 Subject: [PATCH 24/32] remove template files --- .../board.expression/R/expression_plot.R | 98 ------------------- .../board.expression/R/expression_table.R | 55 ----------- 2 files changed, 153 deletions(-) delete mode 100644 components/board.expression/R/expression_plot.R delete mode 100644 components/board.expression/R/expression_table.R diff --git a/components/board.expression/R/expression_plot.R b/components/board.expression/R/expression_plot.R deleted file mode 100644 index 9ecc8b001..000000000 --- a/components/board.expression/R/expression_plot.R +++ /dev/null @@ -1,98 +0,0 @@ -#' ## -#' ## This file is part of the Omics Playground project. -#' ## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. -#' ## -#' -#' #' Expression plot UI input function -#' #' -#' #' @description A shiny Module for plotting (UI code). -#' #' -#' #' @param id -#' #' @param label -#' #' @param height -#' #' -#' #' @export -#' expression_plot_FnName_ui <- function(id, -#' label='', -#' height, -#' width) { -#' ns <- shiny::NS(id) -#' -#' info_text = "" -#' -#' PlotModuleUI(ns(""), -#' title = "", -#' label = label, -#' plotlib = "plotly", -#' info.text = info_text, -#' options = NULL, -#' download.fmt=c("png","pdf","csv"), -#' height = height, -#' width = width) -#' } -#' -#' #' Expression plot Server function -#' #' -#' #' @description A shiny Module for plotting (server code). -#' #' -#' #' @param id -#' #' -#' #' @return -#' #' @export -#' expression_plot_FnName_server <- function(id, watermark = FALSE) -#' { -#' moduleServer( id, function(input, output, session) { -#' -#' -#' #reactive function listening for changes in input -#' plot_data <- shiny::reactive({ -#' #code here -#' }) -#' -#' plot.RENDER <- function() { -#' pd <- plot_data() -#' shiny::req(pd) -#' -#' #plot code here -#' } -#' -#' plotly.RENDER <- function() { -#' pd <- plot_data() -#' shiny::req(pd) -#' -#' df <- pd -#' -#' ## plot as regular plot -#' plotly::plot_ly(data = df, -#' type = '', -#' x = "", -#' y = "", -#' ## hoverinfo = "text", -#' hovertext = ~annot, -#' marker = list(color = ~color) -#' ) -#' } -#' -#' modal_plotly.RENDER <- function() { -#' plotly.RENDER() %>% -#' plotly::layout( -#' ## showlegend = TRUE, -#' font = list( -#' size = 16 -#' ) -#' ) -#' } -#' -#' -#' PlotModuleServer( -#' "plot", -#' plotlib = "plotly", -#' func = plotly.RENDER, -#' func2 = modal_plotly.RENDER, -#' csvFunc = plot_data, ## *** downloadable data as CSV -#' res = c(80,170), ## resolution of plots -#' pdf.width = 6, pdf.height = 6, -#' add.watermark = watermark -#' ) -#' }## end of moduleServer -#' } diff --git a/components/board.expression/R/expression_table.R b/components/board.expression/R/expression_table.R deleted file mode 100644 index 5d8fcddb1..000000000 --- a/components/board.expression/R/expression_table.R +++ /dev/null @@ -1,55 +0,0 @@ -#' ## -#' ## This file is part of the Omics Playground project. -#' ## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. -#' ## -#' -#' #' UI code for table code: expression board -#' #' -#' #' @param id -#' #' @param label -#' #' @param height -#' #' @param width -#' #' -#' #' @export -#' expression_table_TableName_ui <- function(id, -#' label='', -#' height, -#' width) { -#' -#' ns <- shiny::NS(id) -#' -#' tableWidget(ns("table")) -#' -#' } -#' -#' #' Server side table code: expression board -#' #' -#' #' @param id -#' #' @param watermark -#' #' -#' #' @export -#' expression_table_TableName_server <- function(id, -#' watermark=FALSE){ -#' moduleServer( id, function(input, output, session) { -#' -#' table.RENDER <- shiny::reactive({ -#' -#' #code here -#' -#' }) -#' -#' table_info = "" -#' -#' score_table <- shiny::callModule( -#' tableModule, id = "table", -#' func = "table.RENDER", ## ns=ns, -#' info.text = table_info, -#' title = tags$div( -#' HTML('')), -#' height = c(,), -#' width = c(,) -#' ) -#' return(score_table) -#' } -#' ) -#' } \ No newline at end of file From 28cc66386b74cf2a515cdd23183ee6ddcc99e35c Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Mon, 30 Jan 2023 11:49:53 +0100 Subject: [PATCH 25/32] remove old table code --- .../board.expression/R/expression_server.R | 386 ------------------ 1 file changed, 386 deletions(-) diff --git a/components/board.expression/R/expression_server.R b/components/board.expression/R/expression_server.R index 653489166..bca77174d 100644 --- a/components/board.expression/R/expression_server.R +++ b/components/board.expression/R/expression_server.R @@ -484,392 +484,6 @@ ExpressionBoard <- function(id, inputData) { height = c(tabH, 700), watermark=FALSE) - - - - #genetable table refactoring ######### - - # gene_selected <- shiny::reactive({ #THIS FN IS NOT USED ANYWHERE! - # i <- as.integer(genetable$rows_selected()) - # if (is.null(i) || length(i) == 0) { - # return(NULL) - # } - # res <- filteredDiffExprTable() - # gene <- rownames(res)[i] - # return(gene) - # }) -# -# genetable.RENDER <- shiny::reactive({ -# -# res <- filteredDiffExprTable() -# ## res <- fullDiffExprTable() -# -# if (is.null(res) || nrow(res) == 0) { -# return(NULL) -# } -# -# fx.col <- grep("fc|fx|mean.diff|logfc|foldchange", tolower(colnames(res)))[1] -# fx.col -# fx <- res[, fx.col] -# -# if ("gene_title" %in% colnames(res)) res$gene_title <- shortstring(res$gene_title, 50) -# rownames(res) <- sub(".*:", "", rownames(res)) -# -# if (!DEV) { -# kk <- grep("meta.fx|meta.fc|meta.p", colnames(res), invert = TRUE) -# res <- res[, kk, drop = FALSE] -# } -# if (!input$gx_showqvalues) { -# kk <- grep("^q[.]", colnames(res), invert = TRUE) -# res <- res[, kk, drop = FALSE] -# } -# -# numeric.cols <- which(sapply(res, is.numeric)) -# numeric.cols <- colnames(res)[numeric.cols] -# -# DT::datatable(res, -# rownames = FALSE, -# ## class = 'compact cell-border stripe hover', -# class = "compact hover", -# extensions = c("Scroller"), -# selection = list(mode = "single", target = "row", selected = 1), -# fillContainer = TRUE, -# options = list( -# dom = "frtip", -# paging = TRUE, -# pageLength = 16, ## lengthMenu = c(20, 30, 40, 60, 100, 250), -# scrollX = TRUE, -# scrollY = FALSE, -# scroller = FALSE, -# deferRender = TRUE, -# search = list( -# regex = TRUE, -# caseInsensitive = TRUE -# ## , search = 'M[ae]' -# ) -# ) ## end of options.list -# ) %>% -# DT::formatSignif(numeric.cols, 4) %>% -# DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") %>% -# DT::formatStyle(colnames(res)[fx.col], -# ## background = DT::styleColorBar(c(0,3), 'lightblue'), -# background = color_from_middle(fx, "lightblue", "#f5aeae"), -# backgroundSize = "98% 88%", -# backgroundRepeat = "no-repeat", -# backgroundPosition = "center" -# ) -# }) %>% -# bindCache(filteredDiffExprTable(), input$gx_showqvalues) - -# genetable_text <- "Table I shows the results of the statistical tests. To increase the statistical reliability of the Omics Playground, we perform the DE analysis using four commonly accepted methods in the literature, namely, T-test (standard, Welch), limma (no trend, trend, voom), edgeR (QLF, LRT), and DESeq2 (Wald, LRT), and merge the results. -#

For a selected comparison under the Contrast setting, the results of the selected methods are combined and reported under the table, where meta.q for a gene represents the highest q value among the methods and the number of stars for a gene indicate how many methods identified significant q values (q < 0.05). The table is interactive (scrollable, clickable); users can sort genes by logFC, meta.q, or average expression in either conditions. Users can filter top N = {10} differently expressed genes in the table by clicking the top 10 genes from the table Settings." - - - - # genetable <- shiny::callModule( - # tableModule, - # id = "genetable", - # func = genetable.RENDER, - # info.text = genetable_text, - # label = "I", info.width = "500px", - # options = genetable_opts, - # server = TRUE, - # title = "Differential expression analysis", - # height = c(tabH - 10, 700) - # ) - ## output$genetable <- genetable_module$render - - #end genetable table refactoring ######### - - # #gsettable refactoring ######## - # - # ## NEED RETHINK: reacts too often - # gx_related_genesets <- shiny::reactive({ - # - # ngs <- inputData() - # res <- filteredDiffExprTable() - # if (is.null(res) || nrow(res) == 0) { - # return(NULL) - # } - # contr <- input$gx_contrast - # if (is.null(contr)) { - # return(NULL) - # } - # ## get table - # sel.row <- 1 - # ## sel.row = input$genetable_rows_selected - # sel.row <- genetable$rows_selected() - # if (is.null(sel.row)) { - # return(NULL) - # } - # 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)) - # if (length(gset) == 0) { - # return(NULL) - # } - # - # fx <- ngs$gset.meta$meta[[contr]]$meta.fx - # names(fx) <- rownames(ngs$gset.meta$meta[[contr]]) - # fx <- round(fx[gset], digits = 4) - # - # rho <- cor(t(ngs$gsetX[gset, ]), ngs$X[gene0, ])[, 1] - # rho <- round(rho, digits = 3) - # gset1 <- substring(gset, 1, 60) - # - # df <- data.frame(geneset = gset1, rho = rho, fx = fx, check.names = FALSE) - # rownames(df) <- gset - # df <- df[order(-abs(df$fx)), ] - # - # return(df) - # }) - # - # gsettable.RENDER <- shiny::reactive({ - # df <- gx_related_genesets() - # if (is.null(df)) { - # return(NULL) - # } - # - # df$geneset <- wrapHyperLink(df$geneset, rownames(df)) - # - # DT::datatable(df, - # ## class = 'compact cell-border stripe', - # class = "compact", - # rownames = FALSE, escape = c(-1, -2), - # extensions = c("Scroller"), - # fillContainer = TRUE, - # options = list( - # ## dom = 'lfrtip', - # dom = "frtip", - # paging = TRUE, - # pageLength = 16, ## lengthMenu = c(20, 30, 40, 60, 100, 250), - # scrollX = TRUE, - # ## scrollY = tabV, - # scrollY = FALSE, - # scroller = FALSE, - # deferRender = TRUE, - # search = list( - # regex = TRUE, - # caseInsensitive = TRUE - # ## search = 'GOBP:' - # ) - # ), ## end of options.list - # selection = list(mode = "single", target = "row", selected = NULL) - # ) %>% - # ## formatSignif(1:ncol(df),4) %>% - # DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") %>% - # DT::formatStyle("fx", background = color_from_middle(df$fx, "lightblue", "#f5aeae")) - # # }, server=FALSE) - # }) - # - # gsettable_text <- "By clicking on a gene in the Table I, it is possible to see which genesets contain that gene in this table, and check the differential expression status in other comparisons from the Gene in contrasts plot under the Plots tab." - # - # gsettable <- shiny::callModule( - # tableModule, - # id = "gsettable", - # func = gsettable.RENDER, - # info.text = gsettable_text, label = "II", - # title = "Gene sets with gene", - # height = c(tabH - 10, 700), width = c("100%", 800) - # ) - - #end gsettable refactoring ######## - - #fctable table refactoring ###### - - # fctable.RENDER <- shiny::reactive({ - # ngs <- inputData() - # res <- filteredDiffExprTable() - # 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 <- metaFC() - # Q <- metaQ() - # - # fc.rms <- sqrt(F[, 1]**2) - # if (NCOL(F) > 1) { - # fc.rms <- round(sqrt(rowMeans(F**2)), digits = 4) - # } - # - # show.q <- TRUE - # show.q <- input$fctable_showq - # df <- NULL - # if (show.q) { - # F1 <- do.call(cbind, lapply(1:ncol(F), function(i) cbind(F[, i], Q[, i]))) - # colnames(F1) <- as.vector(rbind(paste0("FC.", colnames(F)), paste0("q.", colnames(Q)))) - # ## colnames(F1) <- sub("q.*","q",colnames(F1)) - # df <- data.frame(gene = rownames(F), rms.FC = fc.rms, F1, check.names = FALSE) - # } else { - # F1 <- F - # colnames(F1) <- paste0("FC.", colnames(F)) - # df <- data.frame(gene = rownames(F), rms.FC = fc.rms, F1, check.names = FALSE) - # } - # - # df <- df[intersect(rownames(df), rownames(res)), ] ## take intersection of current comparison - # df <- df[order(-df$rms.FC), ] - # colnames(df) <- gsub("_", " ", colnames(df)) ## so it allows wrap line - # colnames(F1) <- gsub("_", " ", colnames(F1)) ## so it allows wrap line - # qv.cols <- grep("^q", colnames(F1)) - # fc.cols <- setdiff(which(colnames(df) %in% colnames(F1)), qv.cols) - # ## if(length(qv.cols)==0) qv = 0 - # - # dt <- DT::datatable(df, - # rownames = FALSE, - # # class = 'compact cell-border stripe hover', - # class = "compact hover", - # extensions = c("Scroller"), - # selection = list(mode = "single", target = "row", selected = c(1)), - # fillContainer = TRUE, - # options = list( - # dom = "lfrtip", - # ## pageLength = 20,## lengthMenu = c(20, 30, 40, 60, 100, 250), - # scrollX = TRUE, - # scrollY = tabV, - # scroller = TRUE, deferRender = TRUE - # ) ## end of options.list - # ) %>% - # DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") %>% - # DT::formatSignif(columns = fc.cols, digits = 3) %>% - # DT::formatStyle("rms.FC", - # ## background = DT::styleColorBar(c(0,3), 'lightblue'), - # background = color_from_middle(fc.rms, "lightblue", "#f5aeae"), - # backgroundSize = "98% 88%", backgroundRepeat = "no-repeat", - # backgroundPosition = "center" - # ) %>% - # DT::formatStyle(fc.cols, - # ## background = DT::styleColorBar(c(0,3), 'lightblue'), - # background = color_from_middle(F, "lightblue", "#f5aeae"), - # backgroundSize = "98% 88%", backgroundRepeat = "no-repeat", - # backgroundPosition = "center" - # ) - # - # if (length(qv.cols) > 0) { - # dt <- dt %>% - # DT::formatSignif(columns = qv.cols, digits = 3) - # } - # - # dt - # }) - # - # fctable_text <- "The Foldchange (all) tab reports the gene fold changes for all contrasts in the selected dataset." - # - # fctable_caption <- "Differential expression (fold-change) across all contrasts. The column `rms.FC` corresponds to the root-mean-square fold-change across all contrasts." - # - # fctable_opts <- shiny::tagList( - # withTooltip(shiny::checkboxInput(ns("fctable_showq"), "show q-values", TRUE), - # "Show q-values next to FC values.", - # placement = "right", options = list(container = "body") - # ) - # ) - # - # shiny::callModule( - # tableModule, - # id = "fctable", - # func = fctable.RENDER, - # title = "Gene fold changes for all contrasts", - # info.text = fctable_text, - # options = fctable_opts, - # caption = fctable_caption, - # height = c(tabH, 700) - # ) - - #end fctable table refactoring ####### - - #FDRtable table code ######### - - # FDRtable.RENDER <- shiny::reactive({ - # - # methods <- GX.DEFAULTTEST - # methods <- input$gx_statmethod - # ## methods = input$gx_statmethod - # if (is.null(methods)) { - # return(NULL) - # } - # - # ## comp <- input$gx_contrast - # ngs <- inputData() - # - # 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 - # 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)) { - # rownames(counts.up[[i]]) <- paste0(names(counts.up)[i], "::", rownames(counts.up[[i]])) - # rownames(counts.down[[i]]) <- paste0(names(counts.down)[i], "::", rownames(counts.down[[i]])) - # } - # sig.up <- do.call(rbind, counts.up) - # sig.down <- do.call(rbind, counts.down) - # - # sig.up <- sig.up[order(rownames(sig.up)), , drop = FALSE] - # sig.down <- sig.down[order(rownames(sig.down)), , drop = FALSE] - # colnames(sig.up)[1] <- paste("UP FDR = ", colnames(sig.up)[1]) - # colnames(sig.down)[1] <- paste("DOWN FDR = ", colnames(sig.down)[1]) - # colnames(sig.down) <- paste0(" ", colnames(sig.down)) - # sigcount <- cbind(sig.down, sig.up[rownames(sig.down), , drop = FALSE]) - # dim(sigcount) - # maxsig <- 0.99 * max(sigcount, na.rm = TRUE) - # - # contr <- sub("::.*", "", rownames(sigcount)) - # ## contr = rownames(sigcount) - # metd <- sub(".*::", "", rownames(sigcount)) - # D <- data.frame(method = metd, contrast = contr, sigcount, check.names = FALSE) - # - # DT::datatable(D, - # rownames = FALSE, - # # class = 'compact cell-border stripe hover', - # class = "compact hover", - # fillContainer = TRUE, - # extensions = c("Scroller"), - # options = list( - # dom = "lfrtip", - # pageLength = 999, ## lengthMenu = c(20, 30, 40, 60, 100, 250), - # scrollX = TRUE, - # scrollY = tabV, - # scroller = TRUE, deferRender = TRUE - # ) ## end of options.list - # ) %>% - # DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") %>% - # DT::formatStyle(colnames(sig.up), - # background = DT::styleColorBar(c(0, maxsig), "#f5aeae"), - # backgroundSize = "98% 88%", - # backgroundRepeat = "no-repeat", - # backgroundPosition = "center" - # ) %>% - # DT::formatStyle(colnames(sig.down), - # background = DT::styleColorBar(c(0, maxsig), "lightblue"), - # backgroundSize = "98% 88%", - # backgroundRepeat = "no-repeat", - # backgroundPosition = "center" - # ) - # }) - # - # FDRtable_text <- "The FDR table tab reports the number of significant genes at different FDR thresholds for all contrasts within the dataset." - # - # FDRtable_caption <- "Number of significant genes versus FDR. This table reports the number of significant genes at different FDR thresholds for all contrasts and methods. This enables to quickly see which methods are more sensitive. The left part of the table (in blue) correspond to the number of significant down-regulated genes, the right part (in red) correspond to the number of significant overexpressed genes." - # - # shiny::callModule( - # tableModule, - # id = "FDRtable", - # func = FDRtable.RENDER, - # info.text = FDRtable_text, - # title = "Number of significant genes", - # caption = FDRtable_caption, - # height = c(tabH, 700) - # ) - - #end FDRtable table code ######### - - # reactive values to return to parent environment ######### metaQ <- shiny::reactive({ From 924f5838096b4f30a881d1c125bc9c64e3adf3b0 Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Mon, 30 Jan 2023 12:19:35 +0100 Subject: [PATCH 26/32] cleaning code --- components/board.expression/R/expression_plot_boxplot.R | 5 ----- 1 file changed, 5 deletions(-) diff --git a/components/board.expression/R/expression_plot_boxplot.R b/components/board.expression/R/expression_plot_boxplot.R index 57f7a8631..4e5bce06a 100644 --- a/components/board.expression/R/expression_plot_boxplot.R +++ b/components/board.expression/R/expression_plot_boxplot.R @@ -18,9 +18,6 @@ expression_plot_boxplot_ui <- function(id, height, width){ ns <- shiny::NS(id) - # options <- tagList( - # actionButton(ns("button1"), "some action") - # ) plots_boxplot_opts = shiny::tagList( withTooltip( shiny::checkboxInput(ns('boxplot_grouped'),'grouped',TRUE), @@ -50,8 +47,6 @@ expression_plot_boxplot_ui <- function(id, #' #' @param id #' @param comp -#' @param grouped -#' @param logscale #' @param ngs #' @param sel #' @param res From 25c3e179335d942724c054a69155dca9a13fd4dc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Mon, 30 Jan 2023 21:45:23 +0100 Subject: [PATCH 27/32] Small changes to make `Plot` panel and tables work --- .../R/expression_plot_boxplot.R | 24 ++++++++--------- .../R/expression_plot_topfoldchange.R | 26 ++++++++++--------- .../board.expression/R/expression_server.R | 2 ++ .../R/expression_table_FDRtable.R | 2 +- .../R/expression_table_fctable.R | 3 ++- .../R/expression_table_genetable.R | 19 +++++++------- .../R/expression_table_gsettable.R | 8 +++--- components/board.expression/R/expression_ui.R | 9 ++++--- 8 files changed, 50 insertions(+), 43 deletions(-) diff --git a/components/board.expression/R/expression_plot_boxplot.R b/components/board.expression/R/expression_plot_boxplot.R index 4e5bce06a..c09670828 100644 --- a/components/board.expression/R/expression_plot_boxplot.R +++ b/components/board.expression/R/expression_plot_boxplot.R @@ -65,7 +65,6 @@ expression_plot_boxplot_server <- function(id, # #calculate required inputs for plotting --------------------------------- plot_data <- shiny::reactive({ - comp <- comp() #input$gx_contrast grouped <- input$boxplot_grouped logscale <- input$boxplot_logscale @@ -73,18 +72,6 @@ expression_plot_boxplot_server <- function(id, sel <- sel() res <- res() - - if (is.null(sel) || length(sel) == 0) { - frame() - text(0.5, 0.5, "No gene selected", col = "black") - return(NULL) - } - - - if (is.null(res) || is.null(sel)) { - return(NULL) - } - psel <- rownames(res)[sel] gene <- ngs$genes[1, "gene_name"] @@ -95,6 +82,7 @@ expression_plot_boxplot_server <- function(id, ngs = ngs, gene = gene, comp = comp, + sel = sel, grouped = grouped, logscale = logscale, srt = srt) @@ -105,6 +93,16 @@ expression_plot_boxplot_server <- function(id, pd <- plot_data() shiny::req(pd) + if (is.null(pd[["sel"]]) || length(pd[["sel"]]) == 0) { + frame() + text(0.5, 0.5, "No gene selected", col = "black") + return(NULL) + } + + if (is.null(res) || is.null(sel)) { + return(NULL) + } + par(mfrow = c(1, 1), mar = c(4, 3, 1.5, 1.5), mgp = c(2, 0.8, 0), oma = c(1, 0.5, 0, 0.5)) pgx.plotExpression(pd[["ngs"]], pd[["gene"]], diff --git a/components/board.expression/R/expression_plot_topfoldchange.R b/components/board.expression/R/expression_plot_topfoldchange.R index e13b428e0..3132547ca 100644 --- a/components/board.expression/R/expression_plot_topfoldchange.R +++ b/components/board.expression/R/expression_plot_topfoldchange.R @@ -61,20 +61,12 @@ expression_plot_topfoldchange_server <- function(id, sel <- sel() res <- res() - if (is.null(sel) || length(sel) == 0) { - frame() - text(0.5, 0.5, "No gene selected", col = "black") - return(NULL) - } - - - if (is.null(res) || is.null(sel)) { - return(NULL) - } psel <- rownames(res)[sel] gene <- ngs$genes[psel, "gene_name"] - ## fc <- res$meta.fx + if (is.null(sel) || length(sel) == 0) { # Ugly + return(list(sel = sel)) + } if (is.null(comp) || length(comp) == 0) { return(NULL) @@ -88,10 +80,10 @@ expression_plot_topfoldchange_server <- function(id, fc.top <- head(c(fc.top, rep(NA, 99)), 15) klr.pal <- RColorBrewer::brewer.pal(4, "Paired")[2:1] - ## klr.pal <- BLUERED(16)[c(3,14)] klr <- klr.pal[1 + 1 * (sign(fc.top) < 0)] return(list( + sel = sel, fc.top = fc.top, klr = klr, gene = gene @@ -102,6 +94,16 @@ expression_plot_topfoldchange_server <- function(id, pd <- plot_data() shiny::req(pd) + if (is.null(pd[["sel"]]) || length(pd[["sel"]]) == 0) { + frame() + text(0.5, 0.5, "No gene selected", col = "black") + return(NULL) + } + + if (is.null(res) || is.null(sel)) { + return(NULL) + } + par(mfrow = c(1, 1), mar = c(4, 4, 2, 2) * 1, mgp = c(2, 0.8, 0), oma = c(1, 1, 1, 0.5) * 0.2) par(mfrow = c(1, 1), mar = c(6, 3, 0, 1), mgp = c(2, 0.8, 0), oma = c(1, 0, 0, 0)) nch <- max(nchar(names(pd[["fc.top"]]))) diff --git a/components/board.expression/R/expression_server.R b/components/board.expression/R/expression_server.R index bca77174d..42922226d 100644 --- a/components/board.expression/R/expression_server.R +++ b/components/board.expression/R/expression_server.R @@ -232,6 +232,7 @@ ExpressionBoard <- function(id, inputData) { ngs <- inputData() ## if(is.null(ngs)) return(NULL) shiny::req(ngs, input$gx_features, input$gx_fdr, input$gx_lfc) + # browser() comp <- 1 test <- "trend.limma" @@ -476,6 +477,7 @@ ExpressionBoard <- function(id, inputData) { metaFC = metaFC, metaQ = metaQ, height = c(tabH, 700), + tabV = tabV, watermark=FALSE) expression_table_FDRtable_server(id = "FDRtable", diff --git a/components/board.expression/R/expression_table_FDRtable.R b/components/board.expression/R/expression_table_FDRtable.R index c8a994c48..702bc3362 100644 --- a/components/board.expression/R/expression_table_FDRtable.R +++ b/components/board.expression/R/expression_table_FDRtable.R @@ -15,7 +15,7 @@ expression_table_FDRtable_ui <- function(id) { ns <- shiny::NS(id) - tableWidget(ns("table")) + tableWidget(ns("FDRtable")) } diff --git a/components/board.expression/R/expression_table_fctable.R b/components/board.expression/R/expression_table_fctable.R index 72e9e9d57..2db19dc86 100644 --- a/components/board.expression/R/expression_table_fctable.R +++ b/components/board.expression/R/expression_table_fctable.R @@ -15,7 +15,7 @@ expression_table_fctable_ui <- function(id) { ns <- shiny::NS(id) - tableWidget(ns("table")) + tableWidget(ns("fctable")) } @@ -31,6 +31,7 @@ expression_table_fctable_server <- function(id, metaFC, metaQ, height, + tabV, watermark=FALSE){ moduleServer( id, function(input, output, session) { diff --git a/components/board.expression/R/expression_table_genetable.R b/components/board.expression/R/expression_table_genetable.R index 7cf434148..c5cd775dd 100644 --- a/components/board.expression/R/expression_table_genetable.R +++ b/components/board.expression/R/expression_table_genetable.R @@ -13,13 +13,13 @@ #' @export expression_table_genetable_ui <- function(id) { - message("expression_table_genetable_ui called") + # message("expression_table_genetable_ui called") ns <- shiny::NS(id) - tableWidget(ns("table")) + tableWidget(ns("genetable")) - message("expression_table_genetable_ui done") + # message("expression_table_genetable_ui done") } @@ -108,8 +108,8 @@ expression_table_genetable_server <- function(id, backgroundRepeat = "no-repeat", backgroundPosition = "center" ) - }) %>% - bindCache(filteredDiffExprTable(), input$gx_showqvalues) + })# %>% + # bindCache(filteredDiffExprTable(), input$gx_showqvalues) genetable_text = "Table I shows the results of the statistical tests. To increase the statistical reliability of the Omics Playground, we perform the DE analysis using four commonly accepted methods in the literature, namely, T-test (standard, Welch), limma (no trend, trend, voom), edgeR (QLF, LRT), and DESeq2 (Wald, LRT), and merge the results.

For a selected comparison under the Contrast setting, the results of the selected methods are combined and reported under the table, where meta.q for a gene represents the highest q value among the methods and the number of stars for a gene indicate how many methods identified significant q values (q < 0.05). The table is interactive (scrollable, clickable); users can sort genes by logFC, meta.q, or average expression in either conditions. Users can filter top N = {10} differently expressed genes in the table by clicking the top 10 genes from the table Settings." @@ -118,13 +118,14 @@ expression_table_genetable_server <- function(id, genetable <- shiny::callModule( tableModule, - id = "table", + id = "genetable", func = table.RENDER, info.text = genetable_text, - label = "I", info.width = "500px", + info.width = "500px", options = genetable_opts, - server = TRUE, - title = "Differential expression analysis" + title = tags$div( + HTML('(I)Differential expression analysis') + ) ) message("expression_table_genetable_server done") diff --git a/components/board.expression/R/expression_table_gsettable.R b/components/board.expression/R/expression_table_gsettable.R index ac38e7db2..3f6acecd3 100644 --- a/components/board.expression/R/expression_table_gsettable.R +++ b/components/board.expression/R/expression_table_gsettable.R @@ -15,7 +15,7 @@ expression_table_gsettable_ui <- function(id) { ns <- shiny::NS(id) - tableWidget(ns("table")) + tableWidget(ns("gsettable")) } @@ -78,8 +78,10 @@ expression_table_gsettable_server <- function(id, tableModule, id = "gsettable", func = gsettable.RENDER, - info.text = gsettable_text, label = "II", - title = "Gene sets with gene", + info.text = gsettable_text, + title = tags$div( + HTML('(II)Gene sets with gene') + ), height = height, width = width ) return(gsettable) diff --git a/components/board.expression/R/expression_ui.R b/components/board.expression/R/expression_ui.R index a77454a4c..84054496f 100644 --- a/components/board.expression/R/expression_ui.R +++ b/components/board.expression/R/expression_ui.R @@ -85,7 +85,7 @@ ExpressionUI <- function(id) { div( class = "col-md-3", expression_plot_volcano_ui(ns("plots_volcano"), - label = "A", + label = "a", height = c(imgH, imgH), width = c("auto", imgH) ), @@ -94,7 +94,7 @@ ExpressionUI <- function(id) { class = "col-md-3", expression_plot_maplot_ui( id = ns("plots_maplot"), - label = "B", + label = "b", height = c(imgH, imgH), width = c("auto", imgH) ), @@ -103,7 +103,7 @@ ExpressionUI <- function(id) { class = "col-md-3", expression_plot_boxplot_ui( id = ns("plots_boxplot"), - label = "C", + label = "c", height = c(imgH, imgH), width = c("auto", imgH) ), @@ -112,13 +112,14 @@ ExpressionUI <- function(id) { class = "col-md-3", expression_plot_topfoldchange_ui( id = ns("plots_topfoldchange"), - label = "D", + label = "d", height = c(imgH, imgH), width = c("auto", imgH) ), ) ), tags$div( + class = "caption", HTML("Expression plots associated with the selected contrast. (a) Volcano-plot plotting fold-change versuson significance the x and y axes, respectively. (b) MA-plot plotting signal intensity versus fold-change on the x and y axes, respectively. (c) Sorted barplot of the top diffentially expressed genes with largest (absolute) fold-change From fb66b52de301bc20e481cfde1095d47192894bf2 Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Tue, 31 Jan 2023 09:43:32 +0100 Subject: [PATCH 28/32] add caption attributes to div --- components/board.expression/R/expression_ui.R | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/components/board.expression/R/expression_ui.R b/components/board.expression/R/expression_ui.R index 84054496f..bed0fce5f 100644 --- a/components/board.expression/R/expression_ui.R +++ b/components/board.expression/R/expression_ui.R @@ -137,6 +137,7 @@ ExpressionUI <- function(id) { shiny::br(), tags$div( + class = "caption", HTML("Top differentially expressed genes. Expression barplots of the top most differentially (both positively and negatively) expressed genes for the selected contrast.") ) @@ -149,6 +150,7 @@ ExpressionUI <- function(id) { width = c("auto", 1600)), shiny::br(), tags$div( + class = "caption", HTML("Volcano plot for all contrasts. Simultaneous visualisation of volcano plots of genes for all contrasts. Experimental contrasts with better statistical significance will show volcano plots with 'higher' wings.") @@ -162,6 +164,7 @@ ExpressionUI <- function(id) { width = c("auto", 1600)), shiny::br(), tags$div( + class = "caption", HTML("Volcano plot for all statistical methods. Simultaneous visualisation of volcano plots of genes by multiple differential expression methods for the selected contrast. Methods showing better statistical significance will show volcano plots with 'higher' wings.") @@ -176,6 +179,7 @@ ExpressionUI <- function(id) { shiny::tabPanel( "Table", tags$div( + class = "caption", HTML("Differential Expression Analysis. Compare expression between two conditions. Determine which genes are significantly downregulated or overexpressed in one of the groups.") ), From 70270d9c4d87abd1e32cf177f2b886e46dcc6e5e Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Tue, 31 Jan 2023 09:43:52 +0100 Subject: [PATCH 29/32] fix FDRtable --- components/board.expression/R/expression_server.R | 3 ++- .../board.expression/R/expression_table_FDRtable.R | 9 +++++---- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/components/board.expression/R/expression_server.R b/components/board.expression/R/expression_server.R index 42922226d..a6d0bd360 100644 --- a/components/board.expression/R/expression_server.R +++ b/components/board.expression/R/expression_server.R @@ -482,7 +482,8 @@ ExpressionBoard <- function(id, inputData) { expression_table_FDRtable_server(id = "FDRtable", ngs = inputData, - GX.DEFAULTTEST = GX.DEFAULTTEST, + methods = shiny::reactive(input$gx_statmethod), + tabV = tabV, height = c(tabH, 700), watermark=FALSE) diff --git a/components/board.expression/R/expression_table_FDRtable.R b/components/board.expression/R/expression_table_FDRtable.R index 702bc3362..e2fefcf28 100644 --- a/components/board.expression/R/expression_table_FDRtable.R +++ b/components/board.expression/R/expression_table_FDRtable.R @@ -27,7 +27,8 @@ expression_table_FDRtable_ui <- function(id) { #' @export expression_table_FDRtable_server <- function(id, ngs, - GX.DEFAULTTEST, + methods, #input$gx_statmethod + tabV, height, #c(tabH, 700) watermark=FALSE){ moduleServer( id, function(input, output, session) { @@ -36,9 +37,9 @@ expression_table_FDRtable_server <- function(id, FDRtable.RENDER <- shiny::reactive({ - methods <- GX.DEFAULTTEST - methods <- input$gx_statmethod - ## methods = input$gx_statmethod + #methods <- GX.DEFAULTTEST + methods <- methods() #input$gx_statmethod + if (is.null(methods)) { return(NULL) } From 5c8d24c2e2fe989a1a7fbc9482a91a13d3af99ed Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Tue, 31 Jan 2023 14:04:50 +0100 Subject: [PATCH 30/32] fixed zoom and standardized plot labels, fixed plotlibs --- .../R/expression_plot_boxplot.R | 24 +++++++++---------- .../R/expression_plot_topfoldchange.R | 24 +++++++++---------- .../R/expression_plot_topgenes.R | 4 ++-- .../R/expression_plot_volcanoAll.R | 24 +++++++++---------- .../R/expression_plot_volcanoMethods.R | 24 +++++++++---------- components/board.expression/R/expression_ui.R | 6 ++--- 6 files changed, 53 insertions(+), 53 deletions(-) diff --git a/components/board.expression/R/expression_plot_boxplot.R b/components/board.expression/R/expression_plot_boxplot.R index c09670828..db2e7b133 100644 --- a/components/board.expression/R/expression_plot_boxplot.R +++ b/components/board.expression/R/expression_plot_boxplot.R @@ -115,23 +115,23 @@ expression_plot_boxplot_server <- function(id, ) } - modal_plotly.RENDER <- function() { - fig <- plotly.RENDER() %>% - plotly::layout( - font = list(size = 18), - legend = list( - font = list(size = 18) - ) - ) - fig <- plotly::style(fig, marker.size = 20) - fig - } + # modal_plotly.RENDER <- function() { + # fig <- plotly.RENDER() %>% + # plotly::layout( + # font = list(size = 18), + # legend = list( + # font = list(size = 18) + # ) + # ) + # fig <- plotly::style(fig, marker.size = 20) + # fig + # } PlotModuleServer( "pltmod", plotlib = "base", func = plotly.RENDER, - func2 = modal_plotly.RENDER, + #func2 = modal_plotly.RENDER, csvFunc = plot_data, ## *** downloadable data as CSV res = c(80, 95), ## resolution of plots pdf.width = 6, pdf.height = 6, diff --git a/components/board.expression/R/expression_plot_topfoldchange.R b/components/board.expression/R/expression_plot_topfoldchange.R index 3132547ca..89b1c5fe9 100644 --- a/components/board.expression/R/expression_plot_topfoldchange.R +++ b/components/board.expression/R/expression_plot_topfoldchange.R @@ -123,23 +123,23 @@ expression_plot_topfoldchange_server <- function(id, title(pd[["gene"]], cex.main = 1, line = -0.15) } - modal_plotly.RENDER <- function() { - fig <- plotly.RENDER() %>% - plotly::layout( - font = list(size = 18), - legend = list( - font = list(size = 18) - ) - ) - fig <- plotly::style(fig, marker.size = 20) - fig - } + # modal_plotly.RENDER <- function() { + # fig <- plotly.RENDER() %>% + # plotly::layout( + # font = list(size = 18), + # legend = list( + # font = list(size = 18) + # ) + # ) + # fig <- plotly::style(fig, marker.size = 20) + # fig + # } PlotModuleServer( "pltmod", plotlib = "base", func = plotly.RENDER, - func2 = modal_plotly.RENDER, + # func2 = modal_plotly.RENDER, csvFunc = plot_data, ## *** downloadable data as CSV res = c(80, 95), ## resolution of plots pdf.width = 6, pdf.height = 6, diff --git a/components/board.expression/R/expression_plot_topgenes.R b/components/board.expression/R/expression_plot_topgenes.R index 5a0d7d76b..8021b43e5 100644 --- a/components/board.expression/R/expression_plot_topgenes.R +++ b/components/board.expression/R/expression_plot_topgenes.R @@ -39,7 +39,7 @@ expression_plot_topgenes_ui <- function(id, PlotModuleUI(ns("pltmod"), title = "Expression of top differentially expressed genes", label = label, - plotlib = "base", + plotlib = "ggplot", info.text = info_text, options = topgenes_opts, download.fmt = c("png", "pdf", "csv"), @@ -173,7 +173,7 @@ expression_plot_topgenes_server <- function(id, PlotModuleServer( "pltmod", - plotlib = "base", + plotlib = "ggplot", func = plotly.RENDER, # func2 = modal_plotly.RENDER, csvFunc = plot_data, ## *** downloadable data as CSV diff --git a/components/board.expression/R/expression_plot_volcanoAll.R b/components/board.expression/R/expression_plot_volcanoAll.R index 033621ad2..e27bd1140 100644 --- a/components/board.expression/R/expression_plot_volcanoAll.R +++ b/components/board.expression/R/expression_plot_volcanoAll.R @@ -23,7 +23,7 @@ expression_plot_volcanoAll_ui <- function(id, PlotModuleUI(ns("pltmod"), title = "Volcano plots for all contrasts", label = label, - plotlib = "ggplot", + plotlib = "grid", info.text = info_text, options = NULL, download.fmt=c("png","pdf","csv"), @@ -164,22 +164,22 @@ expression_plot_volcanoAll_server <- function(id, gridExtra::grid.arrange(grobs = plt, nrow = nr, ncol = nc) } - modal_plot.RENDER <- function() { - plot.RENDER() %>% - plotly::layout( - ## showlegend = TRUE, - font = list( - size = 16 - ) - ) - } + # modal_plot.RENDER <- function() { + # plot.RENDER() %>% + # plotly::layout( + # ## showlegend = TRUE, + # font = list( + # size = 16 + # ) + # ) + # } PlotModuleServer( "pltmod", - plotlib = "ggplot", + plotlib = "grid", func = plot.RENDER, - func2 = modal_plot.RENDER, + # func2 = modal_plot.RENDER, csvFunc = plot_data, ## *** downloadable data as CSV res = c(70, 90), ## resolution of plots pdf.width = 6, pdf.height = 6, diff --git a/components/board.expression/R/expression_plot_volcanoMethods.R b/components/board.expression/R/expression_plot_volcanoMethods.R index 120dc511c..c69595bd7 100644 --- a/components/board.expression/R/expression_plot_volcanoMethods.R +++ b/components/board.expression/R/expression_plot_volcanoMethods.R @@ -24,7 +24,7 @@ expression_plot_volcanoMethods_ui <- function(id, PlotModuleUI(ns("pltmod"), title = "Volcano plots for all methods", label = label, - plotlib = "plotly", + plotlib = "ggplot", info.text = info_text, options = NULL, download.fmt=c("png","pdf","csv"), @@ -150,22 +150,22 @@ expression_plot_volcanoMethods_server <- function(id, - modal_plot.RENDER <- function() { - plot.RENDER() %>% - plotly::layout( - ## showlegend = TRUE, - font = list( - size = 16 - ) - ) - } + # modal_plot.RENDER <- function() { + # plot.RENDER() %>% + # plotly::layout( + # ## showlegend = TRUE, + # font = list( + # size = 16 + # ) + # ) + # } PlotModuleServer( "pltmod", - plotlib = "plotly", + plotlib = "ggplot", func = plot.RENDER, - func2 = modal_plot.RENDER, + # func2 = modal_plot.RENDER, csvFunc = plot_data, ## *** downloadable data as CSV res = c(80,170), ## resolution of plots pdf.width = 6, pdf.height = 6, diff --git a/components/board.expression/R/expression_ui.R b/components/board.expression/R/expression_ui.R index bed0fce5f..6f809909d 100644 --- a/components/board.expression/R/expression_ui.R +++ b/components/board.expression/R/expression_ui.R @@ -130,7 +130,7 @@ ExpressionUI <- function(id) { "Top genes", expression_plot_topgenes_ui( id = ns("topgenes"), - label = "A", + label = "a", height = c(imgH,420), width = c('auto',1600) ), @@ -145,7 +145,7 @@ ExpressionUI <- function(id) { shiny::tabPanel( "Volcano (all)", expression_plot_volcanoAll_ui(ns("volcanoAll"), - label='A', + label='a', height = c(imgH, 500), width = c("auto", 1600)), shiny::br(), @@ -159,7 +159,7 @@ ExpressionUI <- function(id) { shiny::tabPanel( "Volcano (methods)", expression_plot_volcanoMethods_ui(id = ns("volcanoMethods"), - label ='A', + label ='a', height = c(imgH, 450), width = c("auto", 1600)), shiny::br(), From 3b89b06a9034d401229e8e39488787d52eb80ee9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Tue, 31 Jan 2023 23:10:12 +0100 Subject: [PATCH 31/32] fix: solved `plot_topgenes` bug --- .../board.expression/R/expression_plot_topgenes.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/components/board.expression/R/expression_plot_topgenes.R b/components/board.expression/R/expression_plot_topgenes.R index 8021b43e5..ee10dbceb 100644 --- a/components/board.expression/R/expression_plot_topgenes.R +++ b/components/board.expression/R/expression_plot_topgenes.R @@ -39,7 +39,6 @@ expression_plot_topgenes_ui <- function(id, PlotModuleUI(ns("pltmod"), title = "Expression of top differentially expressed genes", label = label, - plotlib = "ggplot", info.text = info_text, options = topgenes_opts, download.fmt = c("png", "pdf", "csv"), @@ -127,6 +126,7 @@ expression_plot_topgenes_server <- function(id, plotly.RENDER <- function() { + pd <- plot_data() shiny::req(pd) @@ -141,17 +141,18 @@ expression_plot_topgenes_server <- function(id, gene <- rownames(pd[["res"]])[i] pgx.plotExpression( pd[["ngs"]], - pd[["gene"]], + # pd[["gene"]], + gene, pd[["comp"]], pd[["grouped"]], max.points = 200, logscale = pd[["logscale"]], collapse.others = TRUE, showothers = pd[["showothers"]], - ylab=ylab, + ylab=pd[["ylab"]], xlab="", srt=pd[["srt"]], - names = show.names, + names = pd[["show.names"]], main = "" ) title(gene, cex.main = 1, line = -0.6) @@ -173,7 +174,6 @@ expression_plot_topgenes_server <- function(id, PlotModuleServer( "pltmod", - plotlib = "ggplot", func = plotly.RENDER, # func2 = modal_plotly.RENDER, csvFunc = plot_data, ## *** downloadable data as CSV From b08b08f0ca59904fc64fd3c31870ba65c886762c Mon Sep 17 00:00:00 2001 From: ncullen93 Date: Wed, 1 Feb 2023 18:49:35 +0100 Subject: [PATCH 32/32] styling changes --- .../R/expression_plot_boxplot.R | 39 +-- .../R/expression_plot_maplot.R | 11 - .../R/expression_plot_topfoldchange.R | 16 +- .../R/expression_plot_topgenes.R | 21 +- .../R/expression_plot_volcano.R | 30 +- .../R/expression_plot_volcanoAll.R | 294 +++++++++--------- .../R/expression_plot_volcanoMethods.R | 272 ++++++++-------- .../board.expression/R/expression_server.R | 112 +++---- .../R/expression_table_FDRtable.R | 90 +++--- .../R/expression_table_fctable.R | 206 ++++++------ .../R/expression_table_genetable.R | 75 +++-- .../R/expression_table_gsettable.R | 55 ++-- components/board.expression/R/expression_ui.R | 32 +- 13 files changed, 595 insertions(+), 658 deletions(-) diff --git a/components/board.expression/R/expression_plot_boxplot.R b/components/board.expression/R/expression_plot_boxplot.R index db2e7b133..f31ace8e4 100644 --- a/components/board.expression/R/expression_plot_boxplot.R +++ b/components/board.expression/R/expression_plot_boxplot.R @@ -16,16 +16,19 @@ expression_plot_boxplot_ui <- function(id, label = "", height, - width){ + width) { ns <- shiny::NS(id) - plots_boxplot_opts = shiny::tagList( - withTooltip( shiny::checkboxInput(ns('boxplot_grouped'),'grouped',TRUE), - "Group expression values by conditions.", - placement="right", options = list(container = "body")), - withTooltip( shiny::checkboxInput(ns('boxplot_logscale'),'log scale',TRUE), - "Show logarithmic (log2CPM) expression values.", - placement="right", options = list(container = "body"))) + plots_boxplot_opts <- shiny::tagList( + withTooltip(shiny::checkboxInput(ns("boxplot_grouped"), "grouped", TRUE), + "Group expression values by conditions.", + placement = "right", options = list(container = "body") + ), + withTooltip(shiny::checkboxInput(ns("boxplot_logscale"), "log scale", TRUE), + "Show logarithmic (log2CPM) expression values.", + placement = "right", options = list(container = "body") + ) + ) info_text <- "The top N = {12} differentially (both positively and negatively) expressed gene barplot for the selected comparison under the Contrast settings." @@ -65,7 +68,7 @@ expression_plot_boxplot_server <- function(id, # #calculate required inputs for plotting --------------------------------- plot_data <- shiny::reactive({ - comp <- comp() #input$gx_contrast + comp <- comp() # input$gx_contrast grouped <- input$boxplot_grouped logscale <- input$boxplot_logscale ngs <- ngs() @@ -85,8 +88,8 @@ expression_plot_boxplot_server <- function(id, sel = sel, grouped = grouped, logscale = logscale, - srt = srt) - ) + srt = srt + )) }) plotly.RENDER <- function() { @@ -115,23 +118,11 @@ expression_plot_boxplot_server <- function(id, ) } - # modal_plotly.RENDER <- function() { - # fig <- plotly.RENDER() %>% - # plotly::layout( - # font = list(size = 18), - # legend = list( - # font = list(size = 18) - # ) - # ) - # fig <- plotly::style(fig, marker.size = 20) - # fig - # } - PlotModuleServer( "pltmod", plotlib = "base", func = plotly.RENDER, - #func2 = modal_plotly.RENDER, + # func2 = modal_plotly.RENDER, csvFunc = plot_data, ## *** downloadable data as CSV res = c(80, 95), ## resolution of plots pdf.width = 6, pdf.height = 6, diff --git a/components/board.expression/R/expression_plot_maplot.R b/components/board.expression/R/expression_plot_maplot.R index 9542c6fa8..6f404bb6e 100644 --- a/components/board.expression/R/expression_plot_maplot.R +++ b/components/board.expression/R/expression_plot_maplot.R @@ -87,15 +87,11 @@ expression_plot_maplot_server <- function(id, return(NULL) } fc.genes <- as.character(res[, grep("^gene$|gene_name", colnames(res))]) - ## pval = res$P.Value - ## pval = res[,grep("P.Value|meta.p|pval|p.val",colnames(res))[1]] ## filter genes by gene family or gene set fam.genes <- unique(unlist(ngs$families[10])) - ## fam.genes = unique(unlist(ngs$families[input$gx_features])) fam.genes <- res$gene_name if (gx_features() != "") { - ## gset <- GSETS[input$gx_features] gset <- getGSETS(gx_features()) fam.genes <- unique(unlist(gset)) } @@ -121,10 +117,8 @@ expression_plot_maplot_server <- function(id, sel.genes <- intersect(sig.genes, sel.genes) ## are there any genes/genesets selected? - # sel1 = genetable$rows_selected() sel1 <- sel1() df1 <- df1() - # sel2 = gsettable$rows_selected() sel2 <- sel2() df2 <- df2() lab.cex <- 1 @@ -168,9 +162,6 @@ expression_plot_maplot_server <- function(id, head(sel.genes[order(-impt(sel.genes))], 10) ) - - - return(list( x = x, y = y, @@ -200,8 +191,6 @@ expression_plot_maplot_server <- function(id, highlight = pd[["sel.genes"]], label = pd[["lab.genes"]], label.cex = pd[["lab.cex"]], group.names = c("group1", "group0"), - ## xlim=xlim, ylim=ylim, ## hi.col="#222222", - ## use.fdr=TRUE, psig = pd[["fdr"]], lfc = pd[["lfc"]], xlab = "average expression (log2.CPM)", ylab = "effect size (log2.FC)", diff --git a/components/board.expression/R/expression_plot_topfoldchange.R b/components/board.expression/R/expression_plot_topfoldchange.R index 89b1c5fe9..a9ff53473 100644 --- a/components/board.expression/R/expression_plot_topfoldchange.R +++ b/components/board.expression/R/expression_plot_topfoldchange.R @@ -55,8 +55,7 @@ expression_plot_topfoldchange_server <- function(id, # #calculate required inputs for plotting --------------------------------- plot_data <- shiny::reactive({ - - comp <- comp() #input$gx_contrast + comp <- comp() # input$gx_contrast ngs <- ngs() sel <- sel() res <- res() @@ -110,7 +109,6 @@ expression_plot_topfoldchange_server <- function(id, m1 <- ifelse(nch > 12, 12, 8) m1 <- ifelse(nch > 30, 16, m1) - ## par( mar=c(4,m1,2,0.5) ) par(mar = c(3.2, m1 - 0.5, 1, 1)) cex1 <- 0.9 nn <- sum(!is.na(pd[["fc.top"]])) @@ -123,18 +121,6 @@ expression_plot_topfoldchange_server <- function(id, title(pd[["gene"]], cex.main = 1, line = -0.15) } - # modal_plotly.RENDER <- function() { - # fig <- plotly.RENDER() %>% - # plotly::layout( - # font = list(size = 18), - # legend = list( - # font = list(size = 18) - # ) - # ) - # fig <- plotly::style(fig, marker.size = 20) - # fig - # } - PlotModuleServer( "pltmod", plotlib = "base", diff --git a/components/board.expression/R/expression_plot_topgenes.R b/components/board.expression/R/expression_plot_topgenes.R index ee10dbceb..ccda2338f 100644 --- a/components/board.expression/R/expression_plot_topgenes.R +++ b/components/board.expression/R/expression_plot_topgenes.R @@ -16,7 +16,7 @@ expression_plot_topgenes_ui <- function(id, label = "", height, - width){ + width) { ns <- shiny::NS(id) info_text <- "The Top genes section shows the average expression plots across the samples for the top differentially (both positively and negatively) expressed genes for the selected comparison from the Contrast settings. Under the plot Settings, users can scale the abundance levels (counts) or ungroup the samples in the plot from the log scale and ungroup samples settings, respectively." @@ -71,7 +71,7 @@ expression_plot_topgenes_server <- function(id, # #calculate required inputs for plotting --------------------------------- plot_data <- shiny::reactive({ - comp <- comp() #input$gx_contrast + comp <- comp() # input$gx_contrast ngs <- inputData() shiny::req(ngs) @@ -81,7 +81,6 @@ expression_plot_topgenes_server <- function(id, } ## filter on active rows (using search) - ## ii <- genetable$rows_all() ii <- ii() res <- res[ii, , drop = FALSE] if (nrow(res) == 0) { @@ -100,7 +99,6 @@ expression_plot_topgenes_server <- function(id, ny <- nrow(ngs$samples) ## ???!! show.names <- ifelse(!grouped & ny > 25, FALSE, TRUE) - ## nx = ifelse(grouped, ngrp, length(y)) nx <- ifelse(grouped, 3, ny) nc <- 4 nc <- 8 @@ -126,12 +124,11 @@ expression_plot_topgenes_server <- function(id, plotly.RENDER <- function() { - pd <- plot_data() shiny::req(pd) nc <- 8 - mar1 = 3.5 + mar1 <- 3.5 par(mfrow = c(2, nc), mar = c(mar1, 3.5, 1, 1), mgp = c(2, 0.8, 0), oma = c(0.1, 0.6, 0, 0.6)) i <- 1 @@ -149,9 +146,9 @@ expression_plot_topgenes_server <- function(id, logscale = pd[["logscale"]], collapse.others = TRUE, showothers = pd[["showothers"]], - ylab=pd[["ylab"]], - xlab="", - srt=pd[["srt"]], + ylab = pd[["ylab"]], + xlab = "", + srt = pd[["srt"]], names = pd[["show.names"]], main = "" ) @@ -177,9 +174,9 @@ expression_plot_topgenes_server <- function(id, func = plotly.RENDER, # func2 = modal_plotly.RENDER, csvFunc = plot_data, ## *** downloadable data as CSV - res = c(90,105), ## resolution of plots - pdf.width=14, pdf.height=3.5, + res = c(90, 105), ## resolution of plots + pdf.width = 14, pdf.height = 3.5, add.watermark = watermark ) }) ## end of moduleServer -} \ No newline at end of file +} diff --git a/components/board.expression/R/expression_plot_volcano.R b/components/board.expression/R/expression_plot_volcano.R index 79a8a0b7b..032040c07 100644 --- a/components/board.expression/R/expression_plot_volcano.R +++ b/components/board.expression/R/expression_plot_volcano.R @@ -67,28 +67,22 @@ expression_plot_volcano_server <- function(id, df2, watermark = FALSE) { moduleServer(id, function(input, output, session) { - # reactive function listening for changes in input plot_data <- shiny::reactive({ # calculate required inputs for plotting - comp1 = comp1() - fdr = as.numeric(fdr()) - lfc = as.numeric(lfc()) - features = features() - res = res() - sel1= sel1() - df1 = df1() - sel2 = sel2() - df2 = df2() - - # comp1 <- input$gx_contrast() - # fdr <- as.numeric(input$gx_fdr()) - # res = fullDiffExprTable() - # lfc <- as.numeric(input$gx_lfc()) + comp1 <- comp1() + fdr <- as.numeric(fdr()) + lfc <- as.numeric(lfc()) + features <- features() + res <- res() + sel1 <- sel1() + df1 <- df1() + sel2 <- sel2() + df2 <- df2() + fam.genes <- res$gene_name - ## fam.genes = unique(unlist(gx$families[features])) if (is.null(res)) { return(NULL) @@ -100,7 +94,6 @@ expression_plot_volcano_server <- function(id, return(NULL) } if (features != "") { - ## gset <- GSETS[features] gset <- getGSETS(features) fam.genes <- unique(unlist(gset)) } @@ -136,7 +129,6 @@ expression_plot_volcano_server <- function(id, lab.cex <- 1.3 } else if (gene.selected && gset.selected) { gs <- rownames(df2)[sel2] - ## gset <- GSETS[[gs]] gset <- unlist(getGSETS(gs)) sel.genes <- intersect(sel.genes, gset) lab.genes <- c( @@ -154,8 +146,6 @@ expression_plot_volcano_server <- function(id, xlim <- c(-1, 1) * max(abs(x), na.rm = TRUE) ylim <- c(0, max(12, 1.1 * max(-log10(qval), na.rm = TRUE))) - ## par(mfrow=c(1,1), mar=c(4,3,1,1.5), mgp=c(2,0.8,0), oma=c(0,0,0,0)) - return(list( x = x, y = y, diff --git a/components/board.expression/R/expression_plot_volcanoAll.R b/components/board.expression/R/expression_plot_volcanoAll.R index e27bd1140..247e22679 100644 --- a/components/board.expression/R/expression_plot_volcanoAll.R +++ b/components/board.expression/R/expression_plot_volcanoAll.R @@ -13,22 +13,23 @@ #' #' @export expression_plot_volcanoAll_ui <- function(id, - label='', + label = "", height, width) { ns <- shiny::NS(id) - info_text = "Under the Volcano (all) tab, the platform simultaneously displays multiple volcano plots for genes across all contrasts. This provides users an overview of the statistics for all comparisons. By comparing multiple volcano plots, the user can immediately see which comparison is statistically weak or strong." + info_text <- "Under the Volcano (all) tab, the platform simultaneously displays multiple volcano plots for genes across all contrasts. This provides users an overview of the statistics for all comparisons. By comparing multiple volcano plots, the user can immediately see which comparison is statistically weak or strong." PlotModuleUI(ns("pltmod"), - title = "Volcano plots for all contrasts", - label = label, - plotlib = "grid", - info.text = info_text, - options = NULL, - download.fmt=c("png","pdf","csv"), - height = height, - width = width) + title = "Volcano plots for all contrasts", + label = label, + plotlib = "grid", + info.text = info_text, + options = NULL, + download.fmt = c("png", "pdf", "csv"), + height = height, + width = width + ) } #' Expression plot Server function @@ -45,145 +46,140 @@ expression_plot_volcanoAll_server <- function(id, features, fdr, lfc, - watermark = FALSE){ - 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)) { - return(NULL) - } - ct <- getAllContrasts() - F <- ct$F - Q <- ct$Q - - ## comp = names(ngs$gx.meta$meta) - comp <- names(F) - if (length(comp) == 0) { - return(NULL) - } - if (is.null(features)) { - return(NULL) - } - - fdr <- 1 - lfc <- 0 - fdr <- as.numeric(fdr()) - lfc <- as.numeric(lfc()) - - sel.genes <- rownames(ngs$X) - if (features != "") { - gset <- getGSETS(features) - sel.genes <- unique(unlist(gset)) - } - - - return(list( - comp = comp, - fdr = fdr, - lfc = lfc, - sel.genes = sel.genes, - F = F, - Q =Q) + watermark = FALSE) { + 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)) { + return(NULL) + } + ct <- getAllContrasts() + F <- ct$F + Q <- ct$Q + + ## comp = names(ngs$gx.meta$meta) + comp <- names(F) + if (length(comp) == 0) { + return(NULL) + } + if (is.null(features)) { + return(NULL) + } + + fdr <- 1 + lfc <- 0 + fdr <- as.numeric(fdr()) + lfc <- as.numeric(lfc()) + + sel.genes <- rownames(ngs$X) + if (features != "") { + gset <- getGSETS(features) + sel.genes <- unique(unlist(gset)) + } + + + return(list( + comp = comp, + fdr = fdr, + lfc = lfc, + sel.genes = sel.genes, + F = F, + Q = Q + )) + }) + + plot.RENDER <- function() { + pd <- plot_data() + shiny::req(pd) + + shiny::withProgress(message = "rendering volcano plots ...", value = 0, { + ## plot layout ##### + ng <- length(pd[["comp"]]) + nn <- c(2, max(ceiling(ng / 2), 5)) + ## if(ng>12) nn = c(3,8) + par(mfrow = nn, mar = c(1, 1, 1, 1) * 0.2, mgp = c(2.6, 1, 0), oma = c(1, 1, 0, 0) * 2) + nr <- 2 + nc <- ceiling(sqrt(ng)) + if (ng > 24) { + nc <- max(ceiling(ng / 3), 6) + nr <- 3 + } else if (TRUE && ng <= 4) { + nc <- 4 + nr <- 1 + } else { + nc <- max(ceiling(ng / 2), 6) + nr <- 2 + } + nr + nc + par(mfrow = c(nr, nc)) + + ymax <- 15 + nlq <- -log10(1e-99 + unlist(pd[["Q"]])) + ymax <- max(1.3, 1.2 * quantile(nlq, probs = 0.999, na.rm = TRUE)[1]) ## y-axis + xmax <- max(1, 1.2 * quantile(abs(unlist(pd[["F"]])), probs = 0.999, na.rm = TRUE)[1]) ## x-axis + + + plt <- list() + i <- 1 + for (i in 1:length(pd[["comp"]])) { + qval <- pd[["Q"]][[i]] + fx <- pd[["F"]][[i]] + fc.gene <- names(qval) + is.sig <- (qval <= pd[["fdr"]] & abs(fx) >= pd[["lfc"]]) + sig.genes <- fc.gene[which(is.sig)] + genes1 <- sig.genes[which(toupper(sig.genes) %in% toupper(pd[["sel.genes"]]))] + genes2 <- head(genes1[order(-abs(fx[genes1]) * (-log10(qval[genes1])))], 10) + xy <- data.frame(x = fx, y = -log10(qval)) + is.sig2 <- factor(is.sig, levels = c(FALSE, TRUE)) + + plt[[i]] <- pgx.scatterPlotXY.GGPLOT( + xy, + title = pd[["comp"]][i], cex.title = 0.85, + var = is.sig2, type = "factor", + col = c("#bbbbbb", "#1e60bb"), + legend.pos = "none", ## plotlib="ggplot", + hilight = NULL, hilight2 = genes2, + xlim = xmax * c(-1, 1), ylim = c(0, ymax), + xlab = "difference (log2FC)", + ylab = "significance (-log10q)", + hilight.lwd = 0, hilight.col = "#1e60bb", hilight.cex = 1.5, + cex = 0.45, cex.lab = 0.62 ) + ## ggplot2::theme(legend.position='none') + ## ggplot2::theme_bw(base_size=11) - - }) - - plot.RENDER <- function() { - pd <- plot_data() - shiny::req(pd) - - shiny::withProgress(message = "rendering volcano plots ...", value = 0, { - ## plot layout ##### - ng <- length(pd[["comp"]]) - nn <- c(2, max(ceiling(ng / 2), 5)) - ## if(ng>12) nn = c(3,8) - par(mfrow = nn, mar = c(1, 1, 1, 1) * 0.2, mgp = c(2.6, 1, 0), oma = c(1, 1, 0, 0) * 2) - nr <- 2 - nc <- ceiling(sqrt(ng)) - if (ng > 24) { - nc <- max(ceiling(ng / 3), 6) - nr <- 3 - } else if (TRUE && ng <= 4) { - nc <- 4 - nr <- 1 - } else { - nc <- max(ceiling(ng / 2), 6) - nr <- 2 - } - nr - nc - par(mfrow = c(nr, nc)) - - ymax <- 15 - nlq <- -log10(1e-99 + unlist(pd[["Q"]])) - ymax <- max(1.3, 1.2 * quantile(nlq, probs = 0.999, na.rm = TRUE)[1]) ## y-axis - xmax <- max(1, 1.2 * quantile(abs(unlist(pd[["F"]])), probs = 0.999, na.rm = TRUE)[1]) ## x-axis - - - plt <- list() - i <- 1 - for (i in 1:length(pd[["comp"]])) { - qval <- pd[["Q"]][[i]] - fx <- pd[["F"]][[i]] - fc.gene <- names(qval) - is.sig <- (qval <= pd[["fdr"]] & abs(fx) >= pd[["lfc"]]) - sig.genes <- fc.gene[which(is.sig)] - genes1 <- sig.genes[which(toupper(sig.genes) %in% toupper(pd[["sel.genes"]]))] - genes2 <- head(genes1[order(-abs(fx[genes1]) * (-log10(qval[genes1])))], 10) - xy <- data.frame(x = fx, y = -log10(qval)) - is.sig2 <- factor(is.sig, levels = c(FALSE, TRUE)) - - plt[[i]] <- pgx.scatterPlotXY.GGPLOT( - xy, - title = pd[["comp"]][i], cex.title = 0.85, - var = is.sig2, type = "factor", - col = c("#bbbbbb", "#1e60bb"), - legend.pos = "none", ## plotlib="ggplot", - hilight = NULL, hilight2 = genes2, - xlim = xmax * c(-1, 1), ylim = c(0, ymax), - xlab = "difference (log2FC)", - ylab = "significance (-log10q)", - hilight.lwd = 0, hilight.col = "#1e60bb", hilight.cex = 1.5, - cex = 0.45, cex.lab = 0.62 - ) - ## ggplot2::theme(legend.position='none') - ## ggplot2::theme_bw(base_size=11) - - if (!interactive()) shiny::incProgress(1 / length(comp)) - } - }) ## progress - - gridExtra::grid.arrange(grobs = plt, nrow = nr, ncol = nc) + if (!interactive()) shiny::incProgress(1 / length(comp)) } - - # modal_plot.RENDER <- function() { - # plot.RENDER() %>% - # plotly::layout( - # ## showlegend = TRUE, - # font = list( - # size = 16 - # ) - # ) - # } - - - PlotModuleServer( - "pltmod", - plotlib = "grid", - func = plot.RENDER, - # func2 = modal_plot.RENDER, - csvFunc = plot_data, ## *** downloadable data as CSV - res = c(70, 90), ## resolution of plots - pdf.width = 6, pdf.height = 6, - add.watermark = watermark - ) - })## end of moduleServer -} \ No newline at end of file + }) ## progress + + gridExtra::grid.arrange(grobs = plt, nrow = nr, ncol = nc) + } + + # modal_plot.RENDER <- function() { + # plot.RENDER() %>% + # plotly::layout( + # ## showlegend = TRUE, + # font = list( + # size = 16 + # ) + # ) + # } + + + PlotModuleServer( + "pltmod", + plotlib = "grid", + func = plot.RENDER, + # func2 = modal_plot.RENDER, + csvFunc = plot_data, ## *** downloadable data as CSV + res = c(70, 90), ## resolution of plots + pdf.width = 6, pdf.height = 6, + add.watermark = watermark + ) + }) ## end of moduleServer +} diff --git a/components/board.expression/R/expression_plot_volcanoMethods.R b/components/board.expression/R/expression_plot_volcanoMethods.R index c69595bd7..a18096cc1 100644 --- a/components/board.expression/R/expression_plot_volcanoMethods.R +++ b/components/board.expression/R/expression_plot_volcanoMethods.R @@ -14,22 +14,23 @@ #' #' @export expression_plot_volcanoMethods_ui <- function(id, - label='', + label = "", height, width) { ns <- shiny::NS(id) - info_text = "Under the Volcano (methods) tab, the platform displays the volcano plots provided by multiple differential expression calculation methods for the selected contrast. This provides users an overview of the statistics of all methods at the same time." + info_text <- "Under the Volcano (methods) tab, the platform displays the volcano plots provided by multiple differential expression calculation methods for the selected contrast. This provides users an overview of the statistics of all methods at the same time." PlotModuleUI(ns("pltmod"), - title = "Volcano plots for all methods", - label = label, - plotlib = "ggplot", - info.text = info_text, - options = NULL, - download.fmt=c("png","pdf","csv"), - height = height, - width = width) + title = "Volcano plots for all methods", + label = label, + plotlib = "ggplot", + info.text = info_text, + options = NULL, + download.fmt = c("png", "pdf", "csv"), + height = height, + width = width + ) } #' Expression plot Server function @@ -42,134 +43,129 @@ expression_plot_volcanoMethods_ui <- function(id, #' @export expression_plot_volcanoMethods_server <- function(id, inputData, - comp, #input$gx_contrast - features, #input$gx_features - fdr, #input$gx_fdr - lfc, #input$gx_lfc - watermark = FALSE) -{ + comp, # input$gx_contrast + features, # input$gx_features + fdr, # input$gx_fdr + lfc, # input$gx_lfc + watermark = FALSE) { moduleServer(id, function(input, output, session) { - - - #reactive function listening for changes in input - plot_data <- shiny::reactive({ - - comp <- comp() - features <- features() - - if (is.null(comp)) { - return(NULL) - } - ngs <- inputData() - shiny::req(ngs) - if (is.null(features)) { - return(NULL) - } - - comp <- names(ngs$gx.meta$meta)[1] - fdr <- as.numeric(fdr()) #fdr <- 1 - lfc <- as.numeric(lfc()) #lfc <- 1 - genes <- NULL - - gset <- getGSETS(features) - sel.genes <- unique(unlist(gset)) - - return( - list( - ngs = ngs, - fdr = fdr, - lfc = lfc, - comp = comp, - sel.genes = sel.genes - )) - - }) - - plot.RENDER <- function(){ - pd <- plot_data() - shiny::req(pd) - - ## meta tables - mx <- pd[["ngs"]]$gx.meta$meta[[pd[["comp"]]]] - fc <- unclass(mx$fc) - ## pv = unclass(mx$p) - qv <- unclass(mx$q) - nlq <- -log10(1e-99 + qv) - 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"] - nplots <- min(24, ncol(qv)) - - ## methods = names(ngs$gx.meta$output) - methods <- colnames(pd[["ngs"]]$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) { - nplots <- min(nplots, 24) - par(mfrow = c(3, 8), mar = c(4, 4, 2, 2) * 0) - nc <- 8 - } - - shiny::withProgress(message = "computing volcano plots ...", value = 0, { - i <- 1 - for (i in 1:nplots) { - fx <- fc[, i] - ## pval = pv[,i] - qval <- qv[, i] - sig.genes <- fc.genes[which(qval <= pd[["fdr"]] & abs(fx) >= pd[["lfc"]])] - ## genes1 = intersect(sig.genes, sel.genes) - genes1 <- sig.genes[which(toupper(sig.genes) %in% toupper(pd[["sel.genes"]]))] - gx.volcanoPlot.XY( - x = fx, pv = qval, gene = fc.genes, - render = "canvas", n = 5000, nlab = 5, - xlim = xlim, ylim = c(0, ymax), axes = FALSE, - use.fdr = TRUE, p.sig = pd[["fdr"]], lfc = pd[["lfc"]], - ## main=comp[i], - ## ma.plot=TRUE, use.rpkm=TRUE, - cex = 0.6, lab.cex = 1.5, highlight = genes1 - ) - - is.first <- (i %% nc == 1) - last.row <- ((i - 1) %/% nc == (nplots - 1) %/% nc) - is.first - last.row - if (is.first) axis(2, mgp = c(2, 0.7, 0), cex.axis = 0.8) - if (last.row) axis(1, mgp = c(2, 0.7, 0), cex.axis = 0.8) - graphics::box(lwd = 1, col = "black", lty = "solid") - legend("top", - legend = colnames(fc)[i], cex = 1.2, - bg = "white", box.lty = 0, inset = c(0, 0.01), - x.intersp = 0.1, y.intersp = 0.1 - ) - shiny::incProgress(1 / length(nplots)) - } - - }) - } - - - - # modal_plot.RENDER <- function() { - # plot.RENDER() %>% - # plotly::layout( - # ## showlegend = TRUE, - # font = list( - # size = 16 - # ) - # ) - # } - - - PlotModuleServer( - "pltmod", - plotlib = "ggplot", - func = plot.RENDER, - # func2 = modal_plot.RENDER, - csvFunc = plot_data, ## *** downloadable data as CSV - res = c(80,170), ## resolution of plots - pdf.width = 6, pdf.height = 6, - add.watermark = watermark + # reactive function listening for changes in input + plot_data <- shiny::reactive({ + comp <- comp() + features <- features() + + if (is.null(comp)) { + return(NULL) + } + ngs <- inputData() + shiny::req(ngs) + if (is.null(features)) { + return(NULL) + } + + comp <- names(ngs$gx.meta$meta)[1] + fdr <- as.numeric(fdr()) # fdr <- 1 + lfc <- as.numeric(lfc()) # lfc <- 1 + genes <- NULL + + gset <- getGSETS(features) + sel.genes <- unique(unlist(gset)) + + return( + list( + ngs = ngs, + fdr = fdr, + lfc = lfc, + comp = comp, + sel.genes = sel.genes ) - })## end of moduleServer + ) + }) + + plot.RENDER <- function() { + pd <- plot_data() + shiny::req(pd) + + ## meta tables + mx <- pd[["ngs"]]$gx.meta$meta[[pd[["comp"]]]] + fc <- unclass(mx$fc) + ## pv = unclass(mx$p) + qv <- unclass(mx$q) + nlq <- -log10(1e-99 + qv) + 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"] + nplots <- min(24, ncol(qv)) + + ## methods = names(ngs$gx.meta$output) + methods <- colnames(pd[["ngs"]]$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) { + nplots <- min(nplots, 24) + par(mfrow = c(3, 8), mar = c(4, 4, 2, 2) * 0) + nc <- 8 + } + + shiny::withProgress(message = "computing volcano plots ...", value = 0, { + i <- 1 + for (i in 1:nplots) { + fx <- fc[, i] + ## pval = pv[,i] + qval <- qv[, i] + sig.genes <- fc.genes[which(qval <= pd[["fdr"]] & abs(fx) >= pd[["lfc"]])] + ## genes1 = intersect(sig.genes, sel.genes) + genes1 <- sig.genes[which(toupper(sig.genes) %in% toupper(pd[["sel.genes"]]))] + gx.volcanoPlot.XY( + x = fx, pv = qval, gene = fc.genes, + render = "canvas", n = 5000, nlab = 5, + xlim = xlim, ylim = c(0, ymax), axes = FALSE, + use.fdr = TRUE, p.sig = pd[["fdr"]], lfc = pd[["lfc"]], + ## main=comp[i], + ## ma.plot=TRUE, use.rpkm=TRUE, + cex = 0.6, lab.cex = 1.5, highlight = genes1 + ) + + is.first <- (i %% nc == 1) + last.row <- ((i - 1) %/% nc == (nplots - 1) %/% nc) + is.first + last.row + if (is.first) axis(2, mgp = c(2, 0.7, 0), cex.axis = 0.8) + if (last.row) axis(1, mgp = c(2, 0.7, 0), cex.axis = 0.8) + graphics::box(lwd = 1, col = "black", lty = "solid") + legend("top", + legend = colnames(fc)[i], cex = 1.2, + bg = "white", box.lty = 0, inset = c(0, 0.01), + x.intersp = 0.1, y.intersp = 0.1 + ) + shiny::incProgress(1 / length(nplots)) + } + }) + } + + + + # modal_plot.RENDER <- function() { + # plot.RENDER() %>% + # plotly::layout( + # ## showlegend = TRUE, + # font = list( + # size = 16 + # ) + # ) + # } + + + PlotModuleServer( + "pltmod", + plotlib = "ggplot", + func = plot.RENDER, + # func2 = modal_plot.RENDER, + csvFunc = plot_data, ## *** downloadable data as CSV + res = c(80, 170), ## resolution of plots + pdf.width = 6, pdf.height = 6, + add.watermark = watermark + ) + }) ## end of moduleServer } diff --git a/components/board.expression/R/expression_server.R b/components/board.expression/R/expression_server.R index a6d0bd360..1261f624c 100644 --- a/components/board.expression/R/expression_server.R +++ b/components/board.expression/R/expression_server.R @@ -107,8 +107,6 @@ ExpressionBoard <- function(id, inputData) { return(NULL) } - message("[getDEGtable] called") - ## build meta table mx <- ngs$gx.meta$meta[[comparison]] if (is.null(mx)) { @@ -159,8 +157,6 @@ ExpressionBoard <- function(id, inputData) { AveExpr1 <- mean0 + logFC / 2 AveExpr0 <- mean0 - logFC / 2 - message("[getDEGtable] creating results table") - ## 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] @@ -173,7 +169,6 @@ ExpressionBoard <- function(id, inputData) { rownames(res) <- rownames(mx) if (add.pq) { - message("[getDEGtable] adding PQ table") ## add extra columns ## res <- cbind( res, q=mx$q, p=mx$p) colnames(mx.q) <- paste0("q.", colnames(mx.q)) @@ -292,7 +287,7 @@ ExpressionBoard <- function(id, inputData) { expression_plot_volcano_server( id = "plots_volcano", comp1 = shiny::reactive(input$gx_contrast), - fdr= shiny::reactive(input$gx_fdr), + fdr = shiny::reactive(input$gx_fdr), lfc = shiny::reactive(input$gx_lfc), features = shiny::reactive(input$gx_features), res = fullDiffExprTable, @@ -387,39 +382,44 @@ ExpressionBoard <- function(id, inputData) { ct }) - expression_plot_topgenes_server(id = "topgenes", - comp = shiny::reactive(input$gx_contrast), - inputData = inputData, - res = filteredDiffExprTable, - ii = genetable$rows_current, - watermark = FALSE) + expression_plot_topgenes_server( + id = "topgenes", + comp = shiny::reactive(input$gx_contrast), + inputData = inputData, + res = filteredDiffExprTable, + ii = genetable$rows_current, + watermark = FALSE + ) # tab differential expression > Volcano All #### - expression_plot_volcanoAll_server(id = "volcanoAll", - inputData = inputData, - getAllContrasts = getAllContrasts, - features = shiny::reactive(input$gx_features), - fdr = shiny::reactive(input$gx_fdr), - lfc = shiny::reactive(input$gx_lfc), - watermark = FALSE) + expression_plot_volcanoAll_server( + id = "volcanoAll", + inputData = inputData, + getAllContrasts = getAllContrasts, + features = shiny::reactive(input$gx_features), + fdr = shiny::reactive(input$gx_fdr), + lfc = shiny::reactive(input$gx_lfc), + watermark = FALSE + ) # tab differential expression > Volcano Methods #### - expression_plot_volcanoMethods_server(id = "volcanoMethods", - inputData = inputData, - comp = shiny::reactive(input$gx_contrast), - features = shiny::reactive(input$gx_features), - fdr = shiny::reactive(input$gx_fdr), - lfc = shiny::reactive(input$gx_lfc), - watermark = FALSE) + expression_plot_volcanoMethods_server( + id = "volcanoMethods", + inputData = inputData, + comp = shiny::reactive(input$gx_contrast), + features = shiny::reactive(input$gx_features), + fdr = shiny::reactive(input$gx_fdr), + lfc = shiny::reactive(input$gx_lfc), + watermark = FALSE + ) # tab differential expression > Volcano Methods #### # rendering tables #### gx_related_genesets <- shiny::reactive({ - ngs <- inputData() res <- filteredDiffExprTable() if (is.null(res) || nrow(res) == 0) { @@ -461,31 +461,39 @@ ExpressionBoard <- function(id, inputData) { return(df) }) - genetable <- expression_table_genetable_server(id = "genetable", - res = filteredDiffExprTable, - height=c(tabH - 10, 700)) - - gsettable <- expression_table_gsettable_server(id = "gsettable", - gx_related_genesets = gx_related_genesets, - height = c(tabH - 10, 700), - width = c("100%", 800), - watermark=FALSE) - - expression_table_fctable_server(id = "fctable", - ngs = inputData, - res = filteredDiffExprTable, - metaFC = metaFC, - metaQ = metaQ, - height = c(tabH, 700), - tabV = tabV, - watermark=FALSE) - - expression_table_FDRtable_server(id = "FDRtable", - ngs = inputData, - methods = shiny::reactive(input$gx_statmethod), - tabV = tabV, - height = c(tabH, 700), - watermark=FALSE) + genetable <- expression_table_genetable_server( + id = "genetable", + res = filteredDiffExprTable, + height = c(tabH - 10, 700) + ) + + gsettable <- expression_table_gsettable_server( + id = "gsettable", + gx_related_genesets = gx_related_genesets, + height = c(tabH - 10, 700), + width = c("100%", 800), + watermark = FALSE + ) + + expression_table_fctable_server( + id = "fctable", + ngs = inputData, + res = filteredDiffExprTable, + metaFC = metaFC, + metaQ = metaQ, + height = c(tabH, 700), + tabV = tabV, + watermark = FALSE + ) + + expression_table_FDRtable_server( + id = "FDRtable", + ngs = inputData, + methods = shiny::reactive(input$gx_statmethod), + tabV = tabV, + height = c(tabH, 700), + watermark = FALSE + ) # reactive values to return to parent environment ######### diff --git a/components/board.expression/R/expression_table_FDRtable.R b/components/board.expression/R/expression_table_FDRtable.R index e2fefcf28..a498233c8 100644 --- a/components/board.expression/R/expression_table_FDRtable.R +++ b/components/board.expression/R/expression_table_FDRtable.R @@ -12,11 +12,9 @@ #' #' @export expression_table_FDRtable_ui <- function(id) { - ns <- shiny::NS(id) tableWidget(ns("FDRtable")) - } #' Server side table code: expression board @@ -27,18 +25,16 @@ expression_table_FDRtable_ui <- function(id) { #' @export expression_table_FDRtable_server <- function(id, ngs, - methods, #input$gx_statmethod + methods, # input$gx_statmethod tabV, - height, #c(tabH, 700) - watermark=FALSE){ - moduleServer( id, function(input, output, session) { - + height, # c(tabH, 700) + watermark = FALSE) { + moduleServer(id, function(input, output, session) { ns <- session$ns FDRtable.RENDER <- shiny::reactive({ - - #methods <- GX.DEFAULTTEST - methods <- methods() #input$gx_statmethod + # methods <- GX.DEFAULTTEST + methods <- methods() # input$gx_statmethod if (is.null(methods)) { return(NULL) @@ -75,46 +71,46 @@ expression_table_FDRtable_server <- function(id, D <- data.frame(method = metd, contrast = contr, sigcount, check.names = FALSE) DT::datatable(D, - rownames = FALSE, - # class = 'compact cell-border stripe hover', - class = "compact hover", - fillContainer = TRUE, - extensions = c("Scroller"), - options = list( - dom = "lfrtip", - pageLength = 999, ## lengthMenu = c(20, 30, 40, 60, 100, 250), - scrollX = TRUE, - scrollY = tabV, - scroller = TRUE, deferRender = TRUE - ) ## end of options.list + rownames = FALSE, + # class = 'compact cell-border stripe hover', + class = "compact hover", + fillContainer = TRUE, + extensions = c("Scroller"), + options = list( + dom = "lfrtip", + pageLength = 999, ## lengthMenu = c(20, 30, 40, 60, 100, 250), + scrollX = TRUE, + scrollY = tabV, + scroller = TRUE, deferRender = TRUE + ) ## end of options.list ) %>% DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") %>% DT::formatStyle(colnames(sig.up), - background = DT::styleColorBar(c(0, maxsig), "#f5aeae"), - backgroundSize = "98% 88%", - backgroundRepeat = "no-repeat", - backgroundPosition = "center" + background = DT::styleColorBar(c(0, maxsig), "#f5aeae"), + backgroundSize = "98% 88%", + backgroundRepeat = "no-repeat", + backgroundPosition = "center" ) %>% DT::formatStyle(colnames(sig.down), - background = DT::styleColorBar(c(0, maxsig), "lightblue"), - backgroundSize = "98% 88%", - backgroundRepeat = "no-repeat", - backgroundPosition = "center" + background = DT::styleColorBar(c(0, maxsig), "lightblue"), + backgroundSize = "98% 88%", + backgroundRepeat = "no-repeat", + backgroundPosition = "center" ) - }) - - FDRtable_text <- "The FDR table tab reports the number of significant genes at different FDR thresholds for all contrasts within the dataset." - - FDRtable_caption <- "Number of significant genes versus FDR. This table reports the number of significant genes at different FDR thresholds for all contrasts and methods. This enables to quickly see which methods are more sensitive. The left part of the table (in blue) correspond to the number of significant down-regulated genes, the right part (in red) correspond to the number of significant overexpressed genes." - - shiny::callModule( - tableModule, - id = "FDRtable", - func = FDRtable.RENDER, - info.text = FDRtable_text, - title = "Number of significant genes", - caption = FDRtable_caption, - height = height - ) - })#end module server -}#end server \ No newline at end of file + }) + + FDRtable_text <- "The FDR table tab reports the number of significant genes at different FDR thresholds for all contrasts within the dataset." + + FDRtable_caption <- "Number of significant genes versus FDR. This table reports the number of significant genes at different FDR thresholds for all contrasts and methods. This enables to quickly see which methods are more sensitive. The left part of the table (in blue) correspond to the number of significant down-regulated genes, the right part (in red) correspond to the number of significant overexpressed genes." + + shiny::callModule( + tableModule, + id = "FDRtable", + func = FDRtable.RENDER, + info.text = FDRtable_text, + title = "Number of significant genes", + caption = FDRtable_caption, + height = height + ) + }) # end module server +} # end server diff --git a/components/board.expression/R/expression_table_fctable.R b/components/board.expression/R/expression_table_fctable.R index 2db19dc86..79bc9617e 100644 --- a/components/board.expression/R/expression_table_fctable.R +++ b/components/board.expression/R/expression_table_fctable.R @@ -12,11 +12,9 @@ #' #' @export expression_table_fctable_ui <- function(id) { - ns <- shiny::NS(id) tableWidget(ns("fctable")) - } #' Server side table code: expression board @@ -26,119 +24,117 @@ expression_table_fctable_ui <- function(id) { #' #' @export expression_table_fctable_server <- function(id, - ngs, #inputData() - res, #filteredDiffExprTable + ngs, # inputData() + res, # filteredDiffExprTable metaFC, metaQ, height, tabV, - watermark=FALSE){ - moduleServer( id, function(input, output, session) { - + watermark = FALSE) { + moduleServer(id, function(input, output, session) { ns <- session$ns message("expression_table_fctable_server called") 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 <- metaFC() - Q <- metaQ() - - fc.rms <- sqrt(F[, 1]**2) - if (NCOL(F) > 1) { - fc.rms <- round(sqrt(rowMeans(F**2)), digits = 4) - } - - show.q <- TRUE - show.q <- input$fctable_showq - df <- NULL - if (show.q) { - F1 <- do.call(cbind, lapply(1:ncol(F), function(i) cbind(F[, i], Q[, i]))) - colnames(F1) <- as.vector(rbind(paste0("FC.", colnames(F)), paste0("q.", colnames(Q)))) - ## colnames(F1) <- sub("q.*","q",colnames(F1)) - df <- data.frame(gene = rownames(F), rms.FC = fc.rms, F1, check.names = FALSE) - } else { - F1 <- F - colnames(F1) <- paste0("FC.", colnames(F)) - df <- data.frame(gene = rownames(F), rms.FC = fc.rms, F1, check.names = FALSE) - } - - df <- df[intersect(rownames(df), rownames(res)), ] ## take intersection of current comparison - df <- df[order(-df$rms.FC), ] - colnames(df) <- gsub("_", " ", colnames(df)) ## so it allows wrap line - colnames(F1) <- gsub("_", " ", colnames(F1)) ## so it allows wrap line - qv.cols <- grep("^q", colnames(F1)) - fc.cols <- setdiff(which(colnames(df) %in% colnames(F1)), qv.cols) - ## if(length(qv.cols)==0) qv = 0 - - dt <- DT::datatable(df, - rownames = FALSE, - # class = 'compact cell-border stripe hover', - class = "compact hover", - extensions = c("Scroller"), - selection = list(mode = "single", target = "row", selected = c(1)), - fillContainer = TRUE, - options = list( - dom = "lfrtip", - ## pageLength = 20,## lengthMenu = c(20, 30, 40, 60, 100, 250), - scrollX = TRUE, - scrollY = tabV, - scroller = TRUE, deferRender = TRUE - ) ## end of options.list - ) %>% - DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") %>% - DT::formatSignif(columns = fc.cols, digits = 3) %>% - DT::formatStyle("rms.FC", - ## background = DT::styleColorBar(c(0,3), 'lightblue'), - background = color_from_middle(fc.rms, "lightblue", "#f5aeae"), - backgroundSize = "98% 88%", backgroundRepeat = "no-repeat", - backgroundPosition = "center" + 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 <- metaFC() + Q <- metaQ() + + fc.rms <- sqrt(F[, 1]**2) + if (NCOL(F) > 1) { + fc.rms <- round(sqrt(rowMeans(F**2)), digits = 4) + } + + show.q <- TRUE + show.q <- input$fctable_showq + df <- NULL + if (show.q) { + F1 <- do.call(cbind, lapply(1:ncol(F), function(i) cbind(F[, i], Q[, i]))) + colnames(F1) <- as.vector(rbind(paste0("FC.", colnames(F)), paste0("q.", colnames(Q)))) + ## colnames(F1) <- sub("q.*","q",colnames(F1)) + df <- data.frame(gene = rownames(F), rms.FC = fc.rms, F1, check.names = FALSE) + } else { + F1 <- F + colnames(F1) <- paste0("FC.", colnames(F)) + df <- data.frame(gene = rownames(F), rms.FC = fc.rms, F1, check.names = FALSE) + } + + df <- df[intersect(rownames(df), rownames(res)), ] ## take intersection of current comparison + df <- df[order(-df$rms.FC), ] + colnames(df) <- gsub("_", " ", colnames(df)) ## so it allows wrap line + colnames(F1) <- gsub("_", " ", colnames(F1)) ## so it allows wrap line + qv.cols <- grep("^q", colnames(F1)) + fc.cols <- setdiff(which(colnames(df) %in% colnames(F1)), qv.cols) + ## if(length(qv.cols)==0) qv = 0 + + dt <- DT::datatable(df, + rownames = FALSE, + # class = 'compact cell-border stripe hover', + class = "compact hover", + extensions = c("Scroller"), + selection = list(mode = "single", target = "row", selected = c(1)), + fillContainer = TRUE, + options = list( + dom = "lfrtip", + ## pageLength = 20,## lengthMenu = c(20, 30, 40, 60, 100, 250), + scrollX = TRUE, + scrollY = tabV, + scroller = TRUE, deferRender = TRUE + ) ## end of options.list ) %>% - DT::formatStyle(fc.cols, - ## background = DT::styleColorBar(c(0,3), 'lightblue'), - background = color_from_middle(F, "lightblue", "#f5aeae"), - backgroundSize = "98% 88%", backgroundRepeat = "no-repeat", - backgroundPosition = "center" + DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") %>% + DT::formatSignif(columns = fc.cols, digits = 3) %>% + DT::formatStyle("rms.FC", + ## background = DT::styleColorBar(c(0,3), 'lightblue'), + background = color_from_middle(fc.rms, "lightblue", "#f5aeae"), + backgroundSize = "98% 88%", backgroundRepeat = "no-repeat", + backgroundPosition = "center" + ) %>% + DT::formatStyle(fc.cols, + ## background = DT::styleColorBar(c(0,3), 'lightblue'), + background = color_from_middle(F, "lightblue", "#f5aeae"), + backgroundSize = "98% 88%", backgroundRepeat = "no-repeat", + backgroundPosition = "center" + ) + + if (length(qv.cols) > 0) { + dt <- dt %>% + DT::formatSignif(columns = qv.cols, digits = 3) + } + + dt + }) + + fctable_text <- "The Foldchange (all) tab reports the gene fold changes for all contrasts in the selected dataset." + + fctable_caption <- "Differential expression (fold-change) across all contrasts. The column `rms.FC` corresponds to the root-mean-square fold-change across all contrasts." + + fctable_opts <- shiny::tagList( + withTooltip(shiny::checkboxInput(ns("fctable_showq"), "show q-values", TRUE), + "Show q-values next to FC values.", + placement = "right", options = list(container = "body") ) + ) - if (length(qv.cols) > 0) { - dt <- dt %>% - DT::formatSignif(columns = qv.cols, digits = 3) - } - - dt - }) - - fctable_text <- "The Foldchange (all) tab reports the gene fold changes for all contrasts in the selected dataset." - - fctable_caption <- "Differential expression (fold-change) across all contrasts. The column `rms.FC` corresponds to the root-mean-square fold-change across all contrasts." - - fctable_opts <- shiny::tagList( - withTooltip(shiny::checkboxInput(ns("fctable_showq"), "show q-values", TRUE), - "Show q-values next to FC values.", - placement = "right", options = list(container = "body") + shiny::callModule( + tableModule, + id = "fctable", + func = fctable.RENDER, + title = "Gene fold changes for all contrasts", + info.text = fctable_text, + options = fctable_opts, + caption = fctable_caption, + height = height ) - ) - - shiny::callModule( - tableModule, - id = "fctable", - func = fctable.RENDER, - title = "Gene fold changes for all contrasts", - info.text = fctable_text, - options = fctable_opts, - caption = fctable_caption, - height = height - ) - - })#end module server -}#end server \ No newline at end of file + }) # end module server +} # end server diff --git a/components/board.expression/R/expression_table_genetable.R b/components/board.expression/R/expression_table_genetable.R index c5cd775dd..2bbdf394f 100644 --- a/components/board.expression/R/expression_table_genetable.R +++ b/components/board.expression/R/expression_table_genetable.R @@ -12,7 +12,6 @@ #' #' @export expression_table_genetable_ui <- function(id) { - # message("expression_table_genetable_ui called") ns <- shiny::NS(id) @@ -20,7 +19,6 @@ expression_table_genetable_ui <- function(id) { tableWidget(ns("genetable")) # message("expression_table_genetable_ui done") - } #' Server side table code: expression board @@ -30,28 +28,26 @@ expression_table_genetable_ui <- function(id) { #' #' @export expression_table_genetable_server <- function(id, - res, #filteredDiffExprTable + res, # filteredDiffExprTable height, - watermark=FALSE){ + watermark = FALSE) { moduleServer(id, function(input, output, session) { - message("expression_table_genetable_server called") ns <- session$ns genetable_opts <- shiny::tagList( withTooltip(shiny::checkboxInput(ns("gx_top10"), "top 10 up/down genes", FALSE), - "Display only top 10 differentially (positively and negatively) expressed genes in the table.", - placement = "top", options = list(container = "body") + "Display only top 10 differentially (positively and negatively) expressed genes in the table.", + placement = "top", options = list(container = "body") ), withTooltip(shiny::checkboxInput(ns("gx_showqvalues"), "show indivivual q-values", FALSE), - "Show q-values of each indivivual statistical method in the table.", - placement = "top", options = list(container = "body") + "Show q-values of each indivivual statistical method in the table.", + placement = "top", options = list(container = "body") ) ) table.RENDER <- shiny::reactive({ - res <- res() if (is.null(res) || nrow(res) == 0) { @@ -78,40 +74,40 @@ expression_table_genetable_server <- function(id, numeric.cols <- colnames(res)[numeric.cols] DT::datatable(res, - rownames = FALSE, - ## class = 'compact cell-border stripe hover', - class = "compact hover", - extensions = c("Scroller"), - selection = list(mode = "single", target = "row", selected = 1), - fillContainer = TRUE, - options = list( - dom = "frtip", - paging = TRUE, - pageLength = 16, ## lengthMenu = c(20, 30, 40, 60, 100, 250), - scrollX = TRUE, - scrollY = FALSE, - scroller = FALSE, - deferRender = TRUE, - search = list( - regex = TRUE, - caseInsensitive = TRUE - ## , search = 'M[ae]' - ) - ) ## end of options.list + rownames = FALSE, + ## class = 'compact cell-border stripe hover', + class = "compact hover", + extensions = c("Scroller"), + selection = list(mode = "single", target = "row", selected = 1), + fillContainer = TRUE, + options = list( + dom = "frtip", + paging = TRUE, + pageLength = 16, ## lengthMenu = c(20, 30, 40, 60, 100, 250), + scrollX = TRUE, + scrollY = FALSE, + scroller = FALSE, + deferRender = TRUE, + search = list( + regex = TRUE, + caseInsensitive = TRUE + ## , search = 'M[ae]' + ) + ) ## end of options.list ) %>% DT::formatSignif(numeric.cols, 4) %>% DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") %>% DT::formatStyle(colnames(res)[fx.col], - ## background = DT::styleColorBar(c(0,3), 'lightblue'), - background = color_from_middle(fx, "lightblue", "#f5aeae"), - backgroundSize = "98% 88%", - backgroundRepeat = "no-repeat", - backgroundPosition = "center" + ## background = DT::styleColorBar(c(0,3), 'lightblue'), + background = color_from_middle(fx, "lightblue", "#f5aeae"), + backgroundSize = "98% 88%", + backgroundRepeat = "no-repeat", + backgroundPosition = "center" ) - })# %>% + }) # %>% # bindCache(filteredDiffExprTable(), input$gx_showqvalues) - genetable_text = "Table I shows the results of the statistical tests. To increase the statistical reliability of the Omics Playground, we perform the DE analysis using four commonly accepted methods in the literature, namely, T-test (standard, Welch), limma (no trend, trend, voom), edgeR (QLF, LRT), and DESeq2 (Wald, LRT), and merge the results. + genetable_text <- "Table I shows the results of the statistical tests. To increase the statistical reliability of the Omics Playground, we perform the DE analysis using four commonly accepted methods in the literature, namely, T-test (standard, Welch), limma (no trend, trend, voom), edgeR (QLF, LRT), and DESeq2 (Wald, LRT), and merge the results.

For a selected comparison under the Contrast setting, the results of the selected methods are combined and reported under the table, where meta.q for a gene represents the highest q value among the methods and the number of stars for a gene indicate how many methods identified significant q values (q < 0.05). The table is interactive (scrollable, clickable); users can sort genes by logFC, meta.q, or average expression in either conditions. Users can filter top N = {10} differently expressed genes in the table by clicking the top 10 genes from the table Settings." @@ -131,6 +127,5 @@ expression_table_genetable_server <- function(id, message("expression_table_genetable_server done") return(genetable) - } - ) -} \ No newline at end of file + }) +} diff --git a/components/board.expression/R/expression_table_gsettable.R b/components/board.expression/R/expression_table_gsettable.R index 3f6acecd3..0467fdea5 100644 --- a/components/board.expression/R/expression_table_gsettable.R +++ b/components/board.expression/R/expression_table_gsettable.R @@ -12,11 +12,9 @@ #' #' @export expression_table_gsettable_ui <- function(id) { - ns <- shiny::NS(id) tableWidget(ns("gsettable")) - } #' Server side table code: expression board @@ -29,9 +27,8 @@ expression_table_gsettable_server <- function(id, gx_related_genesets, height, width, - watermark=FALSE){ - moduleServer( id, function(input, output, session) { - + watermark = FALSE) { + moduleServer(id, function(input, output, session) { ns <- session$ns gsettable.RENDER <- shiny::reactive({ @@ -43,28 +40,28 @@ expression_table_gsettable_server <- function(id, df$geneset <- wrapHyperLink(df$geneset, rownames(df)) DT::datatable(df, - ## class = 'compact cell-border stripe', - class = "compact", - rownames = FALSE, escape = c(-1, -2), - extensions = c("Scroller"), - fillContainer = TRUE, - options = list( - ## dom = 'lfrtip', - dom = "frtip", - paging = TRUE, - pageLength = 16, ## lengthMenu = c(20, 30, 40, 60, 100, 250), - scrollX = TRUE, - ## scrollY = tabV, - scrollY = FALSE, - scroller = FALSE, - deferRender = TRUE, - search = list( - regex = TRUE, - caseInsensitive = TRUE - ## search = 'GOBP:' - ) - ), ## end of options.list - selection = list(mode = "single", target = "row", selected = NULL) + ## class = 'compact cell-border stripe', + class = "compact", + rownames = FALSE, escape = c(-1, -2), + extensions = c("Scroller"), + fillContainer = TRUE, + options = list( + ## dom = 'lfrtip', + dom = "frtip", + paging = TRUE, + pageLength = 16, ## lengthMenu = c(20, 30, 40, 60, 100, 250), + scrollX = TRUE, + ## scrollY = tabV, + scrollY = FALSE, + scroller = FALSE, + deferRender = TRUE, + search = list( + regex = TRUE, + caseInsensitive = TRUE + ## search = 'GOBP:' + ) + ), ## end of options.list + selection = list(mode = "single", target = "row", selected = NULL) ) %>% ## formatSignif(1:ncol(df),4) %>% DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") %>% @@ -85,5 +82,5 @@ expression_table_gsettable_server <- function(id, height = height, width = width ) return(gsettable) - }) #end module server -} #end server \ No newline at end of file + }) # end module server +} # end server diff --git a/components/board.expression/R/expression_ui.R b/components/board.expression/R/expression_ui.R index 6f809909d..2e0475eb3 100644 --- a/components/board.expression/R/expression_ui.R +++ b/components/board.expression/R/expression_ui.R @@ -73,7 +73,6 @@ ExpressionUI <- function(id) { boardHeader(title = "Differential expression", info_link = ns("gx_info")), div( tagList( - div( style = "max-height:50vh;", shiny::tabsetPanel( @@ -85,9 +84,9 @@ ExpressionUI <- function(id) { div( class = "col-md-3", expression_plot_volcano_ui(ns("plots_volcano"), - label = "a", - height = c(imgH, imgH), - width = c("auto", imgH) + label = "a", + height = c(imgH, imgH), + width = c("auto", imgH) ), ), div( @@ -131,10 +130,9 @@ ExpressionUI <- function(id) { expression_plot_topgenes_ui( id = ns("topgenes"), label = "a", - height = c(imgH,420), - width = c('auto',1600) + height = c(imgH, 420), + width = c("auto", 1600) ), - shiny::br(), tags$div( class = "caption", @@ -145,9 +143,10 @@ ExpressionUI <- function(id) { shiny::tabPanel( "Volcano (all)", expression_plot_volcanoAll_ui(ns("volcanoAll"), - label='a', - height = c(imgH, 500), - width = c("auto", 1600)), + label = "a", + height = c(imgH, 500), + width = c("auto", 1600) + ), shiny::br(), tags$div( class = "caption", @@ -158,10 +157,12 @@ ExpressionUI <- function(id) { ), shiny::tabPanel( "Volcano (methods)", - expression_plot_volcanoMethods_ui(id = ns("volcanoMethods"), - label ='a', - height = c(imgH, 450), - width = c("auto", 1600)), + expression_plot_volcanoMethods_ui( + id = ns("volcanoMethods"), + label = "a", + height = c(imgH, 450), + width = c("auto", 1600) + ), shiny::br(), tags$div( class = "caption", @@ -206,8 +207,7 @@ ExpressionUI <- function(id) { ) ) ) - - ) ) ) + ) }