From e18ac946bd40b20a0e500afb6568f953825eff62 Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Thu, 16 Feb 2023 17:57:32 +0100 Subject: [PATCH 01/44] `compare_plot_cum_fc` split into two plots --- .../board.compare/R/compare_plot_cum_fc.R | 139 ------------------ .../board.compare/R/compare_plot_cum_fc1.R | 138 +++++++++++++++++ .../board.compare/R/compare_plot_cum_fc2.R | 138 +++++++++++++++++ components/board.compare/R/compare_server.R | 46 +++++- components/board.compare/R/compare_ui.R | 12 +- 5 files changed, 329 insertions(+), 144 deletions(-) delete mode 100644 components/board.compare/R/compare_plot_cum_fc.R create mode 100644 components/board.compare/R/compare_plot_cum_fc1.R create mode 100644 components/board.compare/R/compare_plot_cum_fc2.R diff --git a/components/board.compare/R/compare_plot_cum_fc.R b/components/board.compare/R/compare_plot_cum_fc.R deleted file mode 100644 index 123ee558a..000000000 --- a/components/board.compare/R/compare_plot_cum_fc.R +++ /dev/null @@ -1,139 +0,0 @@ -## -## This file is part of the Omics Playground project. -## Copyright (c) 2018-2023 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 -compare_plot_cum_fc_ui <- function(id, - height, - width) { - ns <- shiny::NS(id) - info_text <- "" - - PlotModuleUI(ns("plot"), - title = "Cumulative foldchange", - plotlib = "base", - label = "b", - info.text = info_text, - 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 -compare_plot_cum_fc_server <- function(id, - inputData, - dataset2, - input.contrast1, - input.contrast2, - watermark = FALSE) { - moduleServer(id, function(input, output, session) { - ns <- session$ns - - plot_data <- shiny::reactive({ - ngs1 <- inputData() - ngs2 <- dataset2() - - ct1 <- head(names(ngs1$gx.meta$meta), 2) - ct2 <- head(names(ngs2$gx.meta$meta), 2) - ct1 <- input.contrast1() - ct2 <- input.contrast2() - shiny::req(ct1) - shiny::req(ct2) - if (!all(ct1 %in% names(ngs1$gx.meta$meta))) { - return(NULL) - } - if (!all(ct2 %in% names(ngs2$gx.meta$meta))) { - return(NULL) - } - - F1 <- pgx.getMetaMatrix(ngs1)$fc[, ct1, drop = FALSE] - F2 <- pgx.getMetaMatrix(ngs2)$fc[, ct2, drop = FALSE] - - gg <- intersect(toupper(rownames(F1)), toupper(rownames(F2))) - g1 <- rownames(F1)[match(gg, toupper(rownames(F1)))] - g2 <- rownames(F2)[match(gg, toupper(rownames(F2)))] - F1 <- F1[g1, , drop = FALSE] - F2 <- F2[g2, , drop = FALSE] - colnames(F1) <- paste0("1:", colnames(F1)) - colnames(F2) <- paste0("2:", colnames(F2)) - - return(cbind(F1, F2)) - }) - - cumfcplot.RENDER <- shiny::reactive({ - F <- plot_data() - indexes <- substr(colnames(F), 1, 1) - F1 <- F[, indexes == 1, drop = FALSE] - F2 <- F[, indexes == 2, drop = FALSE] - - ii <- head(order(-rowMeans(F**2)), 50) - ii <- ii[order(rowMeans(F[ii, ]))] - F <- F[ii, , drop = FALSE] - F1 <- F1[ii, , drop = FALSE] - F2 <- F2[ii, , drop = FALSE] - - par(mfrow = c(1, 1), mar = c(4.5, 0, 1, 2), mgp = c(2.2, 0.8, 0)) - graphics::layout(matrix(c(1, 2, 3), nrow = 1, byrow = T), widths = c(0.5, 1, 1)) - - frame() - mtext(rownames(F), - cex = 0.80, side = 2, at = (1:nrow(F) - 0.5) / nrow(F), - las = 1, line = -12 - ) - col1 <- grey.colors(ncol(F1)) - if (ncol(F1) == 1) col1 <- "grey50" - pgx.stackedBarplot(F1, - hz = TRUE, las = 1, col = col1, - cex.names = 0.01, cex.lab = 1.4, space = 0.25, - xlab = "cumulative foldchange", ylab = "" - ) - legend("bottomright", colnames(F1), - fill = grey.colors(ncol(F1)), - cex = 0.9, y.intersp = 0.9, inset = c(-0.03, 0.02), xpd = TRUE - ) - title("DATASET1", line = -0.35, cex.main = 1.2) - - col2 <- grey.colors(ncol(F2)) - if (ncol(F2) == 1) col2 <- "grey50" - pgx.stackedBarplot(F2, - hz = TRUE, las = 1, col = col2, - cex.names = 0.01, cex.lab = 1.4, space = 0.25, - xlab = "cumulative foldchange", ylab = "" - ) - legend("bottomright", colnames(F2), - fill = grey.colors(ncol(F2)), - cex = 0.9, y.intersp = 0.9, inset = c(-0.03, 0.02), xpd = TRUE - ) - title("DATASET2", line = -0.35, cex.main = 1.2) - p <- grDevices::recordPlot() - p - }) - - PlotModuleServer( - "plot", - plotlib = "base", - func = cumfcplot.RENDER, - csvFunc = plot_data, - res = c(80, 98), ## resolution of plots - pdf.width = 6, pdf.height = 6, - add.watermark = watermark - ) - }) ## end of moduleServer -} diff --git a/components/board.compare/R/compare_plot_cum_fc1.R b/components/board.compare/R/compare_plot_cum_fc1.R new file mode 100644 index 000000000..b545a5e99 --- /dev/null +++ b/components/board.compare/R/compare_plot_cum_fc1.R @@ -0,0 +1,138 @@ +## +## This file is part of the Omics Playground project. +## Copyright (c) 2018-2023 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 +compare_plot_cum_fc1_ui <- function(id, + height, + width, + label) { + ns <- shiny::NS(id) + info_text <- "" + + PlotModuleUI(ns("plot"), + title = "Cumulative foldchange", + plotlib = "plotly", + label = label, + info.text = info_text, + download.fmt = c("png", "pdf", "csv"), + height = height, + width = width + ) +} + +#' Expression plot Server function +#' +#' @description A shiny Module for plotting (server code). +#' +#' @param id +#' +#' @export +compare_plot_cum_fc1_server <- function(id, + inputData, + dataset2, + cum_fc, + input.contrast1, + input.contrast2, + watermark = FALSE) { + moduleServer(id, function(input, output, session) { + ns <- session$ns + + cumfcplot.RENDER <- shiny::reactive({ + F <- cum_fc() + indexes <- substr(colnames(F), 1, 1) + F1 <- F[, indexes == 1, drop = FALSE] + F2 <- F[, indexes == 2, drop = FALSE] + + ii <- head(order(-rowMeans(F**2)), 50) + ii <- ii[order(rowMeans(F[ii, ]))] + F <- F[ii, , drop = FALSE] + F1 <- F1[ii, , drop = FALSE] + F2 <- F2[ii, , drop = FALSE] + + fig <- pgx.barplot.PLOTLY( + data = data.frame( + x = factor(rownames(F1),levels =rownames(F1)), + y = as.numeric(F1) + ), + x = "x", + y = "y", + yaxistitle = "Cumulative foldchange", + xaxistitle = "Genes", + title = "Dataset 1", + type = "bar", + plotRawValues = TRUE + ) + + # fig2 <- pgx.barplot.PLOTLY( + # data = data.frame( + # x = factor(rownames(F2),levels =rownames(F2)), + # y = as.numeric(F2) + # ), + # x = "x", + # y = "y", + # yaxistitle = "Cumulative foldchange", + # xaxistitle = "Genes", + # type = "bar", + # plotRawValues = TRUE + # ) + + fig + + # par(mfrow = c(1, 1), mar = c(4.5, 0, 1, 2), mgp = c(2.2, 0.8, 0)) + # graphics::layout(matrix(c(1, 2, 3), nrow = 1, byrow = T), widths = c(0.5, 1, 1)) + # + # frame() + # mtext(rownames(F), + # cex = 0.80, side = 2, at = (1:nrow(F) - 0.5) / nrow(F), + # las = 1, line = -12 + # ) + # col1 <- grey.colors(ncol(F1)) + # if (ncol(F1) == 1) col1 <- "grey50" + # pgx.stackedBarplot(F1, + # hz = TRUE, las = 1, col = col1, + # cex.names = 0.01, cex.lab = 1.4, space = 0.25, + # xlab = "cumulative foldchange", ylab = "" + # ) + # legend("bottomright", colnames(F1), + # fill = grey.colors(ncol(F1)), + # cex = 0.9, y.intersp = 0.9, inset = c(-0.03, 0.02), xpd = TRUE + # ) + # title("DATASET1", line = -0.35, cex.main = 1.2) + # + # col2 <- grey.colors(ncol(F2)) + # if (ncol(F2) == 1) col2 <- "grey50" + # pgx.stackedBarplot(F2, + # hz = TRUE, las = 1, col = col2, + # cex.names = 0.01, cex.lab = 1.4, space = 0.25, + # xlab = "cumulative foldchange", ylab = "" + # ) + # legend("bottomright", colnames(F2), + # fill = grey.colors(ncol(F2)), + # cex = 0.9, y.intersp = 0.9, inset = c(-0.03, 0.02), xpd = TRUE + # ) + # title("DATASET2", line = -0.35, cex.main = 1.2) + # p <- grDevices::recordPlot() + # p + }) + + PlotModuleServer( + "plot", + plotlib = "plotly", + func = cumfcplot.RENDER, + csvFunc = cum_fc, + res = c(80, 98), ## resolution of plots + pdf.width = 6, pdf.height = 6, + add.watermark = watermark + ) + }) ## end of moduleServer +} diff --git a/components/board.compare/R/compare_plot_cum_fc2.R b/components/board.compare/R/compare_plot_cum_fc2.R new file mode 100644 index 000000000..d74172ae2 --- /dev/null +++ b/components/board.compare/R/compare_plot_cum_fc2.R @@ -0,0 +1,138 @@ +## +## This file is part of the Omics Playground project. +## Copyright (c) 2018-2023 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 +compare_plot_cum_fc2_ui <- function(id, + height, + width, + label) { + ns <- shiny::NS(id) + info_text <- "" + + PlotModuleUI(ns("plot"), + title = "Cumulative foldchange", + plotlib = "plotly", + label = label, + info.text = info_text, + download.fmt = c("png", "pdf", "csv"), + height = height, + width = width + ) +} + +#' Expression plot Server function +#' +#' @description A shiny Module for plotting (server code). +#' +#' @param id +#' +#' @export +compare_plot_cum_fc2_server <- function(id, + inputData, + dataset2, + input.contrast1, + input.contrast2, + cum_fc, + watermark = FALSE) { + moduleServer(id, function(input, output, session) { + ns <- session$ns + + cumfcplot.RENDER <- shiny::reactive({ + F <- cum_fc() + indexes <- substr(colnames(F), 1, 1) + F1 <- F[, indexes == 1, drop = FALSE] + F2 <- F[, indexes == 2, drop = FALSE] + + ii <- head(order(-rowMeans(F**2)), 50) + ii <- ii[order(rowMeans(F[ii, ]))] + F <- F[ii, , drop = FALSE] + F1 <- F1[ii, , drop = FALSE] + F2 <- F2[ii, , drop = FALSE] + + fig <- pgx.barplot.PLOTLY( + data = data.frame( + x = factor(rownames(F2),levels =rownames(F2)), + y = as.numeric(F2) + ), + x = "x", + y = "y", + yaxistitle = "Cumulative foldchange", + xaxistitle = "Genes", + title = "Dataset 2", + type = "bar", + plotRawValues = TRUE + ) + + # fig2 <- pgx.barplot.PLOTLY( + # data = data.frame( + # x = factor(rownames(F2),levels =rownames(F2)), + # y = as.numeric(F2) + # ), + # x = "x", + # y = "y", + # yaxistitle = "Cumulative foldchange", + # xaxistitle = "Genes", + # type = "bar", + # plotRawValues = TRUE + # ) + + fig + + # par(mfrow = c(1, 1), mar = c(4.5, 0, 1, 2), mgp = c(2.2, 0.8, 0)) + # graphics::layout(matrix(c(1, 2, 3), nrow = 1, byrow = T), widths = c(0.5, 1, 1)) + # + # frame() + # mtext(rownames(F), + # cex = 0.80, side = 2, at = (1:nrow(F) - 0.5) / nrow(F), + # las = 1, line = -12 + # ) + # col1 <- grey.colors(ncol(F1)) + # if (ncol(F1) == 1) col1 <- "grey50" + # pgx.stackedBarplot(F1, + # hz = TRUE, las = 1, col = col1, + # cex.names = 0.01, cex.lab = 1.4, space = 0.25, + # xlab = "cumulative foldchange", ylab = "" + # ) + # legend("bottomright", colnames(F1), + # fill = grey.colors(ncol(F1)), + # cex = 0.9, y.intersp = 0.9, inset = c(-0.03, 0.02), xpd = TRUE + # ) + # title("DATASET1", line = -0.35, cex.main = 1.2) + # + # col2 <- grey.colors(ncol(F2)) + # if (ncol(F2) == 1) col2 <- "grey50" + # pgx.stackedBarplot(F2, + # hz = TRUE, las = 1, col = col2, + # cex.names = 0.01, cex.lab = 1.4, space = 0.25, + # xlab = "cumulative foldchange", ylab = "" + # ) + # legend("bottomright", colnames(F2), + # fill = grey.colors(ncol(F2)), + # cex = 0.9, y.intersp = 0.9, inset = c(-0.03, 0.02), xpd = TRUE + # ) + # title("DATASET2", line = -0.35, cex.main = 1.2) + # p <- grDevices::recordPlot() + # p + }) + + PlotModuleServer( + "plot", + plotlib = "plotly", + func = cumfcplot.RENDER, + csvFunc = cum_fc, + res = c(80, 98), ## resolution of plots + pdf.width = 6, pdf.height = 6, + add.watermark = watermark + ) + }) ## end of moduleServer +} diff --git a/components/board.compare/R/compare_server.R b/components/board.compare/R/compare_server.R index c61641049..8f61abc81 100644 --- a/components/board.compare/R/compare_server.R +++ b/components/board.compare/R/compare_server.R @@ -56,6 +56,37 @@ CompareBoard <- function(id, inputData) { ## ========================= REACTIVE FUNCTIONS =================================== ## ================================================================================ + cum_fc <- shiny::reactive({ + ngs1 <- inputData() + ngs2 <- dataset2() + + ct1 <- head(names(ngs1$gx.meta$meta), 2) + ct2 <- head(names(ngs2$gx.meta$meta), 2) + ct1 <- input.contrast1() + ct2 <- input.contrast2() + shiny::req(ct1) + shiny::req(ct2) + if (!all(ct1 %in% names(ngs1$gx.meta$meta))) { + return(NULL) + } + if (!all(ct2 %in% names(ngs2$gx.meta$meta))) { + return(NULL) + } + + F1 <- pgx.getMetaMatrix(ngs1)$fc[, ct1, drop = FALSE] + F2 <- pgx.getMetaMatrix(ngs2)$fc[, ct2, drop = FALSE] + + gg <- intersect(toupper(rownames(F1)), toupper(rownames(F2))) + g1 <- rownames(F1)[match(gg, toupper(rownames(F1)))] + g2 <- rownames(F2)[match(gg, toupper(rownames(F2)))] + F1 <- F1[g1, , drop = FALSE] + F2 <- F2[g2, , drop = FALSE] + colnames(F1) <- paste0("1:", colnames(F1)) + colnames(F2) <- paste0("2:", colnames(F2)) + + return(cbind(F1, F2)) + }) + dataset2 <- shiny::reactive({ shiny::req(input$dataset2) if (input$dataset2 == "") { @@ -279,10 +310,21 @@ CompareBoard <- function(id, inputData) { # Cumulative FC - compare_plot_cum_fc_server( - "cumfcplot", + compare_plot_cum_fc1_server( + "cumfcplot1", + inputData = inputData, + dataset2 = dataset2, + cum_fc = cum_fc, + input.contrast1 = input.contrast1, + input.contrast2 = input.contrast2, + watermark = WATERMARK + ) + + compare_plot_cum_fc2_server( + "cumfcplot2", inputData = inputData, dataset2 = dataset2, + cum_fc = cum_fc, input.contrast1 = input.contrast1, input.contrast2 = input.contrast2, watermark = WATERMARK diff --git a/components/board.compare/R/compare_ui.R b/components/board.compare/R/compare_ui.R index 1ec46e6d9..8224c8db8 100644 --- a/components/board.compare/R/compare_ui.R +++ b/components/board.compare/R/compare_ui.R @@ -123,9 +123,15 @@ CompareUI <- function(id) { ), div( class = "col-md-6", - compare_plot_cum_fc_ui(ns("cumfcplot"), - height = c(700, 750), - width = c("auto", 900) + compare_plot_cum_fc1_ui(ns("cumfcplot1"), + height = c(350, 375), + width = c("auto", 900), + label = "b" + ), + compare_plot_cum_fc2_ui(ns("cumfcplot2"), + height = c(350, 375), + width = c("auto", 900), + label = "c" ) ) ) From aaf1fa7018aabd36976620b2453ed8c4bad3bce9 Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Thu, 16 Feb 2023 18:06:37 +0100 Subject: [PATCH 02/44] add info.text and board caption --- components/board.compare/R/compare_plot_cum_fc1.R | 2 +- components/board.compare/R/compare_plot_cum_fc2.R | 2 +- components/board.compare/R/compare_ui.R | 5 +++++ 3 files changed, 7 insertions(+), 2 deletions(-) diff --git a/components/board.compare/R/compare_plot_cum_fc1.R b/components/board.compare/R/compare_plot_cum_fc1.R index b545a5e99..71026eca5 100644 --- a/components/board.compare/R/compare_plot_cum_fc1.R +++ b/components/board.compare/R/compare_plot_cum_fc1.R @@ -17,7 +17,7 @@ compare_plot_cum_fc1_ui <- function(id, width, label) { ns <- shiny::NS(id) - info_text <- "" + info_text <- "Barplot showing the cumulative fold changes on dataset 1" PlotModuleUI(ns("plot"), title = "Cumulative foldchange", diff --git a/components/board.compare/R/compare_plot_cum_fc2.R b/components/board.compare/R/compare_plot_cum_fc2.R index d74172ae2..9de125995 100644 --- a/components/board.compare/R/compare_plot_cum_fc2.R +++ b/components/board.compare/R/compare_plot_cum_fc2.R @@ -17,7 +17,7 @@ compare_plot_cum_fc2_ui <- function(id, width, label) { ns <- shiny::NS(id) - info_text <- "" + info_text <- "Barplot showing the cumulative fold changes on dataset 2" PlotModuleUI(ns("plot"), title = "Cumulative foldchange", diff --git a/components/board.compare/R/compare_ui.R b/components/board.compare/R/compare_ui.R index 8224c8db8..6ea8249e0 100644 --- a/components/board.compare/R/compare_ui.R +++ b/components/board.compare/R/compare_ui.R @@ -134,6 +134,11 @@ CompareUI <- function(id) { label = "c" ) ) + ), + tags$div( + class = "caption", + HTML("Compare datasets. Identification of similar features across datasets and contrasts. (a) Correlation between selected contrasts. + (b) Cumulative fold change of genes on dataset 1. (c) Cumulative fold change of genes on dataset 2.") ) ), shiny::tabPanel( From f62ee72a483a16989e4d85f437c637af3cc330e3 Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Fri, 17 Feb 2023 11:43:25 +0100 Subject: [PATCH 03/44] improve document outline --- .../board.clustering/R/clustering_server.R | 76 +++++------- .../board.clustering/R/plot_clustannot.R | 113 +++++++++--------- components/board.clustering/R/plot_clustpca.R | 14 +-- 3 files changed, 91 insertions(+), 112 deletions(-) diff --git a/components/board.clustering/R/clustering_server.R b/components/board.clustering/R/clustering_server.R index e1b6ec2ba..7562a00c8 100644 --- a/components/board.clustering/R/clustering_server.R +++ b/components/board.clustering/R/clustering_server.R @@ -22,9 +22,7 @@ The Clustering Analysis module performs unsupervised clustering ') - ##================================================================================ - ##============================ MODULES =========================================== - ##================================================================================ + # modules ######## r.samples <- reactive({ ##colnames(getFilteredMatrix()) @@ -41,9 +39,7 @@ The Clustering Analysis module performs unsupervised clustering parent = ns) - ##================================================================================ - ##======================= OBSERVE FUNCTIONS ====================================== - ##================================================================================ + # observe functions ######## shiny::observeEvent( input$clust_info, { shiny::showModal(shiny::modalDialog( @@ -123,9 +119,9 @@ The Clustering Analysis module performs unsupervised clustering }) - ##================================================================================ - ##========================= REACTIVE FUNCTIONS =================================== - ##================================================================================ + + # REACTIVE FUNCTIONS ############## + getFilteredMatrix <- shiny::reactive({ ## Returns filtered matrix ready for clustering. Filtering based @@ -141,9 +137,9 @@ The Clustering Analysis module performs unsupervised clustering shiny::req(ft) if(input$hm_level=="geneset") { - ##----------------------------------- - ## Gene set level features - ##----------------------------------- + + ## Gene set level features ######### + gsets = rownames(pgx$gsetX) ##gsets = unique(unlist(COLLECTIONS[ft])) gsets = unique(COLLECTIONS[[ft]]) @@ -158,9 +154,9 @@ The Clustering Analysis module performs unsupervised clustering idx <- NULL if(input$hm_level=="gene") { - ##----------------------------------- - ## Gene level features - ##----------------------------------- + + ## Gene level features ########### + gg = pgx$families[[1]] if(ft =="") { gg = rownames(pgx$X) @@ -321,9 +317,9 @@ The Clustering Analysis module performs unsupervised clustering ##if(length(grp)==0) splitby <- 'none' if(do.split && length(grp)==0) return(NULL) - ##------------------------------------------------------------ - ## Any BMC scaling?? - ##------------------------------------------------------------ + + ## Any BMC scaling?? ########## + if(do.split && input$hm_scale=="BMC") { dbg("[ClusteringBoard:getTopMatrix] batch-mean centering...") for(g in unique(grp)) { @@ -333,9 +329,9 @@ The Clustering Analysis module performs unsupervised clustering } } - ##------------------------------------------------------------ - ## Create reduced matrix according to topmode - ##------------------------------------------------------------ + + ## Create reduced matrix according to topmode ####### + topmode="specific" topmode="sd" @@ -477,17 +473,13 @@ The Clustering Analysis module performs unsupervised clustering }) - ##================================================================================ - ##========================= FUNCTIONS ============================================ - ##================================================================================ + # functions ########## hm_splitmap_text = tagsub("Under the Heatmap panel, hierarchical clustering can be performed on gene level or gene set level expression in which users have to specify it under the {Level} dropdown list.

Under the plot configuration {{Settings}}, users can split the samples by a phenotype class (e.g., tissue, cell type, or gender) using the {split by} setting. In addition, users can specify the top N = (50, 150, 500) features to be used in the heatmap. The ordering of top features is selected under {top mode}. The criteria to select the top features are:

  1. SD - features with the highest standard deviation across all the samples,
  2. specific - features that are overexpressed in each phenotype class compared to the rest, or by
  3. PCA - by principal components.

Users can also choose between 'relative' or 'absolute' expression scale. Under the {cexCol} and {cexRow} settings, it is also possible to adjust the cex for the column and row labels.") hm1_splitmap.RENDER <- shiny::reactive({ - ##------------------------------------------------------------ - ## ComplexHeatmap based splitted heatmap - ##------------------------------------------------------------ + ## ComplexHeatmap based splitted heatmap ########## filt <- getTopMatrix() shiny::req(filt) @@ -593,9 +585,9 @@ The Clustering Analysis module performs unsupervised clustering hm2_splitmap.RENDER <- shiny::reactive({ - ##------------------------------------------------------------ - ## iHeatmap based splitted heatmap - ##------------------------------------------------------------ + + ## iHeatmap based splitted heatmap ######### + shiny::req(pgx$genes) ## -------------- variable to split samples @@ -834,9 +826,8 @@ The Clustering Analysis module performs unsupervised clustering add.watermark = WATERMARK ) - ##================================================================================ - ##================================ PCA/tSNE ====================================== - ##================================================================================ + + ## PCA/tSNE ############ hm_PCAplot_text = tagsub(paste0(' The PCA/tSNE panel visualizes unsupervised clustering obtained by the principal components analysis (',a_PCA,') or t-distributed stochastic embedding (',a_tSNE,') algorithms. This plot shows the relationship (or similarity) between the samples for visual analytics, where similarity is visualized as proximity of the points. Samples that are ‘similar’ will be placed close to each other.

Users can customise the PCA/tSNE plot in the plot settings, including the {color} and {shape} of points using a phenotype class, choose t-SNE or PCA layout, label the points, or display 2D and 3D visualisation of the PCA/tSNE plot.')) @@ -1116,9 +1107,7 @@ The Clustering Analysis module performs unsupervised clustering add.watermark = WATERMARK ) - ##================================================================================ - ## Parallel coordinates - ##================================================================================ + ## Parallel coordinates ########## hm_parcoord.ranges <- shiny::reactiveValues() @@ -1299,9 +1288,8 @@ displays the expression levels of selected genes across all conditions in the an height = c(270,700) ) - ##================================================================================ - ## Annotate clusters - ##================================================================================ + ## Annotate clusters ############ + clustannot_plots_text = paste0('The top features of the heatmap in the Heatmap panel are divided into gene (or gene set) clusters based on their expression profile patterns. For each cluster, the platform provides a functional annotation in the Annotate cluster panel by correlating annotation features from more than 42 published reference databases, including well-known databases such as ',a_MSigDB,', ',a_KEGG,' and ',a_GO,'. In the plot settings, users can specify the level and reference set to be used under the Reference level and Reference set settings, respectively.') @@ -1658,9 +1646,8 @@ displays the expression levels of selected genes across all conditions in the an ) }) - ##================================================================================ - ## Phenotypes {data-height=800} - ##================================================================================ + + ## Phenotypes ################# clust_phenoplot.RENDER <- shiny::reactive({ @@ -1747,10 +1734,7 @@ displays the expression levels of selected genes across all conditions in the an add.watermark = WATERMARK ) - - ##============================================================================= - ## Feature ranking - ##============================================================================= + ## Feature ranking ########### calcFeatureRanking <- shiny::reactive({ diff --git a/components/board.clustering/R/plot_clustannot.R b/components/board.clustering/R/plot_clustannot.R index c7353133d..73e6c4a7d 100644 --- a/components/board.clustering/R/plot_clustannot.R +++ b/components/board.clustering/R/plot_clustannot.R @@ -4,9 +4,9 @@ ## -##================================================================================ -## Annotate clusters -##================================================================================ + +## Annotate clusters ########## + clustannot_plot_ui <- function(id, label='', height=c(600,800)) { @@ -17,7 +17,7 @@ clustannot_plot_ui <- function(id, label='', height=c(600,800)) a_GO="Gene Ontology" info_text = paste0('The top features of the heatmap in the Heatmap panel are divided into gene (or gene set) clusters based on their expression profile patterns. For each cluster, the platform provides a functional annotation in the Annotate cluster panel by correlating annotation features from more than 42 published reference databases, including well-known databases such as ',a_MSigDB,', ',a_KEGG,' and ',a_GO,'. In the plot settings, users can specify the level and reference set to be used under the Reference level and Reference set settings, respectively.') - + plots_opts = shiny::tagList( withTooltip( shiny::selectInput(ns("xann_level"), "Reference level:", choices=c("gene","geneset","phenotype"), @@ -34,19 +34,19 @@ clustannot_plot_ui <- function(id, label='', height=c(600,800)) "Specify a reference set to be used in the annotation.", placement="left",options = list(container = "body")) ) - + PlotModuleUI( ns("pltmod"), title = "Functional annotation of clusters", label = label, outputFunc = plotly::plotlyOutput, - outputFunc2 = plotly::plotlyOutput, + outputFunc2 = plotly::plotlyOutput, info.text = info_text, options = plots_opts, - download.fmt=c("png","pdf","csv"), + download.fmt=c("png","pdf","csv"), width = c("auto","100%"), height = height - ) + ) } clustannot_table_ui <- function(id, label='', height=c(600,800)) { @@ -54,18 +54,18 @@ clustannot_table_ui <- function(id, label='', height=c(600,800)) { plotWidget(ns("clustannot_table")) } -clustannot_server <- function(id, +clustannot_server <- function(id, pgx, top_matrix = reactive(NULL), hm_level = reactive("gene"), - hm_topmode = reactive("sd"), + hm_topmode = reactive("sd"), watermark=FALSE) { moduleServer( id, function(input, output, session) { ns <- session$ns - + shiny::observe({ - ##pgx <- inputData() + ##pgx <- inputData() shiny::req(pgx$X,pgx$gsetX,pgx$families) if(is.null(input$xann_level)) return(NULL) @@ -92,25 +92,25 @@ clustannot_server <- function(id, } else { ann.types = sel = "" } - shiny::updateSelectInput(session, "xann_refset", choices=ann.types, selected=sel) + shiny::updateSelectInput(session, "xann_refset", choices=ann.types, selected=sel) }) - + ## This is used both for plot and table get_annot_correlation <- shiny::reactive({ - + ##pgx <- inputData() shiny::req(pgx$X,pgx$Y,pgx$gsetX,pgx$families) ##filt <- getTopMatrix() filt <- top_matrix() shiny::req(filt) - + zx <- filt$mat idx <- filt$idx samples <- filt$samples if(nrow(zx) <= 1) return(NULL) - + ann.level="geneset" ann.refset="Hallmark collection" ann.level = input$xann_level @@ -118,22 +118,22 @@ clustannot_server <- function(id, ann.refset = input$xann_refset ##if(is.null(ann.refset)) return(NULL) shiny::req(input$xann_level, input$xann_refset) - + ref = NULL - ref = pgx$gsetX[,,drop=FALSE] - ref = pgx$X[,,drop=FALSE] + ref = pgx$gsetX[,,drop=FALSE] + ref = pgx$X[,,drop=FALSE] if(ann.level=="gene" && ann.refset %in% names(pgx$families) ) { gg = pgx$families[[ann.refset]] jj = match(toupper(gg), toupper(pgx$genes$gene_name)) jj <- setdiff(jj,NA) pp = rownames(pgx$genes)[jj] - ref = pgx$X[intersect(pp,rownames(pgx$X)),,drop=FALSE] + ref = pgx$X[intersect(pp,rownames(pgx$X)),,drop=FALSE] } if(ann.level=="geneset" && ann.refset %in% names(COLLECTIONS)) { ss = COLLECTIONS[[ann.refset]] ss = intersect(ss, rownames(pgx$gsetX)) length(ss) - ref = pgx$gsetX[ss,] + ref = pgx$gsetX[ss,] } if(ann.level=="phenotype") { ref = t(expandAnnotationMatrix(pgx$Y)) @@ -142,7 +142,7 @@ clustannot_server <- function(id, cat(" WARNING:: ref error\n") return(NULL) } - + ##----------- restrict to top?? dim(ref) if(nrow(ref)>1000) { @@ -152,13 +152,13 @@ clustannot_server <- function(id, ##----------- get original data level X = pgx$X if(hm_level()=="geneset") X <- pgx$gsetX - + ##----------- for each gene cluster compute average correlation - idxx = setdiff(idx, c(NA," "," ")) + idxx = setdiff(idx, c(NA," "," ")) rho <- matrix(NA, nrow(ref), length(idxx)) colnames(rho) <- idxx rownames(rho) <- rownames(ref) - + i=1 if(nrow(ref)>0) { for(i in 1:length(idxx)) { @@ -201,18 +201,18 @@ clustannot_server <- function(id, return(rho) }) - ##-------------------------------------------------------------------- - ## Plot - ##-------------------------------------------------------------------- + + ## Plot ########## + plot_data <- shiny::reactive({ get_annot_correlation() }) - plot.RENDER <- function() { + plot.RENDER <- function() { rho <- plot_data() - shiny::req(rho) - + shiny::req(rho) + NTERMS = 6 NTERMS = 12 slen=40 @@ -225,22 +225,22 @@ clustannot_server <- function(id, if(ncol(rho)<=2) { NTERMS=22 } - + klrpal = rep(RColorBrewer::brewer.pal(8,"Set2"),2) ##klrpal = paste0(klrpal,"88") col.addalpha <- function(clr,a=100) paste0("rgba(",paste(col2rgb(clr)[,1],collapse=","),",",a,")") ##klrpal = as.character(sapply(klrpal, col.addalpha, a=50)) klrpal <- paste0(klrpal,"55") - + plot_list <- list() - i=1 + i=1 for(i in 1:min(9,ncol(rho))) { - + x = rev(head(sort(rho[,i],decreasing=TRUE),NTERMS)) names(x) = sub(".*:","",names(x)) names(x) = gsub(GSET.PREFIX.REGEX,"",names(x)) - + y = names(x) y = factor(y, levels=y) anntitle <- function(tt) { @@ -249,10 +249,10 @@ clustannot_server <- function(id, yanchor = "bottom", xanchor = "center", align = "center", x=0.5, y=1.02 , showarrow = FALSE ) } - + ## NOTE: The same plotly code (originally) as in `clustering_server.R` ## -> Seems it uses the function from that file, not this one - ## TODO: clean-up; we should stick to the general setup of individual + ## TODO: clean-up; we should stick to the general setup of individual ## scripts for the plotting functions plot_list[[i]] <- plotly::plot_ly( x=x, y=y, type='bar', orientation='h', @@ -282,28 +282,28 @@ clustannot_server <- function(id, ## labeling the y-axis inside bars plotly::add_annotations(xref = 'paper', yref = 'y', x = 0.01, y = y, xanchor='left', - text = shortstring(y,slen), + text = shortstring(y,slen), font = list(size = 10), showarrow = FALSE, align = 'right') ##layout(margin = c(0,0,0,0)) } - + if(length(plot_list) <= 4) { nrows = ceiling(length(plot_list)/2 ) } else { nrows = ceiling(length(plot_list)/3 ) } - + plotly::subplot( plot_list, nrows=nrows, shareX=TRUE, ## template = "plotly_dark", margin = c(0, 0.0, 0.05, 0.05) ) %>% - plotly::config(displayModeBar = FALSE) + plotly::config(displayModeBar = FALSE) } modal_plot.RENDER <- function() { plot.RENDER() } - + PlotModuleServer( "pltmod", ##plotlib = "plotly", @@ -312,21 +312,20 @@ clustannot_server <- function(id, func2 = modal_plot.RENDER, csvFunc = plot_data, ## *** downloadable data as CSV renderFunc = plotly::renderPlotly, - renderFunc2 = plotly::renderPlotly, + renderFunc2 = plotly::renderPlotly, res = c(90,170), ## resolution of plots pdf.width = 8, pdf.height = 5, add.watermark = watermark ) - ##-------------------------------------------------------------------- - ## Table - ##-------------------------------------------------------------------- + + ## Table ########## table.RENDER <- shiny::reactive({ - + rho <- get_annot_correlation() if(is.null(rho)) return(NULL) - + ##rownames(rho) = shortstring(rownames(rho),50) rho.name = shortstring(sub(".*:","",rownames(rho)),60) ##rho = data.frame(cbind( name=rho.name, rho)) @@ -335,7 +334,7 @@ clustannot_server <- function(id, if(input$xann_level=="geneset") { df$feature <- wrapHyperLink(df$feature, rownames(df)) } - + DT::datatable( df, rownames=FALSE, escape = c(-1,-2), extensions = c('Buttons','Scroller'), @@ -350,17 +349,17 @@ clustannot_server <- function(id, scrollY = '70vh', scroller=TRUE, deferRender=TRUE - ) ## end of options.list + ) ## end of options.list ) %>% - DT::formatStyle(0, target='row', fontSize='11px', lineHeight='70%') + DT::formatStyle(0, target='row', fontSize='11px', lineHeight='70%') }) table_info_text = "In this table, users can check mean correlation values of features in the clusters with respect to the annotation references database selected in the settings." - + ##clustannot_table_module <- tableModule( clustannot_table_module <- shiny::callModule( - tableModule, - id = "clustannot_table", + tableModule, + id = "clustannot_table", func = table.RENDER, ##options = clustannot_table_opts, info.text = table_info_text, @@ -369,7 +368,7 @@ clustannot_server <- function(id, ##caption = clustannot_caption ) - + }) } diff --git a/components/board.clustering/R/plot_clustpca.R b/components/board.clustering/R/plot_clustpca.R index 2d8566805..d9093b2c9 100644 --- a/components/board.clustering/R/plot_clustpca.R +++ b/components/board.clustering/R/plot_clustpca.R @@ -4,9 +4,8 @@ ## -##================================================================================ -## Annotate clusters -##================================================================================ + +## Annotate clusters ############ plot_clustpca_ui <- function(id, label='', @@ -64,9 +63,8 @@ plot_clustpca_server <- function(id, moduleServer( id, function(input, output, session) { ns <- session$ns - ##-------------------------------------------------------------------- - ## Functions - ##-------------------------------------------------------------------- + ## Functions ############ + hm_getClusterPositions <- shiny::reactive({ dbg("[plot_clustpca_server:hm_getClusterPositions] reacted!") @@ -141,10 +139,8 @@ plot_clustpca_server <- function(id, return(clust) }) + ## Plot ############ - ##-------------------------------------------------------------------- - ## Plot - ##-------------------------------------------------------------------- plot_data <- shiny::reactive({ dbg("[plot_clustpca_server:plot_data] reacted!") clust <- hm_getClusterPositions() From bd01023d6f3344dc31207abc18c739de2ab9f4b1 Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Fri, 17 Feb 2023 13:57:36 +0100 Subject: [PATCH 04/44] refactoring hm_splitmap --- .../R/clustering_plot_hm_splitmap.R | 419 +++++++++++ .../board.clustering/R/clustering_server.R | 709 +++++++++--------- components/board.clustering/R/clustering_ui.R | 9 +- 3 files changed, 786 insertions(+), 351 deletions(-) create mode 100644 components/board.clustering/R/clustering_plot_hm_splitmap.R diff --git a/components/board.clustering/R/clustering_plot_hm_splitmap.R b/components/board.clustering/R/clustering_plot_hm_splitmap.R new file mode 100644 index 000000000..6571edabd --- /dev/null +++ b/components/board.clustering/R/clustering_plot_hm_splitmap.R @@ -0,0 +1,419 @@ +## +## This file is part of the Omics Playground project. +## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. +## + +#' Clustering plot UI input function +#' +#' @description A shiny Module for plotting (UI code). +#' +#' @param id +#' @param label +#' @param height +#' @param width +#' +#' @export +clustering_plot_hm_splitmap_ui <- function(id, + label = "", + height, + width) { + ns <- shiny::NS(id) + + topmodes <- c("sd","pca","specific") + + hm_splitmap_opts = shiny::tagList( + withTooltip( shiny::radioButtons(ns("hm_plottype"), "Plot type:", + choices=c("ComplexHeatmap","iHeatmap"), + selected="ComplexHeatmap", inline=TRUE, width='100%'), + "Choose plot type: ComplexHeatmap (static) or iHeatmap (interactive)", + placement="right",options = list(container = "body")), + withTooltip( shiny::radioButtons( + ns("hm_splitby"), "Split samples by:", inline=TRUE, + ## selected="phenotype", + choices=c("none","phenotype","gene")), + "Split the samples by phenotype or expression level of a gene.", + placement="right",options = list(container = "body")), + shiny::conditionalPanel( + "input.hm_splitby != 'none'", ns=ns, + withTooltip( shiny::selectInput(ns("hm_splitvar"), NULL, choices=""), + "Specify phenotype or gene for splitting the columns of the heatmap.", + placement="right",options = list(container = "body")), + ), + shiny::fillRow( + height = 50, + withTooltip( shiny::selectInput(ns('hm_topmode'),'Top mode:',topmodes, width='100%'), + "Specify the criteria for selecting top features to be shown in the heatmap.", + placement = "right", options = list(container = "body")), + withTooltip( shiny::selectInput(ns('hm_ntop'),'Top N:',c(50,150,500),selected=50), + "Select the number of top features in the heatmap.", + placement="right", options = list(container = "body")), + withTooltip( shiny::selectInput(ns('hm_clustk'),'K:',1:6,selected=4), + "Select the number of gene clusters.", + placement="right", options = list(container = "body")) + ), + ##br(), + withTooltip( shiny::radioButtons( + ns('hm_scale'), 'Scale:', choices=c('relative','absolute','BMC'), inline=TRUE), + ## ns('hm_scale'), 'Scale:', choices=c('relative','absolute'), inline=TRUE), + "Show relative (i.e. mean-centered), absolute expression values or batch-mean-centered.", + placement="right", options = list(container = "body")), + withTooltip( shiny::checkboxInput( + ns('hm_legend'), 'show legend', value=TRUE), "Show or hide the legend.", + placement="right", options = list(container = "body")), + shiny::fillRow( + height = 50, + ## shiny::checkboxInput(ns("hm_labRow"),NULL), + withTooltip( shiny::numericInput(ns("hm_cexRow"), "cexRow:", 1, 0, 1.4, 0.1, width='100%'), + "Specify the row label size. Set to 0 to suppress row labels.", + placement="right",options = list(container = "body")), + withTooltip( shiny::numericInput(ns("hm_cexCol"), "cexCol:", 1, 0, 1.4, 0.1, width='100%'), + "Specify the column label size. Set to 0 to suppress column labels.", + placement="right", options = list(container = "body")) + ), + shiny::br() + ) + + info_text <- "Under the Heatmap panel, hierarchical clustering can be performed on gene level or gene set level expression in which users have to specify it under the {Level} dropdown list.

Under the plot configuration {{Settings}}, users can split the samples by a phenotype class (e.g., tissue, cell type, or gender) using the {split by} setting. In addition, users can specify the top N = (50, 150, 500) features to be used in the heatmap. The ordering of top features is selected under {top mode}. The criteria to select the top features are:

  1. SD - features with the highest standard deviation across all the samples,
  2. specific - features that are overexpressed in each phenotype class compared to the rest, or by
  3. PCA - by principal components.

Users can also choose between 'relative' or 'absolute' expression scale. Under the {cexCol} and {cexRow} settings, it is also possible to adjust the cex for the column and row labels." + + PlotModuleUI( + ns("pltmod"), + title = "Clustered Heatmap", + label = label, + plotlib = "generic", #generic + outputFunc = plotly::plotlyOutput, #"uiOutput" + outputFunc2 = plotly::plotlyOutput, #"uiOutput", + info.text = info_text, + options = hm_splitmap_opts, + download.fmt = c("png", "pdf", "csv"), + width = width, + height = height + ) +} + +#' Clustering plot Server function +#' +#' @description A shiny Module for plotting (server code). +#' +#' @param id +#' @param watermark +#' +#' +#' +#' @export +clustering_plot_hm_splitmap_server <- function(id, + getTopMatrix, + watermark = FALSE) { + moduleServer(id, function(input, output, session) { + + fullH <- 850 + + ns <- session$ns + + # reactive function listening for changes in input + topmodes <- c("sd","pca","specific") + + plot_data_hm1 <- shiny::reactive({ + + ## ComplexHeatmap based splitted heatmap ########## + + filt <- getTopMatrix() + shiny::req(filt) + ##if(is.null(filt)) return(NULL) + + ##if(input$hm_group) { + zx <- filt$mat + annot = filt$annot + zx.idx <- filt$idx + + return(list( + zx = zx, + annot = annot, + zx.idx = zx.idx + )) + }) + + hm1_splitmap.RENDER<- function() { + pd <- plot_data_hm1() + + zx = pd[["zx"]] + annot = pd[["annot"]] + zx.idx = pd[["zx.idx"]] + + + if(nrow(zx) <= 1) return(NULL) + + show_rownames = TRUE + if(nrow(zx) > 100) show_rownames = FALSE + + cex1 = ifelse(ncol(zx)>50,0.75,1) + cex1 = ifelse(ncol(zx)>100,0.5,cex1) + cex1 = ifelse(ncol(zx)>200,0,cex1) + + scale.mode = "none" + if(input$hm_scale=="relative") scale.mode <- "row.center" + if(input$hm_scale=="BMC") scale.mode <- "row.bmc" + scale.mode + + ## split genes dimension in 5 groups + splity = 5 + splity = 6 + if(!is.null(zx.idx)) splity = zx.idx + + ## split samples + splitx = NULL + splitx = filt$grp + + show_legend=show_colnames=TRUE + show_legend <- input$hm_legend + if(input$hm_level=="geneset" || !is.null(splitx)) show_legend = FALSE + + annot$group = NULL ## no group in annotation?? + show_colnames <- (input$hm_cexCol != 0) + ##if(ncol(zx) > 200) show_colnames <- FALSE ## never... + + if(input$hm_level=="gene") { + ## strip any prefix + rownames(zx) = sub(".*:","",rownames(zx)) + } + rownames(zx) <- sub("HALLMARK:HALLMARK_","HALLMARK:",rownames(zx)) + rownames(zx) = gsub(GSET.PREFIX.REGEX,"",rownames(zx)) + rownames(zx) = substring(rownames(zx),1,50) ## cut long names... + if(input$hm_level=="geneset") rownames(zx) <- tolower(rownames(zx)) + + cex2 <- ifelse( nrow(zx) > 60, 0.8, 0.9) + cex1 <- as.numeric(input$hm_cexCol)*0.85 + cex2 <- as.numeric(input$hm_cexRow)*0.75 + cex0 <- ifelse(!is.null(splitx) && length(splitx)<=10, 1.05, 0.85) ## title + + crot <- 0 + totnchar <- nchar(paste0(unique(splitx),collapse="")) + totnchar + nx <- length(unique(splitx)) + if(!is.null(splitx) & (totnchar > 44 || nx>=6) ) crot=90 + + nrownames = 60 + nrownames = 9999 + if(input$hm_cexRow==0) nrownames <- 0 + + shiny::showNotification('rendering heatmap...') + plt <- grid::grid.grabExpr( + gx.splitmap( + zx, + split = splity, splitx = splitx, + scale = scale.mode, show_legend = show_legend, + show_colnames = show_colnames, column_title_rot = crot, + column_names_rot = 45, + show_rownames = nrownames, rownames_width = 40, + softmax = 0, + ## side.height.fraction=0.03+0.055*NCOL(annot), + title_cex = cex0, cexCol = cex1, cexRow = cex2, + col.annot = annot, row.annot = NULL, annot.ht = 2.3, + key.offset = c(0.89,1.01), + main=" ", nmax = -1, mar = c(8,16) + ) + ) + plt + + } + + hm2_splitmap.RENDER<- function() { + + ## iHeatmap based splitted heatmap ######### + + shiny::req(pgx$genes) + + ## -------------- variable to split samples + ##scale = ifelse(input$hm_scale=="relative","row.center","none") + scale = "none" + if(input$hm_scale=="relative") scale <- "row.center" + if(input$hm_scale=="BMC") scale <- "row.bmc" + + plt <- NULL + + filt <- getTopMatrix() + ##if(is.null(filt)) return(NULL) + shiny::req(filt) + + ##if(input$hm_group) { + X <- filt$mat + annot = filt$annot + idx <- filt$idx + + ## sample clustering index + splitx <- NULL + splitx <- filt$grp + + ## iheatmapr needs factors for sharing between groups + annotF <- data.frame(as.list(annot),stringsAsFactors=TRUE) + rownames(annotF) = rownames(annot) + + colcex <- as.numeric(input$hm_cexCol) + rowcex = as.numeric(input$hm_cexRow) + + tooltips = NULL + if(input$hm_level=="gene") { + getInfo <- function(g) { + aa = paste0("",pgx$genes[g,"gene_name"],". ", + ## pgx$genes[g,"map"],". ", + pgx$genes[g,"gene_title"],".") + breakstring2(aa, 50, brk="
") + } + tooltips = sapply(rownames(X), getInfo) + } else { + aa = gsub("_"," ",rownames(X)) ## just geneset names + tooltips = breakstring2(aa, 50, brk="
") + } + ##genetips = rownames(X) + + shiny::showNotification('rendering iHeatmap...') + + plt <- pgx.splitHeatmapFromMatrix( + X=X, annot=annotF, ytips=tooltips, + idx=idx, splitx=splitx, scale=scale, + row_annot_width=0.03, rowcex=rowcex, + colcex=colcex ) + + return(plt) + + } + + + output$hm1_splitmap <- shiny::renderPlot({ + plt <- hm1_splitmap.RENDER() + grid::grid.draw(plt, recording=FALSE) + }, res=90) + + output$hm2_splitmap <- renderIheatmap({ + hm2_splitmap.RENDER() + }) + + hm_splitmap.switchRENDER <- shiny::reactive({ + ##req(input$hm_plottype) + p = NULL + if(input$hm_plottype %in% c("ComplexHeatmap","static") ) { + p = shiny::plotOutput(ns("hm1_splitmap"), height=fullH-80) ## height defined here!! + } else { + p = iheatmaprOutput(ns("hm2_splitmap"), height=fullH-80) ## height defined here!! + } + return(p) + }) + + ##output$hm_splitmap_pdf <- shiny::downloadHandler( + hm_splitmap_downloadPDF <- shiny::downloadHandler( + filename = "plot.pdf", + content = function(file) { + ##PDFFILE = hm_splitmap_module$.tmpfile["pdf"] ## from above! + PDFFILE = paste0(gsub("file","plot",tempfile()),".pdf") + dbg("[ClusteringBoard] hm_splitmap_downloadPDF: exporting SWITCH to PDF...") + ##showNotification("exporting to PDF") + ##wd <- input$hm_pdfwidth + ##ht <- input$hm_pdfheight + ##wd <- input$pdf_width + ##ht <- input$pdf_height + wd <- input[["hm_splitmap-pdf_width"]] ## ugly!! + ht <- input[["hm_splitmap-pdf_height"]] ## ugly!! + + if(1 && input$hm_plottype %in% c("ComplexHeatmap","static")) { + pdf(PDFFILE, width=wd, height=ht) + grid::grid.draw(hm1_splitmap.RENDER()) + ##print(hm1_splitmap.RENDER()) + ##hm1_splitmap.RENDER() + dev.off() + } else { + save_iheatmap(hm2_splitmap.RENDER(), filename=PDFFILE, + vwidth=wd*100, vheight=ht*100) + } + if(WATERMARK) { + dbg("[ClusteringBoard] adding watermark to PDF...\n") + addWatermark.PDF(PDFFILE) ## from pgx-modules.R + } + dbg("[ClusteringBoard] hm_splitmap_downloadPDF: exporting done...") + file.copy(PDFFILE,file) + } + ) + + hm_splitmap_downloadPNG <- shiny::downloadHandler( + filename = "plot.png", + content = function(file) { + PNGFILE = paste0(gsub("file","plot",tempfile()),".png") + dbg("[ClusteringBoard] hm_splitmap_downloadPDF:: exporting SWITCH to PNG...") + ##showNotification("exporting to PNG") + wd <- 100*as.integer(input[["hm_splitmap-pdf_width"]]) + ht <- 100*as.integer(input[["hm_splitmap-pdf_height"]]) + if(1 && input$hm_plottype %in% c("ComplexHeatmap","static")) { + png(PNGFILE, width=wd, height=ht, pointsize=24) + grid::grid.draw(hm1_splitmap.RENDER()) + ##print(hm1_splitmap.RENDER()) ## should be done inside render for base plot... + ##hm1_splitmap.RENDER() ## should be done inside render for base plot... + ##plot(sin) + dev.off() + } else { + save_iheatmap(hm2_splitmap.RENDER(), filename=PNGFILE, vwidth=wd, vheight=ht) + } + dbg("[ClusteringBoard] hm_splitmap_downloadPNG: exporting done...") + file.copy(PNGFILE,file) + } + ) + + # hm_splitmap_downloadHTML <- shiny::downloadHandler( + # filename = "plot.html", + # content = function(file) { + # ##HTMLFILE = hm_splitmap_module$.tmpfile["html"] ## from above! + # HTMLFILE = paste0(gsub("file","plot",tempfile()),".html") + # dbg("renderIheatmap:: exporting SWITCH to HTML...") + # shiny::withProgress({ + # ##write("HTML export error", file=HTMLFILE) + # p <- hm2_splitmap.RENDER() + # shiny::incProgress(0.5) + # save_iheatmap(p, filename=HTMLFILE) + # }, message="exporting to HTML", value=0 ) + # dbg("renderIheatmap:: ... exporting done") + # file.copy(HTMLFILE,file) + # } + # ) + + PlotModuleServer( + "pltmod", + plotlib = "generic", + func = hm_splitmap.switchRENDER, + renderFunc = shiny::renderUI, + renderFunc2 = shiny::renderUI, + func2 = hm_splitmap.switchRENDER, + res = c(80, 95), ## resolution of plots + pdf.width = 10, pdf.height = 8, + download.pdf = hm_splitmap_downloadPDF, + download.png = hm_splitmap_downloadPNG, + add.watermark = watermark + + ) + + + # ## call plotModule + # hm_splitmap_module <- shiny::callModule( + # plotModule, + # id = "hm_splitmap", + # func = hm_splitmap.switchRENDER, ## ns=ns, + # ## func2 = hm_splitmap.switchRENDER, ## ns=ns, + # show.maximize = FALSE, + # plotlib = "generic", + # renderFunc = "renderUI", + # outputFunc = "uiOutput", + # download.fmt = c("pdf","png"), + # options = hm_splitmap_opts, + # height = fullH-80, ##??? + # width = '100%', + # pdf.width = 10, pdf.height = 8, + # title ="Clustered Heatmap", + # info.text = hm_splitmap_text, + # info.width = "350px", + # ## caption = hm_splitmap_caption, + # download.pdf = hm_splitmap_downloadPDF, + # download.png = hm_splitmap_downloadPNG, + # download.html = hm_splitmap_downloadHTML, + # # add.watermark = WATERMARK + # ) + # + + + }) ## end of moduleServer +} diff --git a/components/board.clustering/R/clustering_server.R b/components/board.clustering/R/clustering_server.R index 7562a00c8..610291609 100644 --- a/components/board.clustering/R/clustering_server.R +++ b/components/board.clustering/R/clustering_server.R @@ -473,358 +473,367 @@ The Clustering Analysis module performs unsupervised clustering }) - # functions ########## - - hm_splitmap_text = tagsub("Under the Heatmap panel, hierarchical clustering can be performed on gene level or gene set level expression in which users have to specify it under the {Level} dropdown list.

Under the plot configuration {{Settings}}, users can split the samples by a phenotype class (e.g., tissue, cell type, or gender) using the {split by} setting. In addition, users can specify the top N = (50, 150, 500) features to be used in the heatmap. The ordering of top features is selected under {top mode}. The criteria to select the top features are:

  1. SD - features with the highest standard deviation across all the samples,
  2. specific - features that are overexpressed in each phenotype class compared to the rest, or by
  3. PCA - by principal components.

Users can also choose between 'relative' or 'absolute' expression scale. Under the {cexCol} and {cexRow} settings, it is also possible to adjust the cex for the column and row labels.") - - hm1_splitmap.RENDER <- shiny::reactive({ - - ## ComplexHeatmap based splitted heatmap ########## - - filt <- getTopMatrix() - shiny::req(filt) - ##if(is.null(filt)) return(NULL) - - ##if(input$hm_group) { - zx <- filt$mat - annot = filt$annot - zx.idx <- filt$idx - - if(nrow(zx) <= 1) return(NULL) - - show_rownames = TRUE - if(nrow(zx) > 100) show_rownames = FALSE - - cex1 = ifelse(ncol(zx)>50,0.75,1) - cex1 = ifelse(ncol(zx)>100,0.5,cex1) - cex1 = ifelse(ncol(zx)>200,0,cex1) - - scale.mode = "none" - if(input$hm_scale=="relative") scale.mode <- "row.center" - if(input$hm_scale=="BMC") scale.mode <- "row.bmc" - scale.mode - - ## split genes dimension in 5 groups - splity = 5 - splity = 6 - if(!is.null(zx.idx)) splity = zx.idx - - ## split samples - splitx = NULL - splitx = filt$grp - - show_legend=show_colnames=TRUE - show_legend <- input$hm_legend - if(input$hm_level=="geneset" || !is.null(splitx)) show_legend = FALSE - - annot$group = NULL ## no group in annotation?? - show_colnames <- (input$hm_cexCol != 0) - ##if(ncol(zx) > 200) show_colnames <- FALSE ## never... - - if(input$hm_level=="gene") { - ## strip any prefix - rownames(zx) = sub(".*:","",rownames(zx)) - } - rownames(zx) <- sub("HALLMARK:HALLMARK_","HALLMARK:",rownames(zx)) - rownames(zx) = gsub(GSET.PREFIX.REGEX,"",rownames(zx)) - rownames(zx) = substring(rownames(zx),1,50) ## cut long names... - if(input$hm_level=="geneset") rownames(zx) <- tolower(rownames(zx)) - - cex2 <- ifelse( nrow(zx) > 60, 0.8, 0.9) - cex1 <- as.numeric(input$hm_cexCol)*0.85 - cex2 <- as.numeric(input$hm_cexRow)*0.75 - cex0 <- ifelse(!is.null(splitx) && length(splitx)<=10, 1.05, 0.85) ## title - - crot <- 0 - totnchar <- nchar(paste0(unique(splitx),collapse="")) - totnchar - nx <- length(unique(splitx)) - if(!is.null(splitx) & (totnchar > 44 || nx>=6) ) crot=90 - - nrownames = 60 - nrownames = 9999 - if(input$hm_cexRow==0) nrownames <- 0 - - if(0) { - split=splity;splitx=splitx;mar=c(5,25); scale=scale.mode; show_legend=show_legend; - show_colnames = show_colnames; column_title_rot=crot; - show_rownames = nrownames; softmax=0; - ## side.height.fraction=0.03+0.055*NCOL(annot); - cexCol=cex1; cexRow=cex2;title_cex=1.0 - col.annot=annot; row.annot=NULL; annot.ht=2.2; - nmax=-1 - } - - if(0) { - dbg("[hm1_splitmap.RENDER] rendering heatmap...") - dbg("[hm1_splitmap.RENDER] dim(annot) = ", paste(dim(annot),collapse="x")) - dbg("[hm1_splitmap.RENDER] rownames(annot) = ", rownames(annot)) - dbg("[hm1_splitmap.RENDER] colnames(annot) = ", colnames(annot)) - dbg("[hm1_splitmap.RENDER] splitx = ", paste(splitx,collapse=" ")) - dbg("[hm1_splitmap.RENDER] splity = ", paste(splity,collapse=" ")) - } - shiny::showNotification('rendering heatmap...') - plt <- grid::grid.grabExpr( - gx.splitmap( - zx, - split = splity, splitx = splitx, - scale = scale.mode, show_legend = show_legend, - show_colnames = show_colnames, column_title_rot = crot, - column_names_rot = 45, - show_rownames = nrownames, rownames_width = 40, - softmax = 0, - ## side.height.fraction=0.03+0.055*NCOL(annot), - title_cex = cex0, cexCol = cex1, cexRow = cex2, - col.annot = annot, row.annot = NULL, annot.ht = 2.3, - key.offset = c(0.89,1.01), - main=" ", nmax = -1, mar = c(8,16) - ) - ) - plt - }) - - hm2_splitmap.RENDER <- shiny::reactive({ - - - ## iHeatmap based splitted heatmap ######### - - shiny::req(pgx$genes) - - ## -------------- variable to split samples - ##scale = ifelse(input$hm_scale=="relative","row.center","none") - scale = "none" - if(input$hm_scale=="relative") scale <- "row.center" - if(input$hm_scale=="BMC") scale <- "row.bmc" - scale - - plt <- NULL - - filt <- getTopMatrix() - ##if(is.null(filt)) return(NULL) - shiny::req(filt) - - ##if(input$hm_group) { - X <- filt$mat - annot = filt$annot - idx <- filt$idx - - ## sample clustering index - splitx <- NULL - splitx <- filt$grp - - ## iheatmapr needs factors for sharing between groups - annotF <- data.frame(as.list(annot),stringsAsFactors=TRUE) - rownames(annotF) = rownames(annot) - - colcex <- as.numeric(input$hm_cexCol) - rowcex = as.numeric(input$hm_cexRow) - - tooltips = NULL - if(input$hm_level=="gene") { - getInfo <- function(g) { - aa = paste0("",pgx$genes[g,"gene_name"],". ", - ## pgx$genes[g,"map"],". ", - pgx$genes[g,"gene_title"],".") - breakstring2(aa, 50, brk="
") - } - tooltips = sapply(rownames(X), getInfo) - } else { - aa = gsub("_"," ",rownames(X)) ## just geneset names - tooltips = breakstring2(aa, 50, brk="
") - } - ##genetips = rownames(X) - - shiny::showNotification('rendering iHeatmap...') - - plt <- pgx.splitHeatmapFromMatrix( - X=X, annot=annotF, ytips=tooltips, - idx=idx, splitx=splitx, scale=scale, - row_annot_width=0.03, rowcex=rowcex, - colcex=colcex ) - - ## DOES NOT WORK... - ##plt <- plt %>% - ## plotly::config(toImageButtonOptions = list(format='svg', height=800, width=800)) - - return(plt) - }) - - topmodes <- c("sd","pca","specific") + # plots ########## + + clustering_plot_hm_splitmap_server(id = "hm_splitmap", + getTopMatrix = getTopMatrix, + watermark = FALSE) + + + # start hm_splitmap refactoring ######## + + # hm_splitmap_text = tagsub("Under the Heatmap panel, hierarchical clustering can be performed on gene level or gene set level expression in which users have to specify it under the {Level} dropdown list.

Under the plot configuration {{Settings}}, users can split the samples by a phenotype class (e.g., tissue, cell type, or gender) using the {split by} setting. In addition, users can specify the top N = (50, 150, 500) features to be used in the heatmap. The ordering of top features is selected under {top mode}. The criteria to select the top features are:

  1. SD - features with the highest standard deviation across all the samples,
  2. specific - features that are overexpressed in each phenotype class compared to the rest, or by
  3. PCA - by principal components.

Users can also choose between 'relative' or 'absolute' expression scale. Under the {cexCol} and {cexRow} settings, it is also possible to adjust the cex for the column and row labels.") + + # hm1_splitmap.RENDER <- shiny::reactive({ + # + # ## ComplexHeatmap based splitted heatmap ########## + # + # filt <- getTopMatrix() + # shiny::req(filt) + # ##if(is.null(filt)) return(NULL) + # + # ##if(input$hm_group) { + # zx <- filt$mat + # annot = filt$annot + # zx.idx <- filt$idx + # + # if(nrow(zx) <= 1) return(NULL) + # + # show_rownames = TRUE + # if(nrow(zx) > 100) show_rownames = FALSE + # + # cex1 = ifelse(ncol(zx)>50,0.75,1) + # cex1 = ifelse(ncol(zx)>100,0.5,cex1) + # cex1 = ifelse(ncol(zx)>200,0,cex1) + # + # scale.mode = "none" + # if(input$hm_scale=="relative") scale.mode <- "row.center" + # if(input$hm_scale=="BMC") scale.mode <- "row.bmc" + # scale.mode + # + # ## split genes dimension in 5 groups + # splity = 5 + # splity = 6 + # if(!is.null(zx.idx)) splity = zx.idx + # + # ## split samples + # splitx = NULL + # splitx = filt$grp + # + # show_legend=show_colnames=TRUE + # show_legend <- input$hm_legend + # if(input$hm_level=="geneset" || !is.null(splitx)) show_legend = FALSE + # + # annot$group = NULL ## no group in annotation?? + # show_colnames <- (input$hm_cexCol != 0) + # ##if(ncol(zx) > 200) show_colnames <- FALSE ## never... + # + # if(input$hm_level=="gene") { + # ## strip any prefix + # rownames(zx) = sub(".*:","",rownames(zx)) + # } + # rownames(zx) <- sub("HALLMARK:HALLMARK_","HALLMARK:",rownames(zx)) + # rownames(zx) = gsub(GSET.PREFIX.REGEX,"",rownames(zx)) + # rownames(zx) = substring(rownames(zx),1,50) ## cut long names... + # if(input$hm_level=="geneset") rownames(zx) <- tolower(rownames(zx)) + # + # cex2 <- ifelse( nrow(zx) > 60, 0.8, 0.9) + # cex1 <- as.numeric(input$hm_cexCol)*0.85 + # cex2 <- as.numeric(input$hm_cexRow)*0.75 + # cex0 <- ifelse(!is.null(splitx) && length(splitx)<=10, 1.05, 0.85) ## title + # + # crot <- 0 + # totnchar <- nchar(paste0(unique(splitx),collapse="")) + # totnchar + # nx <- length(unique(splitx)) + # if(!is.null(splitx) & (totnchar > 44 || nx>=6) ) crot=90 + # + # nrownames = 60 + # nrownames = 9999 + # if(input$hm_cexRow==0) nrownames <- 0 + # + # if(0) { + # split=splity;splitx=splitx;mar=c(5,25); scale=scale.mode; show_legend=show_legend; + # show_colnames = show_colnames; column_title_rot=crot; + # show_rownames = nrownames; softmax=0; + # ## side.height.fraction=0.03+0.055*NCOL(annot); + # cexCol=cex1; cexRow=cex2;title_cex=1.0 + # col.annot=annot; row.annot=NULL; annot.ht=2.2; + # nmax=-1 + # } + # + # if(0) { + # dbg("[hm1_splitmap.RENDER] rendering heatmap...") + # dbg("[hm1_splitmap.RENDER] dim(annot) = ", paste(dim(annot),collapse="x")) + # dbg("[hm1_splitmap.RENDER] rownames(annot) = ", rownames(annot)) + # dbg("[hm1_splitmap.RENDER] colnames(annot) = ", colnames(annot)) + # dbg("[hm1_splitmap.RENDER] splitx = ", paste(splitx,collapse=" ")) + # dbg("[hm1_splitmap.RENDER] splity = ", paste(splity,collapse=" ")) + # } + # shiny::showNotification('rendering heatmap...') + # plt <- grid::grid.grabExpr( + # gx.splitmap( + # zx, + # split = splity, splitx = splitx, + # scale = scale.mode, show_legend = show_legend, + # show_colnames = show_colnames, column_title_rot = crot, + # column_names_rot = 45, + # show_rownames = nrownames, rownames_width = 40, + # softmax = 0, + # ## side.height.fraction=0.03+0.055*NCOL(annot), + # title_cex = cex0, cexCol = cex1, cexRow = cex2, + # col.annot = annot, row.annot = NULL, annot.ht = 2.3, + # key.offset = c(0.89,1.01), + # main=" ", nmax = -1, mar = c(8,16) + # ) + # ) + # plt + # }) + + # hm2_splitmap.RENDER <- shiny::reactive({ + # + # + # ## iHeatmap based splitted heatmap ######### + # + # shiny::req(pgx$genes) + # + # ## -------------- variable to split samples + # ##scale = ifelse(input$hm_scale=="relative","row.center","none") + # scale = "none" + # if(input$hm_scale=="relative") scale <- "row.center" + # if(input$hm_scale=="BMC") scale <- "row.bmc" + # scale + # + # plt <- NULL + # + # filt <- getTopMatrix() + # ##if(is.null(filt)) return(NULL) + # shiny::req(filt) + # + # ##if(input$hm_group) { + # X <- filt$mat + # annot = filt$annot + # idx <- filt$idx + # + # ## sample clustering index + # splitx <- NULL + # splitx <- filt$grp + # + # ## iheatmapr needs factors for sharing between groups + # annotF <- data.frame(as.list(annot),stringsAsFactors=TRUE) + # rownames(annotF) = rownames(annot) + # + # colcex <- as.numeric(input$hm_cexCol) + # rowcex = as.numeric(input$hm_cexRow) + # + # tooltips = NULL + # if(input$hm_level=="gene") { + # getInfo <- function(g) { + # aa = paste0("",pgx$genes[g,"gene_name"],". ", + # ## pgx$genes[g,"map"],". ", + # pgx$genes[g,"gene_title"],".") + # breakstring2(aa, 50, brk="
") + # } + # tooltips = sapply(rownames(X), getInfo) + # } else { + # aa = gsub("_"," ",rownames(X)) ## just geneset names + # tooltips = breakstring2(aa, 50, brk="
") + # } + # ##genetips = rownames(X) + # + # shiny::showNotification('rendering iHeatmap...') + # + # plt <- pgx.splitHeatmapFromMatrix( + # X=X, annot=annotF, ytips=tooltips, + # idx=idx, splitx=splitx, scale=scale, + # row_annot_width=0.03, rowcex=rowcex, + # colcex=colcex ) + # + # ## DOES NOT WORK... + # ##plt <- plt %>% + # ## plotly::config(toImageButtonOptions = list(format='svg', height=800, width=800)) + # + # return(plt) + # }) + + # topmodes <- c("sd","pca","specific") ##if(DEV) topmodes <- c("sd","specific","pca") - hm_splitmap_opts = shiny::tagList( - withTooltip( shiny::radioButtons(ns("hm_plottype"), "Plot type:", - choices=c("ComplexHeatmap","iHeatmap"), - selected="ComplexHeatmap", inline=TRUE, width='100%'), - "Choose plot type: ComplexHeatmap (static) or iHeatmap (interactive)", - placement="right",options = list(container = "body")), - withTooltip( shiny::radioButtons( - ns("hm_splitby"), "Split samples by:", inline=TRUE, - ## selected="phenotype", - choices=c("none","phenotype","gene")), - "Split the samples by phenotype or expression level of a gene.", - placement="right",options = list(container = "body")), - shiny::conditionalPanel( - "input.hm_splitby != 'none'", ns=ns, - withTooltip( shiny::selectInput(ns("hm_splitvar"), NULL, choices=""), - "Specify phenotype or gene for splitting the columns of the heatmap.", - placement="right",options = list(container = "body")), - ), - shiny::fillRow( - height = 50, - withTooltip( shiny::selectInput(ns('hm_topmode'),'Top mode:',topmodes, width='100%'), - "Specify the criteria for selecting top features to be shown in the heatmap.", - placement = "right", options = list(container = "body")), - withTooltip( shiny::selectInput(ns('hm_ntop'),'Top N:',c(50,150,500),selected=50), - "Select the number of top features in the heatmap.", - placement="right", options = list(container = "body")), - withTooltip( shiny::selectInput(ns('hm_clustk'),'K:',1:6,selected=4), - "Select the number of gene clusters.", - placement="right", options = list(container = "body")) - ), - ##br(), - withTooltip( shiny::radioButtons( - ns('hm_scale'), 'Scale:', choices=c('relative','absolute','BMC'), inline=TRUE), - ## ns('hm_scale'), 'Scale:', choices=c('relative','absolute'), inline=TRUE), - "Show relative (i.e. mean-centered), absolute expression values or batch-mean-centered.", - placement="right", options = list(container = "body")), - withTooltip( shiny::checkboxInput( - ns('hm_legend'), 'show legend', value=TRUE), "Show or hide the legend.", - placement="right", options = list(container = "body")), - shiny::fillRow( - height = 50, - ## shiny::checkboxInput(ns("hm_labRow"),NULL), - withTooltip( shiny::numericInput(ns("hm_cexRow"), "cexRow:", 1, 0, 1.4, 0.1, width='100%'), - "Specify the row label size. Set to 0 to suppress row labels.", - placement="right",options = list(container = "body")), - withTooltip( shiny::numericInput(ns("hm_cexCol"), "cexCol:", 1, 0, 1.4, 0.1, width='100%'), - "Specify the column label size. Set to 0 to suppress column labels.", - placement="right", options = list(container = "body")) - ), - shiny::br() - ) - - hm_splitmap_caption = "Clustered heatmap. Heatmap showing gene expression sorted by 2-way hierarchical clustering. Red corresponds to overexpression, blue to underexpression of the gene. At the same time, gene clusters are functionally annotated in the 'Annotate clusters' panel on the right." - - output$hm1_splitmap <- shiny::renderPlot({ - plt <- hm1_splitmap.RENDER() - grid::grid.draw(plt, recording=FALSE) - }, res=90) - - output$hm2_splitmap <- renderIheatmap({ - hm2_splitmap.RENDER() - }) - - hm_splitmap.switchRENDER <- shiny::reactive({ - ##req(input$hm_plottype) - p = NULL - if(input$hm_plottype %in% c("ComplexHeatmap","static") ) { - p = shiny::plotOutput(ns("hm1_splitmap"), height=fullH-80) ## height defined here!! - } else { - p = iheatmaprOutput(ns("hm2_splitmap"), height=fullH-80) ## height defined here!! - } - return(p) - }) - - ##output$hm_splitmap_pdf <- shiny::downloadHandler( - hm_splitmap_downloadPDF <- shiny::downloadHandler( - filename = "plot.pdf", - content = function(file) { - ##PDFFILE = hm_splitmap_module$.tmpfile["pdf"] ## from above! - PDFFILE = paste0(gsub("file","plot",tempfile()),".pdf") - dbg("[ClusteringBoard] hm_splitmap_downloadPDF: exporting SWITCH to PDF...") - ##showNotification("exporting to PDF") - ##wd <- input$hm_pdfwidth - ##ht <- input$hm_pdfheight - ##wd <- input$pdf_width - ##ht <- input$pdf_height - wd <- input[["hm_splitmap-pdf_width"]] ## ugly!! - ht <- input[["hm_splitmap-pdf_height"]] ## ugly!! - - if(1 && input$hm_plottype %in% c("ComplexHeatmap","static")) { - pdf(PDFFILE, width=wd, height=ht) - grid::grid.draw(hm1_splitmap.RENDER()) - ##print(hm1_splitmap.RENDER()) - ##hm1_splitmap.RENDER() - dev.off() - } else { - save_iheatmap(hm2_splitmap.RENDER(), filename=PDFFILE, - vwidth=wd*100, vheight=ht*100) - } - if(WATERMARK) { - dbg("[ClusteringBoard] adding watermark to PDF...\n") - addWatermark.PDF(PDFFILE) ## from pgx-modules.R - } - dbg("[ClusteringBoard] hm_splitmap_downloadPDF: exporting done...") - file.copy(PDFFILE,file) - } - ) - - hm_splitmap_downloadPNG <- shiny::downloadHandler( - filename = "plot.png", - content = function(file) { - PNGFILE = paste0(gsub("file","plot",tempfile()),".png") - dbg("[ClusteringBoard] hm_splitmap_downloadPDF:: exporting SWITCH to PNG...") - ##showNotification("exporting to PNG") - wd <- 100*as.integer(input[["hm_splitmap-pdf_width"]]) - ht <- 100*as.integer(input[["hm_splitmap-pdf_height"]]) - if(1 && input$hm_plottype %in% c("ComplexHeatmap","static")) { - png(PNGFILE, width=wd, height=ht, pointsize=24) - grid::grid.draw(hm1_splitmap.RENDER()) - ##print(hm1_splitmap.RENDER()) ## should be done inside render for base plot... - ##hm1_splitmap.RENDER() ## should be done inside render for base plot... - ##plot(sin) - dev.off() - } else { - save_iheatmap(hm2_splitmap.RENDER(), filename=PNGFILE, vwidth=wd, vheight=ht) - } - dbg("[ClusteringBoard] hm_splitmap_downloadPNG: exporting done...") - file.copy(PNGFILE,file) - } - ) - - hm_splitmap_downloadHTML <- shiny::downloadHandler( - filename = "plot.html", - content = function(file) { - ##HTMLFILE = hm_splitmap_module$.tmpfile["html"] ## from above! - HTMLFILE = paste0(gsub("file","plot",tempfile()),".html") - dbg("renderIheatmap:: exporting SWITCH to HTML...") - shiny::withProgress({ - ##write("HTML export error", file=HTMLFILE) - p <- hm2_splitmap.RENDER() - shiny::incProgress(0.5) - save_iheatmap(p, filename=HTMLFILE) - }, message="exporting to HTML", value=0 ) - dbg("renderIheatmap:: ... exporting done") - file.copy(HTMLFILE,file) - } - ) - - - ## call plotModule - hm_splitmap_module <- shiny::callModule( - plotModule, - id = "hm_splitmap", - func = hm_splitmap.switchRENDER, ## ns=ns, - ## func2 = hm_splitmap.switchRENDER, ## ns=ns, - show.maximize = FALSE, - plotlib = "generic", - renderFunc = "renderUI", - outputFunc = "uiOutput", - download.fmt = c("pdf","png"), - options = hm_splitmap_opts, - height = fullH-80, ##??? - width = '100%', - pdf.width = 10, pdf.height = 8, - title ="Clustered Heatmap", - info.text = hm_splitmap_text, - info.width = "350px", - ## caption = hm_splitmap_caption, - download.pdf = hm_splitmap_downloadPDF, - download.png = hm_splitmap_downloadPNG, - download.html = hm_splitmap_downloadHTML, - add.watermark = WATERMARK - ) + # hm_splitmap_opts = shiny::tagList( + # withTooltip( shiny::radioButtons(ns("hm_plottype"), "Plot type:", + # choices=c("ComplexHeatmap","iHeatmap"), + # selected="ComplexHeatmap", inline=TRUE, width='100%'), + # "Choose plot type: ComplexHeatmap (static) or iHeatmap (interactive)", + # placement="right",options = list(container = "body")), + # withTooltip( shiny::radioButtons( + # ns("hm_splitby"), "Split samples by:", inline=TRUE, + # ## selected="phenotype", + # choices=c("none","phenotype","gene")), + # "Split the samples by phenotype or expression level of a gene.", + # placement="right",options = list(container = "body")), + # shiny::conditionalPanel( + # "input.hm_splitby != 'none'", ns=ns, + # withTooltip( shiny::selectInput(ns("hm_splitvar"), NULL, choices=""), + # "Specify phenotype or gene for splitting the columns of the heatmap.", + # placement="right",options = list(container = "body")), + # ), + # shiny::fillRow( + # height = 50, + # withTooltip( shiny::selectInput(ns('hm_topmode'),'Top mode:',topmodes, width='100%'), + # "Specify the criteria for selecting top features to be shown in the heatmap.", + # placement = "right", options = list(container = "body")), + # withTooltip( shiny::selectInput(ns('hm_ntop'),'Top N:',c(50,150,500),selected=50), + # "Select the number of top features in the heatmap.", + # placement="right", options = list(container = "body")), + # withTooltip( shiny::selectInput(ns('hm_clustk'),'K:',1:6,selected=4), + # "Select the number of gene clusters.", + # placement="right", options = list(container = "body")) + # ), + # ##br(), + # withTooltip( shiny::radioButtons( + # ns('hm_scale'), 'Scale:', choices=c('relative','absolute','BMC'), inline=TRUE), + # ## ns('hm_scale'), 'Scale:', choices=c('relative','absolute'), inline=TRUE), + # "Show relative (i.e. mean-centered), absolute expression values or batch-mean-centered.", + # placement="right", options = list(container = "body")), + # withTooltip( shiny::checkboxInput( + # ns('hm_legend'), 'show legend', value=TRUE), "Show or hide the legend.", + # placement="right", options = list(container = "body")), + # shiny::fillRow( + # height = 50, + # ## shiny::checkboxInput(ns("hm_labRow"),NULL), + # withTooltip( shiny::numericInput(ns("hm_cexRow"), "cexRow:", 1, 0, 1.4, 0.1, width='100%'), + # "Specify the row label size. Set to 0 to suppress row labels.", + # placement="right",options = list(container = "body")), + # withTooltip( shiny::numericInput(ns("hm_cexCol"), "cexCol:", 1, 0, 1.4, 0.1, width='100%'), + # "Specify the column label size. Set to 0 to suppress column labels.", + # placement="right", options = list(container = "body")) + # ), + # shiny::br() + # ) + + # hm_splitmap_caption = "Clustered heatmap. Heatmap showing gene expression sorted by 2-way hierarchical clustering. Red corresponds to overexpression, blue to underexpression of the gene. At the same time, gene clusters are functionally annotated in the 'Annotate clusters' panel on the right." + + # output$hm1_splitmap <- shiny::renderPlot({ + # plt <- hm1_splitmap.RENDER() + # grid::grid.draw(plt, recording=FALSE) + # }, res=90) + # + # output$hm2_splitmap <- renderIheatmap({ + # hm2_splitmap.RENDER() + # }) + # + # hm_splitmap.switchRENDER <- shiny::reactive({ + # ##req(input$hm_plottype) + # p = NULL + # if(input$hm_plottype %in% c("ComplexHeatmap","static") ) { + # p = shiny::plotOutput(ns("hm1_splitmap"), height=fullH-80) ## height defined here!! + # } else { + # p = iheatmaprOutput(ns("hm2_splitmap"), height=fullH-80) ## height defined here!! + # } + # return(p) + # }) + # + # ##output$hm_splitmap_pdf <- shiny::downloadHandler( + # hm_splitmap_downloadPDF <- shiny::downloadHandler( + # filename = "plot.pdf", + # content = function(file) { + # ##PDFFILE = hm_splitmap_module$.tmpfile["pdf"] ## from above! + # PDFFILE = paste0(gsub("file","plot",tempfile()),".pdf") + # dbg("[ClusteringBoard] hm_splitmap_downloadPDF: exporting SWITCH to PDF...") + # ##showNotification("exporting to PDF") + # ##wd <- input$hm_pdfwidth + # ##ht <- input$hm_pdfheight + # ##wd <- input$pdf_width + # ##ht <- input$pdf_height + # wd <- input[["hm_splitmap-pdf_width"]] ## ugly!! + # ht <- input[["hm_splitmap-pdf_height"]] ## ugly!! + # + # if(1 && input$hm_plottype %in% c("ComplexHeatmap","static")) { + # pdf(PDFFILE, width=wd, height=ht) + # grid::grid.draw(hm1_splitmap.RENDER()) + # ##print(hm1_splitmap.RENDER()) + # ##hm1_splitmap.RENDER() + # dev.off() + # } else { + # save_iheatmap(hm2_splitmap.RENDER(), filename=PDFFILE, + # vwidth=wd*100, vheight=ht*100) + # } + # if(WATERMARK) { + # dbg("[ClusteringBoard] adding watermark to PDF...\n") + # addWatermark.PDF(PDFFILE) ## from pgx-modules.R + # } + # dbg("[ClusteringBoard] hm_splitmap_downloadPDF: exporting done...") + # file.copy(PDFFILE,file) + # } + # ) + # + # hm_splitmap_downloadPNG <- shiny::downloadHandler( + # filename = "plot.png", + # content = function(file) { + # PNGFILE = paste0(gsub("file","plot",tempfile()),".png") + # dbg("[ClusteringBoard] hm_splitmap_downloadPDF:: exporting SWITCH to PNG...") + # ##showNotification("exporting to PNG") + # wd <- 100*as.integer(input[["hm_splitmap-pdf_width"]]) + # ht <- 100*as.integer(input[["hm_splitmap-pdf_height"]]) + # if(1 && input$hm_plottype %in% c("ComplexHeatmap","static")) { + # png(PNGFILE, width=wd, height=ht, pointsize=24) + # grid::grid.draw(hm1_splitmap.RENDER()) + # ##print(hm1_splitmap.RENDER()) ## should be done inside render for base plot... + # ##hm1_splitmap.RENDER() ## should be done inside render for base plot... + # ##plot(sin) + # dev.off() + # } else { + # save_iheatmap(hm2_splitmap.RENDER(), filename=PNGFILE, vwidth=wd, vheight=ht) + # } + # dbg("[ClusteringBoard] hm_splitmap_downloadPNG: exporting done...") + # file.copy(PNGFILE,file) + # } + # ) + # + # hm_splitmap_downloadHTML <- shiny::downloadHandler( + # filename = "plot.html", + # content = function(file) { + # ##HTMLFILE = hm_splitmap_module$.tmpfile["html"] ## from above! + # HTMLFILE = paste0(gsub("file","plot",tempfile()),".html") + # dbg("renderIheatmap:: exporting SWITCH to HTML...") + # shiny::withProgress({ + # ##write("HTML export error", file=HTMLFILE) + # p <- hm2_splitmap.RENDER() + # shiny::incProgress(0.5) + # save_iheatmap(p, filename=HTMLFILE) + # }, message="exporting to HTML", value=0 ) + # dbg("renderIheatmap:: ... exporting done") + # file.copy(HTMLFILE,file) + # } + # ) + # + # + # ## call plotModule + # hm_splitmap_module <- shiny::callModule( + # plotModule, + # id = "hm_splitmap", + # func = hm_splitmap.switchRENDER, ## ns=ns, + # ## func2 = hm_splitmap.switchRENDER, ## ns=ns, + # show.maximize = FALSE, + # plotlib = "generic", + # renderFunc = "renderUI", + # outputFunc = "uiOutput", + # download.fmt = c("pdf","png"), + # options = hm_splitmap_opts, + # height = fullH-80, ##??? + # width = '100%', + # pdf.width = 10, pdf.height = 8, + # title ="Clustered Heatmap", + # info.text = hm_splitmap_text, + # info.width = "350px", + # ## caption = hm_splitmap_caption, + # download.pdf = hm_splitmap_downloadPDF, + # download.png = hm_splitmap_downloadPNG, + # download.html = hm_splitmap_downloadHTML, + # add.watermark = WATERMARK + # ) + + # end hm_splitmap refactoring ######## ## PCA/tSNE ############ diff --git a/components/board.clustering/R/clustering_ui.R b/components/board.clustering/R/clustering_ui.R index 672bdca06..707b197e2 100644 --- a/components/board.clustering/R/clustering_ui.R +++ b/components/board.clustering/R/clustering_ui.R @@ -55,6 +55,8 @@ ClusteringInputs <- function(id) { ClusteringUI <- function(id) { ns <- shiny::NS(id) ## namespace + fullH = 850 ## full height of page + div( class = "row", ## h4("Cluster Samples"), @@ -64,7 +66,12 @@ ClusteringUI <- function(id) { shiny::tabsetPanel( id = ns("tabs1"), shiny::tabPanel("Heatmap", - plotWidget(ns("hm_splitmap")), + clustering_plot_hm_splitmap_ui(id = ns("hm_splitmap"), + label = "a", + height = fullH-80, + width = '100%'), + # plotWidget(ns("hm_splitmap")), #FIXME + tags$div( class="caption", HTML("Clustered heatmap. Heatmap showing gene expression sorted by 2-way hierarchical clustering. Red corresponds to overexpression, blue to underexpression of the gene. From 2704bd620a89e0d36b6c0f26ba9ae06b28b10609 Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Fri, 17 Feb 2023 13:58:13 +0100 Subject: [PATCH 05/44] adjust file name --- .../R/clustering_plot_PCAplot.R | 338 ++++++++++++++++++ 1 file changed, 338 insertions(+) create mode 100644 components/board.clustering/R/clustering_plot_PCAplot.R diff --git a/components/board.clustering/R/clustering_plot_PCAplot.R b/components/board.clustering/R/clustering_plot_PCAplot.R new file mode 100644 index 000000000..d9093b2c9 --- /dev/null +++ b/components/board.clustering/R/clustering_plot_PCAplot.R @@ -0,0 +1,338 @@ +## +## This file is part of the Omics Playground project. +## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. +## + + + +## Annotate clusters ############ + +plot_clustpca_ui <- function(id, + label='', + + height=c(600,800), + parent) +{ + ns <- shiny::NS(id) + + info_text = tagsub(paste0(' The PCA/tSNE panel visualizes unsupervised clustering obtained by the principal components analysis (',a_PCA,') or t-distributed stochastic embedding (',a_tSNE,') algorithms. This plot shows the relationship (or similarity) between the samples for visual analytics, where similarity is visualized as proximity of the points. Samples that are ‘similar’ will be placed close to each other. +

Users can customise the PCA/tSNE plot in the plot settings, including the {color} and {shape} of points using a phenotype class, choose t-SNE or PCA layout, label the points, or display 2D and 3D visualisation of the PCA/tSNE plot.')) + + caption = "PCA/tSNE plot. The plot visualizes the similarity in expression of samples as a scatterplot in reduced dimension (2D or 3D). Samples that are similar are clustered near to each other, while samples with different expression are positioned farther away. Groups of samples with similar profiles will appear as clusters in the plot." + + + plot_opts = shiny::tagList( + withTooltip( shiny::selectInput(parent("hmpca.colvar"), "Color/label:", choices=NULL, width='100%'), + "Set colors/labels according to a given phenotype."), + withTooltip( shiny::selectInput(parent("hmpca.shapevar"), "Shape:", choices=NULL, width='100%'), + "Set shapes according to a given phenotype."), + withTooltip( shiny::radioButtons( + ns('hmpca_legend'), label = "Legend:", + choices = c('group label','bottom'), inline=TRUE), + "Normalize matrix before calculating distances."), + withTooltip( shiny::checkboxGroupInput( ns('hmpca_options'),"Other:", + choices=c('sample label','3D','normalize'), inline=TRUE), + "Normalize matrix before calculating distances."), + withTooltip( shiny::radioButtons( ns('hm_clustmethod'),"Layout:", + c("default","tsne","pca","umap"),inline=TRUE), + "Choose the layout method for clustering to visualise.",) + ) + + PlotModuleUI( + ns("pltmod"), + title = "PCA/tSNE plot", + label = label, + plotlib = "plotly", + info.text = info_text, + caption = caption, + options = plot_opts, + download.fmt=c("png","pdf","csv"), + width = c("auto","100%"), + height = height + ) +} + +plot_clustpca_server <- function(id, + pgx, + r.samples = reactive(""), + hmpca.colvar, + hmpca.shapevar, + watermark=FALSE, + parent) +{ + moduleServer( id, function(input, output, session) { + ns <- session$ns + + ## Functions ############ + + hm_getClusterPositions <- shiny::reactive({ + + dbg("[plot_clustpca_server:hm_getClusterPositions] reacted!") + + ##pgx <- inputData() + ##shiny::req(pgx$tsne2d,pgx$tsne3d,pgx$cluster) + + ## take full matrix + #flt <- getFilteredMatrix() + #zx <- flt$zx + sel.samples <- r.samples() + + clustmethod="tsne";pdim=2 + do3d <- ("3D" %in% input$hmpca_options) + pdim = c(2,3)[ 1 + 1*do3d] + + pos = NULL + force.compute = FALSE + clustmethod = input$hm_clustmethod + clustmethod0 <- paste0(clustmethod,pdim,"d") + + if(clustmethod=="default" && !force.compute) { + if(pdim==2 && !is.null(pgx$tsne2d) ) { + pos <- pgx$tsne2d[sel.samples,] + } else if(pdim==3 && !is.null(pgx$tsne3d) ) { + pos <- pgx$tsne3d[sel.samples,] + } + } else if( clustmethod0 %in% names(pgx$cluster$pos)) { + shiny::showNotification(paste("switching to ",clustmethod0," layout...\n")) + pos <- pgx$cluster$pos[[clustmethod0]] + if(pdim==2) pos <- pos[sel.samples,1:2] + if(pdim==3) pos <- pos[sel.samples,1:3] + } else { + ##!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ## This should not be necessary anymore as we prefer to + ## precompute all clusterings. + shiny::showNotification(paste("computing ",clustmethod,"...\n")) + + ntop = 1000 + ## ntop = as.integer(input$hm_ntop2) + zx <- pgx$X + zx = zx[order(-apply(zx,1,sd)),,drop=FALSE] ## OK? + if(nrow(zx) > ntop) { + ##zx = head(zx,ntop) ## OK? + zx = zx[1:ntop,,drop=FALSE] ## OK? + } + if("normalize" %in% input$hmpca_options) { + zx <- scale(t(scale(t(zx)))) + } + perplexity = max(1,min((ncol(zx)-1)/3, 30)) + perplexity + res <- pgx.clusterMatrix( + zx, dims = pdim, perplexity = perplexity, + ntop = 999999, prefix = "C", + find.clusters = FALSE, kclust = 1, + row.center = TRUE, row.scale = FALSE, + method = clustmethod) + if(pdim==2) pos <- res$pos2d + if(pdim==3) pos <- res$pos3d + } + + pos <- pos[sel.samples,] + pos <- scale(pos) ## scale + ##colnames(pos) = paste0("dim",1:ncol(pos)) + ##rownames(pos) = colnames(zx) + + idx <- NULL + dbg("[hm_getClusterPositions] done") + + clust = list(pos=pos, clust=idx) + + return(clust) + }) + + ## Plot ############ + + plot_data <- shiny::reactive({ + dbg("[plot_clustpca_server:plot_data] reacted!") + clust <- hm_getClusterPositions() + ##data.frame( x=clust$pos[,1], y=clust$pos[,2], clust=clust$clust ) + return( + list( + hmpca_options = input$hmpca_options, + hmpca.colvar = hmpca.colvar(), + hmpca.shapevar = hmpca.shapevar(), + df = data.frame( x=clust$pos[,1], y=clust$pos[,2]) + + ) + ) + + }) + + plot.RENDER <- function() { + + ##pgx <- inputData() + pd <- plot_data() + hmpca_options <- pd[['hmpca_options']] + hmpca.colvar <- pd[['hmpca.colvar']] + hmpca.shapevar <- pd[['hmpca.shapevar']] + pos <- pd[['df']] + + + dbg("[plot_clustpca_server:plot.RENDER] function called!") + dbg("[plot_clustpca_server:plot.RENDER] names(df) = ",names(df)) + + shiny::req(pgx$Y) + shiny::req(df) + + do3d = ("3D" %in% hmpca_options) + ##clust <- hm_getClusterPositions() + sel <- rownames(pos) + df <- cbind(pos, pgx$Y[sel,]) + # if(!is.null(clust$clust)) df[[""]] <- clust$clust + + colvar = shapevar = linevar = textvar = NULL + if(hmpca.colvar %in% colnames(df)) colvar <- factor(df[,hmpca.colvar]) + if(hmpca.shapevar %in% colnames(df)) shapevar <- factor(df[,hmpca.shapevar]) + ##if(input$hmpca.line %in% colnames(df)) linevar = factor(df[,input$hmpca.line]) + ##if(input$hmpca.text %in% colnames(df)) textvar = factor(df[,input$hmpca.text]) + mode = "markers" + ann.text = rep(" ",nrow(df)) + if(!do3d && "sample label" %in% hmpca_options) ann.text = rownames(df) + if(!is.null(colvar)) { + colvar = factor(colvar) + textvar <- factor(df[,hmpca.colvar]) + } + symbols = c('circle','square','star','triangle-up','triangle-down','pentagon', + 'bowtie','hexagon', 'asterisk','hash','cross','triangle-left', + 'triangle-right','+',c(15:0)) + + Y <- cbind("sample"=rownames(pos), pgx$Y[sel,]) + ##tt.info <- paste('Sample:', rownames(df),'
Group:', df$group) + tt.info <- apply(Y, 1, function(y) paste0(colnames(Y),": ",y,"
",collapse="")) + tt.info <- as.character(tt.info) + cex1 = c(1.0,0.8,0.6)[1 + 1*(nrow(pos)>30) + 1*(nrow(pos)>200)] + + if(do3d ) { + ## 3D plot + j0 = 1:nrow(df) + j1 = NULL + if(!is.null(linevar)) { + linevar = factor(linevar) + j0 = which(linevar==levels(linevar)[1]) + j1 = which(linevar!=levels(linevar)[1]) + } + plt <- plotly::plot_ly(df, mode=mode) %>% + plotly::add_markers(x = df[j0,1], y = df[j0,2], z = df[j0,3], type="scatter3d", + color = colvar[j0], ## size = sizevar, sizes=c(80,140), + ##marker = list(size = 5*cex1), + marker = list(size=5*cex1, line=list(color="grey10", width=0.1)), + symbol = shapevar[j0], symbols=symbols, + text = tt.info[j0] ) %>% + plotly::add_annotations(x = pos[,1], y = pos[,2], z = pos[,3], + text = ann.text, + ##xref = "x", yref = "y", + showarrow = FALSE) + if(!is.null(j1) & length(j1)>0) { + plt <- plt %>% plotly::add_markers( + x = df[j1,1], y = df[j1,2], z = df[j1,3], type="scatter3d", + color = colvar[j1], ## size = sizevar, sizes=c(80,140), + ##marker = list(size=5*cex1, line=list(color="grey10", width=2)), + symbol = shapevar[j1], symbols=symbols, + text=tt.info[j1]) + } + ## add cluster annotation labels + if(0 && length(unique(colvar))>1) { + ## add cluster annotation labels + grp.pos <- apply(pos,2,function(x) tapply(x,colvar,median)) + ##grp.pos <- matrix(grp.pos, ncol=3) + cex2 <- ifelse(length(grp.pos)>20,0.8,1) + plt <- plt %>% plotly::add_annotations( + x = grp.pos[,1], y = grp.pos[,2], z = grp.pos[,3], + text = rownames(grp.pos), + font=list(size=24*cex2, color='#555'), + showarrow = FALSE) + } + + } else { + + ## 2D plot + j0 = 1:nrow(df) + j1 = NULL + if(!is.null(linevar)) { + linevar = factor(linevar) + j0 = which(linevar==levels(linevar)[1]) + j1 = which(linevar!=levels(linevar)[1]) + } + plt <- plotly::plot_ly(df, mode=mode) %>% + plotly::add_markers(x = df[j0,1], y = df[j0,2], type="scatter", + color = colvar[j0], ## size = sizevar, sizes=c(80,140), + marker = list(size=16*cex1, line=list(color="grey20", width=0.6)), + symbol = shapevar[j0], symbols=symbols, + text = tt.info[j0] ) %>% + plotly::add_annotations(x = pos[,1], y = pos[,2], + text = ann.text, + ##xref = "x", yref = "y", + showarrow = FALSE) + + ## add node labels + if(!is.null(j1) & length(j1)>0 ) { + plt <- plt %>% plotly::add_markers( + x = df[j1,1], y = df[j1,2], type="scatter", + color = colvar[j1], ## size = sizevar, sizes=c(80,140), + marker = list(size=16*cex1, line=list(color="grey20", width=1.8)), + symbol = shapevar[j1], symbols=symbols, + text=tt.info[j1]) + } + + ## add group/cluster annotation labels + req(input$hmpca_legend) + if(input$hmpca_legend == 'inside') { + plt <- plt %>% + plotly::layout(legend = list(x=0.05, y=0.95)) + } else if(input$hmpca_legend == 'bottom') { + plt <- plt %>% + plotly::layout(legend = list(orientation='h')) + } else { + if(!is.null(textvar) && length(unique(textvar))>1) { + grp.pos <- apply(pos,2,function(x) tapply(x,as.character(textvar),median)) + cex2 <- 1 + if(length(grp.pos)>20) cex2 <- 0.8 + if(length(grp.pos)>50) cex2 <- 0.6 + plt <- plt %>% plotly::add_annotations( + x = grp.pos[,1], y = grp.pos[,2], + text = paste0("",rownames(grp.pos),""), + font = list(size=24*cex2, color='#555'), + showarrow = FALSE) + } + plt <- plt %>% + plotly::layout(showlegend = FALSE) + } + + + } + title = paste0("PCA (",nrow(pos)," samples)") + if(input$hm_clustmethod=="tsne") title = paste0("tSNE (",nrow(pos)," samples)") + ## plt <- plt %>% plotly::layout(title=title) %>% + ## plotly::config(displayModeBar = FALSE) + plt <- plt %>% + ##config(displayModeBar = FALSE) %>% + plotly::config(displayModeBar = TRUE) %>% + ##config(modeBarButtonsToRemove = all.plotly.buttons ) %>% + plotly::config(displaylogo = FALSE) %>% + plotly::config(toImageButtonOptions = list(format='svg', height=800, width=800)) + ##print(plt) + return(plt) + } + + modal_plot.RENDER <- function() { + plot.RENDER() + } + + PlotModuleServer( + "pltmod", + plotlib = "plotly", + ##plotlib2 = "plotly", + func = plot.RENDER, + func2 = modal_plot.RENDER, + csvFunc = plot_data, ## *** downloadable data as CSV + ##renderFunc = plotly::renderPlotly, + ##renderFunc2 = plotly::renderPlotly, + res = c(90,170), ## resolution of plots + pdf.width = 8, pdf.height = 8, + add.watermark = watermark + ) + + + + }) + +} From f9a296c975fceb031164f5b01612bd11ad669b55 Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Fri, 17 Feb 2023 14:11:11 +0100 Subject: [PATCH 06/44] clustering_plot_PCAplot refactored --- .../R/clustering_plot_PCAplot.R | 23 +- .../board.clustering/R/clustering_server.R | 582 +++++++++--------- components/board.clustering/R/clustering_ui.R | 9 +- 3 files changed, 309 insertions(+), 305 deletions(-) diff --git a/components/board.clustering/R/clustering_plot_PCAplot.R b/components/board.clustering/R/clustering_plot_PCAplot.R index d9093b2c9..ce9ecf6c4 100644 --- a/components/board.clustering/R/clustering_plot_PCAplot.R +++ b/components/board.clustering/R/clustering_plot_PCAplot.R @@ -7,11 +7,10 @@ ## Annotate clusters ############ -plot_clustpca_ui <- function(id, - label='', - - height=c(600,800), - parent) +clustering_plot_clustpca_ui <- function(id, + label='', + height=c(600,800), + parent) { ns <- shiny::NS(id) @@ -52,13 +51,13 @@ plot_clustpca_ui <- function(id, ) } -plot_clustpca_server <- function(id, - pgx, - r.samples = reactive(""), - hmpca.colvar, - hmpca.shapevar, - watermark=FALSE, - parent) +clustering_plot_clustpca_server <- function(id, + pgx, + r.samples = reactive(""), + hmpca.colvar, + hmpca.shapevar, + watermark=FALSE, + parent) { moduleServer( id, function(input, output, session) { ns <- session$ns diff --git a/components/board.clustering/R/clustering_server.R b/components/board.clustering/R/clustering_server.R index 610291609..4a6667359 100644 --- a/components/board.clustering/R/clustering_server.R +++ b/components/board.clustering/R/clustering_server.R @@ -30,17 +30,25 @@ The Clustering Analysis module performs unsupervised clustering }) - plot_clustpca_server("PCAplot", - pgx, - r.samples = r.samples, - hmpca.colvar = shiny::reactive(input$hmpca.colvar), - hmpca.shapevar = shiny::reactive(input$hmpca.shapevar), - watermark=FALSE, - parent = ns) - - # observe functions ######## + shiny::observe({ + shiny::req(pgx$Y) + ##input$menuitem ## upon menuitem change + var.types = colnames(pgx$Y) + var.types = var.types[grep("sample|patient",var.types,invert=TRUE)] + vv = c(var.types,rep("",10)) + var.types0 = c("","",var.types) + var.types0 = c("",var.types) + var.types1 = c("",var.types) + grp = vv[1] + if("group" %in% var.types) grp = "group" + shiny::updateSelectInput(session, "hmpca.colvar", choices=var.types0, selected=grp) + shiny::updateSelectInput(session, "hmpca.shapevar", choices=var.types1, selected="") + ##updateSelectInput(session, "hmpca.line", choices=var.types1, selected="") + ##updateSelectInput(session, "hmpca.text", choices=var.types0, selected="group") + }) + shiny::observeEvent( input$clust_info, { shiny::showModal(shiny::modalDialog( title = shiny::HTML("Clustering Board"), @@ -120,8 +128,7 @@ The Clustering Analysis module performs unsupervised clustering - # REACTIVE FUNCTIONS ############## - + # reactive functions ############## getFilteredMatrix <- shiny::reactive({ ## Returns filtered matrix ready for clustering. Filtering based @@ -479,6 +486,16 @@ The Clustering Analysis module performs unsupervised clustering getTopMatrix = getTopMatrix, watermark = FALSE) + clustering_plot_clustpca_server("PCAplot", + pgx, + r.samples = r.samples, + hmpca.colvar = shiny::reactive(input$hmpca.colvar), + hmpca.shapevar = shiny::reactive(input$hmpca.shapevar), + watermark=FALSE, + parent = ns) + + + # start hm_splitmap refactoring ######## @@ -486,7 +503,7 @@ The Clustering Analysis module performs unsupervised clustering # hm1_splitmap.RENDER <- shiny::reactive({ # - # ## ComplexHeatmap based splitted heatmap ########## + # # filt <- getTopMatrix() # shiny::req(filt) @@ -593,7 +610,6 @@ The Clustering Analysis module performs unsupervised clustering # hm2_splitmap.RENDER <- shiny::reactive({ # # - # ## iHeatmap based splitted heatmap ######### # # shiny::req(pgx$genes) # @@ -835,286 +851,274 @@ The Clustering Analysis module performs unsupervised clustering # end hm_splitmap refactoring ######## + # start PCA/tSNR refactoring ######## + +# ## PCA/tSNE ############ +# +# hm_PCAplot_text = tagsub(paste0(' The PCA/tSNE panel visualizes unsupervised clustering obtained by the principal components analysis (',a_PCA,') or t-distributed stochastic embedding (',a_tSNE,') algorithms. This plot shows the relationship (or similarity) between the samples for visual analytics, where similarity is visualized as proximity of the points. Samples that are ‘similar’ will be placed close to each other. +#

Users can customise the PCA/tSNE plot in the plot settings, including the {color} and {shape} of points using a phenotype class, choose t-SNE or PCA layout, label the points, or display 2D and 3D visualisation of the PCA/tSNE plot.')) +# +# +# +# hm_getClusterPositions <- shiny::reactive({ +# +# dbg("[hm_getClusterPositions] reacted") +# +# ##pgx <- inputData() +# shiny::req(pgx$tsne2d,pgx$tsne3d,pgx$cluster) +# +# ## take full matrix +# flt <- getFilteredMatrix() +# zx <- flt$zx +# +# clustmethod="tsne";pdim=2 +# do3d <- ("3D" %in% input$hmpca_options) +# pdim = c(2,3)[ 1 + 1*do3d] +# +# pos = NULL +# force.compute = FALSE +# clustmethod = input$hm_clustmethod +# clustmethod0 <- paste0(clustmethod,pdim,"d") +# +# if(clustmethod=="default" && !force.compute) { +# if(pdim==2 && !is.null(pgx$tsne2d) ) { +# pos <- pgx$tsne2d[colnames(zx),] +# } else if(pdim==3 && !is.null(pgx$tsne3d) ) { +# pos <- pgx$tsne3d[colnames(zx),] +# } +# } else if( clustmethod0 %in% names(pgx$cluster$pos)) { +# shiny::showNotification(paste("switching to ",clustmethod0," layout...\n")) +# pos <- pgx$cluster$pos[[clustmethod0]] +# if(pdim==2) pos <- pos[colnames(zx),1:2] +# if(pdim==3) pos <- pos[colnames(zx),1:3] +# } else { +# ##!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +# ## This should not be necessary anymore as we prefer to +# ## precompute all clusterings. +# shiny::showNotification(paste("computing ",clustmethod,"...\n")) +# +# ntop = 1000 +# ## ntop = as.integer(input$hm_ntop2) +# zx = zx[order(-apply(zx,1,sd)),,drop=FALSE] ## OK? +# if(nrow(zx) > ntop) { +# ##zx = head(zx,ntop) ## OK? +# zx = zx[1:ntop,,drop=FALSE] ## OK? +# } +# if("normalize" %in% input$hmpca_options) { +# zx <- scale(t(scale(t(zx)))) +# } +# perplexity = max(1,min((ncol(zx)-1)/3, 30)) +# perplexity +# res <- pgx.clusterMatrix( +# zx, dims = pdim, perplexity = perplexity, +# ntop = 999999, prefix = "C", +# find.clusters = FALSE, kclust = 1, +# row.center = TRUE, row.scale = FALSE, +# method = clustmethod) +# if(pdim==2) pos <- res$pos2d +# if(pdim==3) pos <- res$pos3d +# } +# +# pos <- pos[colnames(zx),] +# pos = scale(pos) ## scale +# ##colnames(pos) = paste0("dim",1:ncol(pos)) +# ##rownames(pos) = colnames(zx) +# +# idx <- NULL +# dbg("[hm_getClusterPositions] done") +# +# clust = list(pos=pos, clust=idx) +# return(clust) +# }) +# +# hm_PCAplot.RENDER <- shiny::reactive({ +# +# ##pgx <- inputData() +# shiny::req(pgx$Y) +# +# do3d = ("3D" %in% input$hmpca_options) +# clust <- hm_getClusterPositions() +# pos <- clust$pos +# sel <- rownames(pos) +# df <- cbind(pos, pgx$Y[sel,]) +# if(!is.null(clust$clust)) df[[""]] <- clust$clust +# +# colvar = shapevar = linevar = textvar = NULL +# if(input$hmpca.colvar %in% colnames(df)) colvar <- factor(df[,input$hmpca.colvar]) +# if(input$hmpca.shapevar %in% colnames(df)) shapevar <- factor(df[,input$hmpca.shapevar]) +# ##if(input$hmpca.line %in% colnames(df)) linevar = factor(df[,input$hmpca.line]) +# ##if(input$hmpca.text %in% colnames(df)) textvar = factor(df[,input$hmpca.text]) +# mode = "markers" +# ann.text = rep(" ",nrow(df)) +# if(!do3d && "sample label" %in% input$hmpca_options) ann.text = rownames(df) +# if(!is.null(colvar)) { +# colvar = factor(colvar) +# textvar <- factor(df[,input$hmpca.colvar]) +# } +# symbols = c('circle','square','star','triangle-up','triangle-down','pentagon', +# 'bowtie','hexagon', 'asterisk','hash','cross','triangle-left', +# 'triangle-right','+',c(15:0)) +# +# +# Y <- cbind("sample"=rownames(pos), pgx$Y[sel,]) +# ##tt.info <- paste('Sample:', rownames(df),'
Group:', df$group) +# tt.info <- apply(Y, 1, function(y) paste0(colnames(Y),": ",y,"
",collapse="")) +# tt.info <- as.character(tt.info) +# cex1 = c(1.0,0.8,0.6)[1 + 1*(nrow(pos)>30) + 1*(nrow(pos)>200)] +# +# if(do3d ) { +# ## 3D plot +# j0 = 1:nrow(df) +# j1 = NULL +# if(!is.null(linevar)) { +# linevar = factor(linevar) +# j0 = which(linevar==levels(linevar)[1]) +# j1 = which(linevar!=levels(linevar)[1]) +# } +# plt <- plotly::plot_ly(df, mode=mode) %>% +# plotly::add_markers(x = df[j0,1], y = df[j0,2], z = df[j0,3], type="scatter3d", +# color = colvar[j0], ## size = sizevar, sizes=c(80,140), +# ##marker = list(size = 5*cex1), +# marker = list(size=5*cex1, line=list(color="grey10", width=0.1)), +# symbol = shapevar[j0], symbols=symbols, +# text = tt.info[j0] ) %>% +# plotly::add_annotations(x = pos[,1], y = pos[,2], z = pos[,3], +# text = ann.text, +# ##xref = "x", yref = "y", +# showarrow = FALSE) +# if(!is.null(j1) & length(j1)>0) { +# plt <- plt %>% plotly::add_markers( +# x = df[j1,1], y = df[j1,2], z = df[j1,3], type="scatter3d", +# color = colvar[j1], ## size = sizevar, sizes=c(80,140), +# ##marker = list(size=5*cex1, line=list(color="grey10", width=2)), +# symbol = shapevar[j1], symbols=symbols, +# text=tt.info[j1]) +# } +# ## add cluster annotation labels +# if(0 && length(unique(colvar))>1) { +# ## add cluster annotation labels +# grp.pos <- apply(pos,2,function(x) tapply(x,colvar,median)) +# ##grp.pos <- matrix(grp.pos, ncol=3) +# cex2 <- ifelse(length(grp.pos)>20,0.8,1) +# plt <- plt %>% plotly::add_annotations( +# x = grp.pos[,1], y = grp.pos[,2], z = grp.pos[,3], +# text = rownames(grp.pos), +# font=list(size=24*cex2, color='#555'), +# showarrow = FALSE) +# } +# +# } else { +# +# ## 2D plot +# j0 = 1:nrow(df) +# j1 = NULL +# if(!is.null(linevar)) { +# linevar = factor(linevar) +# j0 = which(linevar==levels(linevar)[1]) +# j1 = which(linevar!=levels(linevar)[1]) +# } +# plt <- plotly::plot_ly(df, mode=mode) %>% +# plotly::add_markers(x = df[j0,1], y = df[j0,2], type="scatter", +# color = colvar[j0], ## size = sizevar, sizes=c(80,140), +# marker = list(size=16*cex1, line=list(color="grey20", width=0.6)), +# symbol = shapevar[j0], symbols=symbols, +# text = tt.info[j0] ) %>% +# plotly::add_annotations(x = pos[,1], y = pos[,2], +# text = ann.text, +# ##xref = "x", yref = "y", +# showarrow = FALSE) +# +# ## add node labels +# if(!is.null(j1) & length(j1)>0 ) { +# plt <- plt %>% plotly::add_markers( +# x = df[j1,1], y = df[j1,2], type="scatter", +# color = colvar[j1], ## size = sizevar, sizes=c(80,140), +# marker = list(size=16*cex1, line=list(color="grey20", width=1.8)), +# symbol = shapevar[j1], symbols=symbols, +# text=tt.info[j1]) +# } +# +# ## add group/cluster annotation labels +# req(input$hmpca_legend) +# if(input$hmpca_legend == 'inside') { +# plt <- plt %>% +# plotly::layout(legend = list(x=0.05, y=0.95)) +# } else if(input$hmpca_legend == 'bottom') { +# plt <- plt %>% +# plotly::layout(legend = list(orientation='h')) +# } else { +# if(!is.null(textvar) && length(unique(textvar))>1) { +# grp.pos <- apply(pos,2,function(x) tapply(x,as.character(textvar),median)) +# cex2 <- 1 +# if(length(grp.pos)>20) cex2 <- 0.8 +# if(length(grp.pos)>50) cex2 <- 0.6 +# plt <- plt %>% plotly::add_annotations( +# x = grp.pos[,1], y = grp.pos[,2], +# text = paste0("",rownames(grp.pos),""), +# font = list(size=24*cex2, color='#555'), +# showarrow = FALSE) +# } +# plt <- plt %>% +# plotly::layout(showlegend = FALSE) +# } +# +# +# } +# title = paste0("PCA (",nrow(pos)," samples)") +# if(input$hm_clustmethod=="tsne") title = paste0("tSNE (",nrow(pos)," samples)") +# plt <- plt %>% +# plotly::config(displayModeBar = TRUE) %>% +# ##config(modeBarButtonsToRemove = all.plotly.buttons ) %>% +# plotly::config(displaylogo = FALSE) %>% +# plotly::config(toImageButtonOptions = list(format='svg', height=800, width=800)) +# ##print(plt) +# return(plt) +# }) + + # hm_PCAplot_opts = shiny::tagList( + # tipifyR( shiny::selectInput( ns("hmpca.colvar"), "Color/label:", choices=NULL, width='100%'), + # "Set colors/labels according to a given phenotype."), + # tipifyR( shiny::selectInput( ns("hmpca.shapevar"), "Shape:", choices=NULL, width='100%'), + # "Set shapes according to a given phenotype."), + # tipifyR( shiny::radioButtons( + # ns('hmpca_legend'), label = "Legend:", + # choices = c('group label','bottom'), inline=TRUE), + # "Normalize matrix before calculating distances."), + # tipifyR( shiny::checkboxGroupInput( ns('hmpca_options'),"Other:", + # choices=c('sample label','3D','normalize'), inline=TRUE), + # "Normalize matrix before calculating distances."), + # tipifyR( shiny::radioButtons( ns('hm_clustmethod'),"Layout:", + # c("default","tsne","pca","umap"),inline=TRUE), + # "Choose the layout method for clustering to visualise.") + # ) - ## PCA/tSNE ############ - - hm_PCAplot_text = tagsub(paste0(' The PCA/tSNE panel visualizes unsupervised clustering obtained by the principal components analysis (',a_PCA,') or t-distributed stochastic embedding (',a_tSNE,') algorithms. This plot shows the relationship (or similarity) between the samples for visual analytics, where similarity is visualized as proximity of the points. Samples that are ‘similar’ will be placed close to each other. -

Users can customise the PCA/tSNE plot in the plot settings, including the {color} and {shape} of points using a phenotype class, choose t-SNE or PCA layout, label the points, or display 2D and 3D visualisation of the PCA/tSNE plot.')) - - shiny::observe({ - shiny::req(pgx$Y) - ##input$menuitem ## upon menuitem change - var.types = colnames(pgx$Y) - var.types = var.types[grep("sample|patient",var.types,invert=TRUE)] - vv = c(var.types,rep("",10)) - var.types0 = c("","",var.types) - var.types0 = c("",var.types) - var.types1 = c("",var.types) - grp = vv[1] - if("group" %in% var.types) grp = "group" - shiny::updateSelectInput(session, "hmpca.colvar", choices=var.types0, selected=grp) - shiny::updateSelectInput(session, "hmpca.shapevar", choices=var.types1, selected="") - ##updateSelectInput(session, "hmpca.line", choices=var.types1, selected="") - ##updateSelectInput(session, "hmpca.text", choices=var.types0, selected="group") - }) - - hm_getClusterPositions <- shiny::reactive({ - - dbg("[hm_getClusterPositions] reacted") - - ##pgx <- inputData() - shiny::req(pgx$tsne2d,pgx$tsne3d,pgx$cluster) - - ## take full matrix - flt <- getFilteredMatrix() - zx <- flt$zx - - clustmethod="tsne";pdim=2 - do3d <- ("3D" %in% input$hmpca_options) - pdim = c(2,3)[ 1 + 1*do3d] - - pos = NULL - force.compute = FALSE - clustmethod = input$hm_clustmethod - clustmethod0 <- paste0(clustmethod,pdim,"d") - - if(clustmethod=="default" && !force.compute) { - if(pdim==2 && !is.null(pgx$tsne2d) ) { - pos <- pgx$tsne2d[colnames(zx),] - } else if(pdim==3 && !is.null(pgx$tsne3d) ) { - pos <- pgx$tsne3d[colnames(zx),] - } - } else if( clustmethod0 %in% names(pgx$cluster$pos)) { - shiny::showNotification(paste("switching to ",clustmethod0," layout...\n")) - pos <- pgx$cluster$pos[[clustmethod0]] - if(pdim==2) pos <- pos[colnames(zx),1:2] - if(pdim==3) pos <- pos[colnames(zx),1:3] - } else { - ##!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ## This should not be necessary anymore as we prefer to - ## precompute all clusterings. - shiny::showNotification(paste("computing ",clustmethod,"...\n")) - - ntop = 1000 - ## ntop = as.integer(input$hm_ntop2) - zx = zx[order(-apply(zx,1,sd)),,drop=FALSE] ## OK? - if(nrow(zx) > ntop) { - ##zx = head(zx,ntop) ## OK? - zx = zx[1:ntop,,drop=FALSE] ## OK? - } - if("normalize" %in% input$hmpca_options) { - zx <- scale(t(scale(t(zx)))) - } - perplexity = max(1,min((ncol(zx)-1)/3, 30)) - perplexity - res <- pgx.clusterMatrix( - zx, dims = pdim, perplexity = perplexity, - ntop = 999999, prefix = "C", - find.clusters = FALSE, kclust = 1, - row.center = TRUE, row.scale = FALSE, - method = clustmethod) - if(pdim==2) pos <- res$pos2d - if(pdim==3) pos <- res$pos3d - } - - pos <- pos[colnames(zx),] - pos = scale(pos) ## scale - ##colnames(pos) = paste0("dim",1:ncol(pos)) - ##rownames(pos) = colnames(zx) - - idx <- NULL - dbg("[hm_getClusterPositions] done") - - clust = list(pos=pos, clust=idx) - return(clust) - }) - - hm_PCAplot.RENDER <- shiny::reactive({ - - ##pgx <- inputData() - shiny::req(pgx$Y) - - do3d = ("3D" %in% input$hmpca_options) - clust <- hm_getClusterPositions() - pos <- clust$pos - sel <- rownames(pos) - df <- cbind(pos, pgx$Y[sel,]) - if(!is.null(clust$clust)) df[[""]] <- clust$clust - - colvar = shapevar = linevar = textvar = NULL - if(input$hmpca.colvar %in% colnames(df)) colvar <- factor(df[,input$hmpca.colvar]) - if(input$hmpca.shapevar %in% colnames(df)) shapevar <- factor(df[,input$hmpca.shapevar]) - ##if(input$hmpca.line %in% colnames(df)) linevar = factor(df[,input$hmpca.line]) - ##if(input$hmpca.text %in% colnames(df)) textvar = factor(df[,input$hmpca.text]) - mode = "markers" - ann.text = rep(" ",nrow(df)) - if(!do3d && "sample label" %in% input$hmpca_options) ann.text = rownames(df) - if(!is.null(colvar)) { - colvar = factor(colvar) - textvar <- factor(df[,input$hmpca.colvar]) - } - symbols = c('circle','square','star','triangle-up','triangle-down','pentagon', - 'bowtie','hexagon', 'asterisk','hash','cross','triangle-left', - 'triangle-right','+',c(15:0)) - - - Y <- cbind("sample"=rownames(pos), pgx$Y[sel,]) - ##tt.info <- paste('Sample:', rownames(df),'
Group:', df$group) - tt.info <- apply(Y, 1, function(y) paste0(colnames(Y),": ",y,"
",collapse="")) - tt.info <- as.character(tt.info) - cex1 = c(1.0,0.8,0.6)[1 + 1*(nrow(pos)>30) + 1*(nrow(pos)>200)] - - if(do3d ) { - ## 3D plot - j0 = 1:nrow(df) - j1 = NULL - if(!is.null(linevar)) { - linevar = factor(linevar) - j0 = which(linevar==levels(linevar)[1]) - j1 = which(linevar!=levels(linevar)[1]) - } - plt <- plotly::plot_ly(df, mode=mode) %>% - plotly::add_markers(x = df[j0,1], y = df[j0,2], z = df[j0,3], type="scatter3d", - color = colvar[j0], ## size = sizevar, sizes=c(80,140), - ##marker = list(size = 5*cex1), - marker = list(size=5*cex1, line=list(color="grey10", width=0.1)), - symbol = shapevar[j0], symbols=symbols, - text = tt.info[j0] ) %>% - plotly::add_annotations(x = pos[,1], y = pos[,2], z = pos[,3], - text = ann.text, - ##xref = "x", yref = "y", - showarrow = FALSE) - if(!is.null(j1) & length(j1)>0) { - plt <- plt %>% plotly::add_markers( - x = df[j1,1], y = df[j1,2], z = df[j1,3], type="scatter3d", - color = colvar[j1], ## size = sizevar, sizes=c(80,140), - ##marker = list(size=5*cex1, line=list(color="grey10", width=2)), - symbol = shapevar[j1], symbols=symbols, - text=tt.info[j1]) - } - ## add cluster annotation labels - if(0 && length(unique(colvar))>1) { - ## add cluster annotation labels - grp.pos <- apply(pos,2,function(x) tapply(x,colvar,median)) - ##grp.pos <- matrix(grp.pos, ncol=3) - cex2 <- ifelse(length(grp.pos)>20,0.8,1) - plt <- plt %>% plotly::add_annotations( - x = grp.pos[,1], y = grp.pos[,2], z = grp.pos[,3], - text = rownames(grp.pos), - font=list(size=24*cex2, color='#555'), - showarrow = FALSE) - } - - } else { - - ## 2D plot - j0 = 1:nrow(df) - j1 = NULL - if(!is.null(linevar)) { - linevar = factor(linevar) - j0 = which(linevar==levels(linevar)[1]) - j1 = which(linevar!=levels(linevar)[1]) - } - plt <- plotly::plot_ly(df, mode=mode) %>% - plotly::add_markers(x = df[j0,1], y = df[j0,2], type="scatter", - color = colvar[j0], ## size = sizevar, sizes=c(80,140), - marker = list(size=16*cex1, line=list(color="grey20", width=0.6)), - symbol = shapevar[j0], symbols=symbols, - text = tt.info[j0] ) %>% - plotly::add_annotations(x = pos[,1], y = pos[,2], - text = ann.text, - ##xref = "x", yref = "y", - showarrow = FALSE) - - ## add node labels - if(!is.null(j1) & length(j1)>0 ) { - plt <- plt %>% plotly::add_markers( - x = df[j1,1], y = df[j1,2], type="scatter", - color = colvar[j1], ## size = sizevar, sizes=c(80,140), - marker = list(size=16*cex1, line=list(color="grey20", width=1.8)), - symbol = shapevar[j1], symbols=symbols, - text=tt.info[j1]) - } - - ## add group/cluster annotation labels - req(input$hmpca_legend) - if(input$hmpca_legend == 'inside') { - plt <- plt %>% - plotly::layout(legend = list(x=0.05, y=0.95)) - } else if(input$hmpca_legend == 'bottom') { - plt <- plt %>% - plotly::layout(legend = list(orientation='h')) - } else { - if(!is.null(textvar) && length(unique(textvar))>1) { - grp.pos <- apply(pos,2,function(x) tapply(x,as.character(textvar),median)) - cex2 <- 1 - if(length(grp.pos)>20) cex2 <- 0.8 - if(length(grp.pos)>50) cex2 <- 0.6 - plt <- plt %>% plotly::add_annotations( - x = grp.pos[,1], y = grp.pos[,2], - text = paste0("",rownames(grp.pos),""), - font = list(size=24*cex2, color='#555'), - showarrow = FALSE) - } - plt <- plt %>% - plotly::layout(showlegend = FALSE) - } - - - } - title = paste0("PCA (",nrow(pos)," samples)") - if(input$hm_clustmethod=="tsne") title = paste0("tSNE (",nrow(pos)," samples)") - plt <- plt %>% - plotly::config(displayModeBar = TRUE) %>% - ##config(modeBarButtonsToRemove = all.plotly.buttons ) %>% - plotly::config(displaylogo = FALSE) %>% - plotly::config(toImageButtonOptions = list(format='svg', height=800, width=800)) - ##print(plt) - return(plt) - }) - - hm_PCAplot_opts = shiny::tagList( - tipifyR( shiny::selectInput( ns("hmpca.colvar"), "Color/label:", choices=NULL, width='100%'), - "Set colors/labels according to a given phenotype."), - tipifyR( shiny::selectInput( ns("hmpca.shapevar"), "Shape:", choices=NULL, width='100%'), - "Set shapes according to a given phenotype."), - tipifyR( shiny::radioButtons( - ns('hmpca_legend'), label = "Legend:", - choices = c('group label','bottom'), inline=TRUE), - "Normalize matrix before calculating distances."), - tipifyR( shiny::checkboxGroupInput( ns('hmpca_options'),"Other:", - choices=c('sample label','3D','normalize'), inline=TRUE), - "Normalize matrix before calculating distances."), - tipifyR( shiny::radioButtons( ns('hm_clustmethod'),"Layout:", - c("default","tsne","pca","umap"),inline=TRUE), - "Choose the layout method for clustering to visualise.") - ) + # hm_PCAplot_caption <- shiny::reactive({ + # text1 = "The plot visualizes the similarity of samples as a scatterplot in reduced dimension (2D or 3D). Samples that are similar (in expression) are clustered near to each other, while samples with different expression are positioned farther away. Groups of samples with similar profiles will appear as clusters in the plot." + # if(input$hmpca.colvar!="") { + # text1 <- paste(text1, "Colors correspond to the ",input$hmpca.colvar,"phenotype.") + # } + # if(input$hmpca.shapevar!="") { + # text1 <- paste(text1, "Shapes correspond to the ",input$hmpca.shapevar,"phenotype.") + # } + # return(shiny::HTML(text1)) + # }) - hm_PCAplot_caption <- shiny::reactive({ - text1 = "The plot visualizes the similarity of samples as a scatterplot in reduced dimension (2D or 3D). Samples that are similar (in expression) are clustered near to each other, while samples with different expression are positioned farther away. Groups of samples with similar profiles will appear as clusters in the plot." - if(input$hmpca.colvar!="") { - text1 <- paste(text1, "Colors correspond to the ",input$hmpca.colvar,"phenotype.") - } - if(input$hmpca.shapevar!="") { - text1 <- paste(text1, "Shapes correspond to the ",input$hmpca.shapevar,"phenotype.") - } - return(shiny::HTML(text1)) - }) + # pca_caption_static = "PCA/tSNE plot. The plot visualizes the similarity in expression of samples as a scatterplot in reduced dimension (2D or 3D). Samples that are similar are clustered near to each other, while samples with different expression are positioned farther away. Groups of samples with similar profiles will appear as clusters in the plot." - pca_caption_static = "PCA/tSNE plot. The plot visualizes the similarity in expression of samples as a scatterplot in reduced dimension (2D or 3D). Samples that are similar are clustered near to each other, while samples with different expression are positioned farther away. Groups of samples with similar profiles will appear as clusters in the plot." + # shiny::callModule( #not used + # plotModule, + # id = "hm_PCAplot", + # func = hm_PCAplot.RENDER, ## ns=ns, + # plotlib = "plotly", + # options = hm_PCAplot_opts, + # height = c(fullH-80,700), width=c("auto",800), + # pdf.width=8, pdf.height=8, + # title="PCA/tSNE plot", + # info.text = hm_PCAplot_text, + # add.watermark = WATERMARK + # ) - shiny::callModule( - plotModule, - id = "hm_PCAplot", - func = hm_PCAplot.RENDER, ## ns=ns, - plotlib = "plotly", - options = hm_PCAplot_opts, - height = c(fullH-80,700), width=c("auto",800), - pdf.width=8, pdf.height=8, - title="PCA/tSNE plot", - info.text = hm_PCAplot_text, - add.watermark = WATERMARK - ) + # end PCA refactoring ############ ## Parallel coordinates ########## diff --git a/components/board.clustering/R/clustering_ui.R b/components/board.clustering/R/clustering_ui.R index 707b197e2..35ecfb234 100644 --- a/components/board.clustering/R/clustering_ui.R +++ b/components/board.clustering/R/clustering_ui.R @@ -81,10 +81,11 @@ ClusteringUI <- function(id) { ) ), shiny::tabPanel("PCA/tSNE", - plot_clustpca_ui(ns("PCAplot"), - label="", - height=c("70vh","70vh"), - parent = ns) + clustering_plot_clustpca_ui( + ns("PCAplot"), + label="", + height=c("70vh","70vh"), + parent = ns) ##plotWidget(ns("hm_PCAplot")), ## tags$div( class="caption", ## HTML("PCA/tSNE plot. The plot visualizes the similarity in expression of From 96addd7d24fff3711a432af7f26afbe49f9cc743 Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Fri, 17 Feb 2023 16:01:12 +0100 Subject: [PATCH 07/44] `hm_parcoord` refactored --- .../R/clustering_plot_hm_parcoord.R | 134 ++++++++ .../board.clustering/R/clustering_server.R | 323 ++++++++++-------- components/board.clustering/R/clustering_ui.R | 7 +- 3 files changed, 315 insertions(+), 149 deletions(-) create mode 100644 components/board.clustering/R/clustering_plot_hm_parcoord.R diff --git a/components/board.clustering/R/clustering_plot_hm_parcoord.R b/components/board.clustering/R/clustering_plot_hm_parcoord.R new file mode 100644 index 000000000..fb728919f --- /dev/null +++ b/components/board.clustering/R/clustering_plot_hm_parcoord.R @@ -0,0 +1,134 @@ +## +## This file is part of the Omics Playground project. +## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. +## + + + +## Annotate clusters ############ + +clustering_plot_hm_parcoord_ui <- function(id, + label='', + height, + width + ) +{ + ns <- shiny::NS(id) + + info_text = "The Parallel Coordinates panel +displays the expression levels of selected genes across all conditions in the analysis. On the x-axis the experimental conditions are plotted. The y-axis shows the expression level of the genes grouped by condition. The colors correspond to the gene groups as defined by the hierarchical clustered heatmap." + + + hm_parcoord_opts = shiny::tagList( + withTooltip( shiny::checkboxInput(ns('hm_pcscale'),'Scale values',TRUE), + "Scale expression values to mean=0 and SD=1.", + placement="right",options = list(container = "body")) + ) + + PlotModuleUI( + ns("pltmod"), + title = "Parallel coordinates", + label = label, + plotlib = "plotly", + info.text = info_text, + options = hm_parcoord_opts, + download.fmt=c("png","pdf","csv"), + width = width, + height = height + ) +} + +clustering_plot_hm_parcoord_server <- function(id, + pgx, + hm_parcoord.matrix, + watermark=FALSE + ) +{ + moduleServer( id, function(input, output, session) { + ns <- session$ns + + hm_parcoord.RENDER <- shiny::reactive({ + + pc <- hm_parcoord.matrix() + shiny::req(pc) + zx <- pc$mat + ## build dimensions + dimensions <- list() + for(i in 1:ncol(zx)) { + dimensions[[i]] <- list( + range = c(min(zx[,i]),max(zx[,i])), + ## constraintrange = c(100000,150000), + ## tickvals = c(0,0.5,1,2,3), + ## ticktext = c('A','AB','B','Y','Z'), + visible = TRUE, + label = colnames(zx)[i], + values = zx[,i] + ) + } + + clust.id <- as.integer(factor(pc$clust)) + table(clust.id) + + df <- data.frame(clust.id=clust.id, zx) + klrpal = rep(RColorBrewer::brewer.pal(8,"Set2"),99) + ##klrpal = rep(c("red","blue","green","yellow","magenta","cyan","black","grey"),99) + klrpal = klrpal[1:max(clust.id)] + ##klrpal <- setNames(klrpal, sort(unique(clust.id))) + klrpal2 <- lapply(1:length(klrpal),function(i) c((i-1)/(length(klrpal)-1),klrpal[i])) + + plt <- plotly::plot_ly(df, source = "pcoords") %>% + plotly::add_trace(type = 'parcoords', + line = list(color = ~clust.id, + ## colorscale = list(c(0,'red'),c(0.5,'green'),c(1,'blue')) + ##colorscale = 'Jet', + colorscale = klrpal2, + cmin = min(clust.id), cmax = max(clust.id), + showscale = FALSE + ##reversescale = TRUE + ), + dimensions = dimensions) + plt <- plt %>% + plotly::layout(margin = list(l=60, r=60, t=0, b=30)) %>% + ##config(displayModeBar = FALSE) %>% + ##config(modeBarButtonsToRemove = setdiff(all.plotly.buttons,"toImage") ) %>% + plotly::config(toImageButtonOptions = list(format='svg', width=900, height=350, scale=1.2)) %>% + plotly::config(displaylogo = FALSE) %>% + plotly::event_register("plotly_restyle") + + plt + + }) + + + PlotModuleServer( + "pltmod", + plotlib = "plotly", + ##plotlib2 = "plotly", + func = hm_parcoord.RENDER, + ##renderFunc = plotly::renderPlotly, + ##renderFunc2 = plotly::renderPlotly, + res = c(90,170), ## resolution of plots + pdf.width = 8, pdf.height = 8, + add.watermark = watermark + ) + + # shiny::callModule( + # plotModule, + # ## hm_parcoord_module <- plotModule( + # "hm_parcoord", + # func = hm_parcoord.RENDER, ## ns = ns, + # plotlib = "plotly", ## renderFunc="renderPlotly", + # ## download.fmt = c("png","pdf","html"), ## PNG & PDF do not work!!! + # ## download.fmt = c("html"), + # options = hm_parcoord_opts, + # height = c(0.45*fullH,600), width = c("100%",1000), + # pdf.width=10, pdf.height=6, info.width="350px", + # title = "Parallel coordinates", label = "a", + # info.text = hm_parcoord_text, + # add.watermark = WATERMARK + # ## caption = hm_parcoord_text, + # ) + }) + + +} diff --git a/components/board.clustering/R/clustering_server.R b/components/board.clustering/R/clustering_server.R index 4a6667359..908fb8be4 100644 --- a/components/board.clustering/R/clustering_server.R +++ b/components/board.clustering/R/clustering_server.R @@ -49,12 +49,12 @@ The Clustering Analysis module performs unsupervised clustering ##updateSelectInput(session, "hmpca.text", choices=var.types0, selected="group") }) - shiny::observeEvent( input$clust_info, { - shiny::showModal(shiny::modalDialog( - title = shiny::HTML("Clustering Board"), - shiny::HTML(clust_infotext), - easyClose = TRUE, size="l" )) - }) + # shiny::observeEvent( input$clust_info, { + # shiny::showModal(shiny::modalDialog( + # title = shiny::HTML("Clustering Board"), + # shiny::HTML(clust_infotext), + # easyClose = TRUE, size="l" )) + # }) ## update filter choices upon change of data set shiny::observe({ @@ -126,6 +126,34 @@ The Clustering Analysis module performs unsupervised clustering shiny::updateSelectInput(session, "hm_features", choices=choices) }) + shiny::observeEvent( plotly::event_data("plotly_restyle", source = "pcoords"), { + ## From: https://rdrr.io/cran/plotly/src/inst/examples/shiny/event_data_parcoords/app.R + ## + d <- plotly::event_data("plotly_restyle", source = "pcoords") + ## what is the relevant dimension (i.e. variable)? + dimension <- as.numeric(stringr::str_extract(names(d[[1]]), "[0-9]+")) + ## If the restyle isn't related to a dimension, exit early. + if (!length(dimension)) return() + if (is.na(dimension)) return() + + pc <- hm_parcoord.matrix() + shiny::req(pc) + ## careful of the indexing in JS (0) versus R (1)! + dimension_name <- colnames(pc$mat)[[dimension + 1]] + ## a given dimension can have multiple selected ranges + ## these will come in as 3D arrays, but a list of vectors + ## is nicer to work with + info <- d[[1]][[1]] + if (length(dim(info)) == 3) { + hm_parcoord.ranges[[dimension_name]] <- lapply(seq_len(dim(info)[2]), function(i) info[,i,]) + } else { + hm_parcoord.ranges[[dimension_name]] <- list(as.numeric(info)) + } + }) + + + + # reactive functions ############## @@ -148,7 +176,7 @@ The Clustering Analysis module performs unsupervised clustering ## Gene set level features ######### gsets = rownames(pgx$gsetX) - ##gsets = unique(unlist(COLLECTIONS[ft])) + ## gsets = unique(unlist(COLLECTIONS[ft])) gsets = unique(COLLECTIONS[[ft]]) zx = pgx$gsetX if(input$hm_customfeatures!="") { @@ -336,10 +364,8 @@ The Clustering Analysis module performs unsupervised clustering } } - ## Create reduced matrix according to topmode ####### - topmode="specific" topmode="sd" topmode <- input$hm_topmode @@ -479,6 +505,45 @@ The Clustering Analysis module performs unsupervised clustering return(filt) }) + hm_parcoord.selected <- shiny::reactive({ + + mat <- hm_parcoord.matrix()$mat + clust <- hm_parcoord.matrix()$clust + shiny::req(mat) + keep <- TRUE + for (i in names(hm_parcoord.ranges)) { + range_ <- hm_parcoord.ranges[[i]] + range_ <- range_[sapply(range_,length)>0] + if(length(range_)>0) { + keep_var <- FALSE + for (j in seq_along(range_)) { + rng <- range_[[j]] + keep_var <- keep_var | dplyr::between(mat[,i], min(rng), max(rng)) + } + keep <- keep & keep_var + } + } + list(mat=mat[keep,,drop=FALSE], clust=clust[keep]) + }) + + hm_parcoord.ranges <- shiny::reactiveValues() + + hm_parcoord.matrix <- shiny::reactive({ + + filt <- getTopMatrix() + shiny::req(filt) + zx <- filt$mat[,] + if(input$hm_pcscale) { + zx <- t(scale(t(zx))) + } + rr <- shiny::isolate(shiny::reactiveValuesToList(hm_parcoord.ranges)) + nrange <- length(rr) + for(i in names(rr)) hm_parcoord.ranges[[i]] <- NULL + zx <- round(zx, digits=3) + list(mat=zx, clust=filt$idx) + }) + + # plots ########## @@ -494,6 +559,12 @@ The Clustering Analysis module performs unsupervised clustering watermark=FALSE, parent = ns) + clustering_plot_hm_parcoord_server(id = "hm_parcoord", + hm_parcoord.matrix = hm_parcoord.matrix(), + watermark=FALSE + ) + + @@ -1120,150 +1191,106 @@ The Clustering Analysis module performs unsupervised clustering # end PCA refactoring ############ - ## Parallel coordinates ########## - - hm_parcoord.ranges <- shiny::reactiveValues() - - hm_parcoord.matrix <- shiny::reactive({ - - filt <- getTopMatrix() - shiny::req(filt) - zx <- filt$mat[,] - if(input$hm_pcscale) { - zx <- t(scale(t(zx))) - } - rr <- shiny::isolate(shiny::reactiveValuesToList(hm_parcoord.ranges)) - nrange <- length(rr) - for(i in names(rr)) hm_parcoord.ranges[[i]] <- NULL - zx <- round(zx, digits=3) - list(mat=zx, clust=filt$idx) - }) - - hm_parcoord.RENDER <- shiny::reactive({ - - pc <- hm_parcoord.matrix() - shiny::req(pc) - zx <- pc$mat - ## build dimensions - dimensions <- list() - for(i in 1:ncol(zx)) { - dimensions[[i]] <- list( - range = c(min(zx[,i]),max(zx[,i])), - ## constraintrange = c(100000,150000), - ## tickvals = c(0,0.5,1,2,3), - ## ticktext = c('A','AB','B','Y','Z'), - visible = TRUE, - label = colnames(zx)[i], - values = zx[,i] - ) - } - - clust.id <- as.integer(factor(pc$clust)) - table(clust.id) - - df <- data.frame(clust.id=clust.id, zx) - klrpal = rep(RColorBrewer::brewer.pal(8,"Set2"),99) - ##klrpal = rep(c("red","blue","green","yellow","magenta","cyan","black","grey"),99) - klrpal = klrpal[1:max(clust.id)] - ##klrpal <- setNames(klrpal, sort(unique(clust.id))) - klrpal2 <- lapply(1:length(klrpal),function(i) c((i-1)/(length(klrpal)-1),klrpal[i])) - - plt <- plotly::plot_ly(df, source = "pcoords") %>% - plotly::add_trace(type = 'parcoords', - line = list(color = ~clust.id, - ## colorscale = list(c(0,'red'),c(0.5,'green'),c(1,'blue')) - ##colorscale = 'Jet', - colorscale = klrpal2, - cmin = min(clust.id), cmax = max(clust.id), - showscale = FALSE - ##reversescale = TRUE - ), - dimensions = dimensions) - plt <- plt %>% - plotly::layout(margin = list(l=60, r=60, t=0, b=30)) %>% - ##config(displayModeBar = FALSE) %>% - ##config(modeBarButtonsToRemove = setdiff(all.plotly.buttons,"toImage") ) %>% - plotly::config(toImageButtonOptions = list(format='svg', width=900, height=350, scale=1.2)) %>% - plotly::config(displaylogo = FALSE) %>% - plotly::event_register("plotly_restyle") - - plt - - }) - - shiny::observeEvent( plotly::event_data("plotly_restyle", source = "pcoords"), { - ## From: https://rdrr.io/cran/plotly/src/inst/examples/shiny/event_data_parcoords/app.R - ## - d <- plotly::event_data("plotly_restyle", source = "pcoords") - ## what is the relevant dimension (i.e. variable)? - dimension <- as.numeric(stringr::str_extract(names(d[[1]]), "[0-9]+")) - ## If the restyle isn't related to a dimension, exit early. - if (!length(dimension)) return() - if (is.na(dimension)) return() - - pc <- hm_parcoord.matrix() - shiny::req(pc) - ## careful of the indexing in JS (0) versus R (1)! - dimension_name <- colnames(pc$mat)[[dimension + 1]] - ## a given dimension can have multiple selected ranges - ## these will come in as 3D arrays, but a list of vectors - ## is nicer to work with - info <- d[[1]][[1]] - if (length(dim(info)) == 3) { - hm_parcoord.ranges[[dimension_name]] <- lapply(seq_len(dim(info)[2]), function(i) info[,i,]) - } else { - hm_parcoord.ranges[[dimension_name]] <- list(as.numeric(info)) - } - }) - - hm_parcoord.selected <- shiny::reactive({ - - mat <- hm_parcoord.matrix()$mat - clust <- hm_parcoord.matrix()$clust - shiny::req(mat) - keep <- TRUE - for (i in names(hm_parcoord.ranges)) { - range_ <- hm_parcoord.ranges[[i]] - range_ <- range_[sapply(range_,length)>0] - if(length(range_)>0) { - keep_var <- FALSE - for (j in seq_along(range_)) { - rng <- range_[[j]] - keep_var <- keep_var | dplyr::between(mat[,i], min(rng), max(rng)) - } - keep <- keep & keep_var - } - } - list(mat=mat[keep,,drop=FALSE], clust=clust[keep]) - }) + # start Parallel coordinates refactoring ########## + # hm_parcoord.ranges <- shiny::reactiveValues() + # + # hm_parcoord.matrix <- shiny::reactive({ + # + # filt <- getTopMatrix() + # shiny::req(filt) + # zx <- filt$mat[,] + # if(input$hm_pcscale) { + # zx <- t(scale(t(zx))) + # } + # rr <- shiny::isolate(shiny::reactiveValuesToList(hm_parcoord.ranges)) + # nrange <- length(rr) + # for(i in names(rr)) hm_parcoord.ranges[[i]] <- NULL + # zx <- round(zx, digits=3) + # list(mat=zx, clust=filt$idx) + # }) + # + # hm_parcoord.RENDER <- shiny::reactive({ + # + # pc <- hm_parcoord.matrix() + # shiny::req(pc) + # zx <- pc$mat + # ## build dimensions + # dimensions <- list() + # for(i in 1:ncol(zx)) { + # dimensions[[i]] <- list( + # range = c(min(zx[,i]),max(zx[,i])), + # ## constraintrange = c(100000,150000), + # ## tickvals = c(0,0.5,1,2,3), + # ## ticktext = c('A','AB','B','Y','Z'), + # visible = TRUE, + # label = colnames(zx)[i], + # values = zx[,i] + # ) + # } + # + # clust.id <- as.integer(factor(pc$clust)) + # table(clust.id) + # + # df <- data.frame(clust.id=clust.id, zx) + # klrpal = rep(RColorBrewer::brewer.pal(8,"Set2"),99) + # ##klrpal = rep(c("red","blue","green","yellow","magenta","cyan","black","grey"),99) + # klrpal = klrpal[1:max(clust.id)] + # ##klrpal <- setNames(klrpal, sort(unique(clust.id))) + # klrpal2 <- lapply(1:length(klrpal),function(i) c((i-1)/(length(klrpal)-1),klrpal[i])) + # + # plt <- plotly::plot_ly(df, source = "pcoords") %>% + # plotly::add_trace(type = 'parcoords', + # line = list(color = ~clust.id, + # ## colorscale = list(c(0,'red'),c(0.5,'green'),c(1,'blue')) + # ##colorscale = 'Jet', + # colorscale = klrpal2, + # cmin = min(clust.id), cmax = max(clust.id), + # showscale = FALSE + # ##reversescale = TRUE + # ), + # dimensions = dimensions) + # plt <- plt %>% + # plotly::layout(margin = list(l=60, r=60, t=0, b=30)) %>% + # ##config(displayModeBar = FALSE) %>% + # ##config(modeBarButtonsToRemove = setdiff(all.plotly.buttons,"toImage") ) %>% + # plotly::config(toImageButtonOptions = list(format='svg', width=900, height=350, scale=1.2)) %>% + # plotly::config(displaylogo = FALSE) %>% + # plotly::event_register("plotly_restyle") + # + # plt + # + # }) - hm_parcoord_opts = shiny::tagList( - withTooltip( shiny::checkboxInput(ns('hm_pcscale'),'Scale values',TRUE), - "Scale expression values to mean=0 and SD=1.", - placement="right",options = list(container = "body")) - ) +# hm_parcoord_opts = shiny::tagList( +# withTooltip( shiny::checkboxInput(ns('hm_pcscale'),'Scale values',TRUE), +# "Scale expression values to mean=0 and SD=1.", +# placement="right",options = list(container = "body")) +# ) +# +# +# hm_parcoord_text = tagsub("The Parallel Coordinates panel +# displays the expression levels of selected genes across all conditions in the analysis. On the x-axis the experimental conditions are plotted. The y-axis shows the expression level of the genes grouped by condition. The colors correspond to the gene groups as defined by the hierarchical clustered heatmap.") - hm_parcoord_text = tagsub("The Parallel Coordinates panel -displays the expression levels of selected genes across all conditions in the analysis. On the x-axis the experimental conditions are plotted. The y-axis shows the expression level of the genes grouped by condition. The colors correspond to the gene groups as defined by the hierarchical clustered heatmap.") + # shiny::callModule( + # plotModule, + # ## hm_parcoord_module <- plotModule( + # "hm_parcoord", + # func = hm_parcoord.RENDER, ## ns = ns, + # plotlib = "plotly", ## renderFunc="renderPlotly", + # ## download.fmt = c("png","pdf","html"), ## PNG & PDF do not work!!! + # ## download.fmt = c("html"), + # options = hm_parcoord_opts, + # height = c(0.45*fullH,600), width = c("100%",1000), + # pdf.width=10, pdf.height=6, info.width="350px", + # title = "Parallel coordinates", label = "a", + # info.text = hm_parcoord_text, + # add.watermark = WATERMARK + # ## caption = hm_parcoord_text, + # ) - shiny::callModule( - plotModule, - ## hm_parcoord_module <- plotModule( - "hm_parcoord", - func = hm_parcoord.RENDER, ## ns = ns, - plotlib = "plotly", ## renderFunc="renderPlotly", - ## download.fmt = c("png","pdf","html"), ## PNG & PDF do not work!!! - ## download.fmt = c("html"), - options = hm_parcoord_opts, - height = c(0.45*fullH,600), width = c("100%",1000), - pdf.width=10, pdf.height=6, info.width="350px", - title = "Parallel coordinates", label = "a", - info.text = hm_parcoord_text, - add.watermark = WATERMARK - ## caption = hm_parcoord_text, - ) + # end Parallel coordinates refactoring ########## hm_parcoord_table.RENDER <- shiny::reactive({ diff --git a/components/board.clustering/R/clustering_ui.R b/components/board.clustering/R/clustering_ui.R index 35ecfb234..45a36e8df 100644 --- a/components/board.clustering/R/clustering_ui.R +++ b/components/board.clustering/R/clustering_ui.R @@ -96,7 +96,12 @@ ClusteringUI <- function(id) { ## ) ), shiny::tabPanel("Parallel", - plotWidget(ns("hm_parcoord")), + + clustering_plot_hm_parcoord_ui( + id ="hm_parcoord", + label= 'a', + width = c("100%",1000), + height=c(0.45*fullH,600)), br(), tableWidget(ns("hm_parcoord_table")), tags$div( class="caption", From 21bc61a74287d82dcadc77c0ecbfedd78a02bc2e Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Sun, 19 Feb 2023 19:12:24 +0100 Subject: [PATCH 08/44] `phenoplot` refactored --- .../R/clustering_plot_phenoplot.R | 143 ++++++++++++++ .../board.clustering/R/clustering_server.R | 183 ++++++++++-------- components/board.clustering/R/clustering_ui.R | 8 +- 3 files changed, 250 insertions(+), 84 deletions(-) create mode 100644 components/board.clustering/R/clustering_plot_phenoplot.R diff --git a/components/board.clustering/R/clustering_plot_phenoplot.R b/components/board.clustering/R/clustering_plot_phenoplot.R new file mode 100644 index 000000000..0cdb41906 --- /dev/null +++ b/components/board.clustering/R/clustering_plot_phenoplot.R @@ -0,0 +1,143 @@ +## +## This file is part of the Omics Playground project. +## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. +## + + +clustering_plot_phenoplot_ui <- function(id, + label='', + height + ) +{ + ns <- shiny::NS(id) + + clust_phenoplot_info = tagsub("Phenotype distribution. This figure visualizes the distribution of the available phenotype data. You can choose to put the group labels in the figure or as separate legend in the {Label} setting, in the plot {{settings}}") + + clust_phenoplot.opts <- shiny::tagList( + shiny::radioButtons(ns('clust_phenoplot_labelmode'),"Label",c("groups","legend"),inline=TRUE) + ) + + PlotModuleUI( + ns("pltmod"), + label = label, + plotlib = "base", + info.text = clust_phenoplot_info, + options = clust_phenoplot.opts, + download.fmt=c("png","pdf","csv"), + width = c("auto","100%"), + height = height + ) +} + +clustering_plot_phenoplot_server <- function(id, + pgx, + hm_getClusterPositions, + watermark=FALSE + ) +{ + moduleServer( id, function(input, output, session) { + + ns <- session$ns + + plot_data <- reactive({ + + ##pgx <- inputData() + shiny::req(pgx$Y) + + ## get t-SNE positions + clust <- hm_getClusterPositions() + ##pos = pgx$tsne2d + pos = clust$pos + + Y <- pgx$Y[rownames(pos),,drop=FALSE] + pheno = colnames(Y) + + ## don't show these... + pheno <- grep("batch|sample|donor|repl|surv",pheno, + invert=TRUE, ignore.case=TRUE,value=TRUE) + + return( + list( + pheno = pheno, + clust_phenoplot_labelmode = input$clust_phenoplot_labelmode, + pos = pos)) + }) + + + plot.RENDER <- function(){ + + pd <- plot_data() + + pheno <- pd[["pheno"]] + clust_phenoplot_labelmode <- pd[["clust_phenoplot_labelmode"]] + pos <- pd[["pos"]] + + ## layout + par(mfrow = c(3,2), mar=c(0.3,0.7,2.8,0.7)) + if(length(pheno)>=6) par(mfrow = c(4,3), mar=c(0.3,0.4,2.8,0.4)*0.8) + if(length(pheno)>=12) par(mfrow = c(5,4), mar=c(0.2,0.2,2.5,0.2)*0.8) + i=1 + + cex1 <- 1.1*c(1.8,1.3,0.8,0.5)[cut(nrow(pos),breaks=c(-1,40,200,1000,1e10))] + cex1 = cex1 * ifelse(length(pheno)>6, 0.8, 1) + cex1 = cex1 * ifelse(length(pheno)>12, 0.8, 1) + + for(i in 1:min(20,length(pheno))) { + + ## ------- set colors + colvar = factor(Y[,1]) + colvar = factor(Y[,pheno[i]]) + colvar[which(colvar %in% c(NA,""," ","NA","na"))] <- NA + colvar = factor(as.character(colvar)) + klrpal = COLORS + klr1 = klrpal[colvar] + klr1 = paste0(gplots::col2hex(klr1),"99") + jj = which(is.na(klr1)) + if(length(jj)) klr1[jj] <- "#AAAAAA22" + tt = tolower(pheno[i]) + + ## ------- start plot + base::plot( pos[,], pch=19, cex=cex1, col=klr1, + fg = gray(0.5), bty = "o", xaxt='n', yaxt='n', + xlab="tSNE1", ylab="tSNE2") + title( tt, cex.main=1.3, line=0.5, col="grey40") + if(clust_phenoplot_labelmode=="legend") { + legend("bottomright", legend=levels(colvar), fill=klrpal, + cex=0.95, y.intersp=0.85, bg="white") + } else { + grp.pos <- apply(pos,2,function(x) tapply(x,colvar,mean,na.rm=TRUE)) + grp.pos <- apply(pos,2,function(x) tapply(x,colvar,median,na.rm=TRUE)) + nvar <- length(setdiff(colvar,NA)) + if(nvar==1) { + grp.pos <- matrix(grp.pos,nrow=1) + rownames(grp.pos) <- setdiff(colvar,NA)[1] + } + labels = rownames(grp.pos) + boxes = sapply(nchar(labels),function(n) paste(rep("\u2588",n),collapse="")) + cex2 = 0.9*cex1**0.33 + text( grp.pos, labels=boxes, cex=cex2*0.95, col="#CCCCCC99") + text( grp.pos, labels=labels, font=2, cex=cex2) + } + } + + } + + + PlotModuleServer( + "pltmod", + plotlib = "base", + ##plotlib2 = "plotly", + func = plot.RENDER, + csvFunc = plot_data, ## *** downloadable data as CSV + ##renderFunc = plotly::renderPlotly, + ##renderFunc2 = plotly::renderPlotly, + res = c(85), ## resolution of plots + pdf.width = 6, pdf.height = 9, + add.watermark = watermark + ) + + + + }) + +} diff --git a/components/board.clustering/R/clustering_server.R b/components/board.clustering/R/clustering_server.R index 908fb8be4..cfcecf35a 100644 --- a/components/board.clustering/R/clustering_server.R +++ b/components/board.clustering/R/clustering_server.R @@ -552,7 +552,7 @@ The Clustering Analysis module performs unsupervised clustering watermark = FALSE) clustering_plot_clustpca_server("PCAplot", - pgx, + pgx = inputData(), r.samples = r.samples, hmpca.colvar = shiny::reactive(input$hmpca.colvar), hmpca.shapevar = shiny::reactive(input$hmpca.shapevar), @@ -564,6 +564,15 @@ The Clustering Analysis module performs unsupervised clustering watermark=FALSE ) + clustering_plot_phenoplot_server(id = "clust_phenoplot", + pgx = inputData(), + hm_getClusterPositions = hm_getClusterPositions, + watermark=FALSE + ) + + + + @@ -1292,6 +1301,9 @@ The Clustering Analysis module performs unsupervised clustering # end Parallel coordinates refactoring ########## + + # hm_parcoord_table refactored into plot module ############# + hm_parcoord_table.RENDER <- shiny::reactive({ mat = hm_parcoord.selected()$mat @@ -1328,7 +1340,10 @@ The Clustering Analysis module performs unsupervised clustering height = c(270,700) ) - ## Annotate clusters ############ + # end hm_parcoord_table ############# + + + # clustannot_plots clustannot_table refactoring into plot module ######### clustannot_plots_text = paste0('The top features of the heatmap in the Heatmap panel are divided into gene (or gene set) clusters based on their expression profile patterns. For each cluster, the platform provides a functional annotation in the Annotate cluster panel by correlating annotation features from more than 42 published reference databases, including well-known databases such as ',a_MSigDB,', ',a_KEGG,' and ',a_GO,'. In the plot settings, users can specify the level and reference set to be used under the Reference level and Reference set settings, respectively.') @@ -1686,93 +1701,97 @@ The Clustering Analysis module performs unsupervised clustering ) }) + # end clustannot_plots clustannot_table refactoring into plot module ######### - ## Phenotypes ################# - - clust_phenoplot.RENDER <- shiny::reactive({ - - ##pgx <- inputData() - shiny::req(pgx$Y) + # clust_phenoplot refactoring into plotmodule ########## - ## get t-SNE positions - clust <- hm_getClusterPositions() - ##pos = pgx$tsne2d - pos = clust$pos - - Y <- pgx$Y[rownames(pos),,drop=FALSE] - pheno = colnames(Y) - - ## don't show these... - pheno <- grep("batch|sample|donor|repl|surv",pheno, - invert=TRUE, ignore.case=TRUE,value=TRUE) + # clust_phenoplot.RENDER <- shiny::reactive({ + # + # ##pgx <- inputData() + # shiny::req(pgx$Y) + # + # ## get t-SNE positions + # clust <- hm_getClusterPositions() + # ##pos = pgx$tsne2d + # pos = clust$pos + # + # Y <- pgx$Y[rownames(pos),,drop=FALSE] + # pheno = colnames(Y) + # + # ## don't show these... + # pheno <- grep("batch|sample|donor|repl|surv",pheno, + # invert=TRUE, ignore.case=TRUE,value=TRUE) + # + # ## layout + # par(mfrow = c(3,2), mar=c(0.3,0.7,2.8,0.7)) + # if(length(pheno)>=6) par(mfrow = c(4,3), mar=c(0.3,0.4,2.8,0.4)*0.8) + # if(length(pheno)>=12) par(mfrow = c(5,4), mar=c(0.2,0.2,2.5,0.2)*0.8) + # i=1 + # + # cex1 <- 1.1*c(1.8,1.3,0.8,0.5)[cut(nrow(pos),breaks=c(-1,40,200,1000,1e10))] + # cex1 = cex1 * ifelse(length(pheno)>6, 0.8, 1) + # cex1 = cex1 * ifelse(length(pheno)>12, 0.8, 1) + # + # for(i in 1:min(20,length(pheno))) { + # + # ## ------- set colors + # colvar = factor(Y[,1]) + # colvar = factor(Y[,pheno[i]]) + # colvar[which(colvar %in% c(NA,""," ","NA","na"))] <- NA + # colvar = factor(as.character(colvar)) + # klrpal = COLORS + # klr1 = klrpal[colvar] + # klr1 = paste0(gplots::col2hex(klr1),"99") + # jj = which(is.na(klr1)) + # if(length(jj)) klr1[jj] <- "#AAAAAA22" + # tt = tolower(pheno[i]) + # + # ## ------- start plot + # base::plot( pos[,], pch=19, cex=cex1, col=klr1, + # fg = gray(0.5), bty = "o", xaxt='n', yaxt='n', + # xlab="tSNE1", ylab="tSNE2") + # title( tt, cex.main=1.3, line=0.5, col="grey40") + # if(input$clust_phenoplot_labelmode=="legend") { + # legend("bottomright", legend=levels(colvar), fill=klrpal, + # cex=0.95, y.intersp=0.85, bg="white") + # } else { + # grp.pos <- apply(pos,2,function(x) tapply(x,colvar,mean,na.rm=TRUE)) + # grp.pos <- apply(pos,2,function(x) tapply(x,colvar,median,na.rm=TRUE)) + # nvar <- length(setdiff(colvar,NA)) + # if(nvar==1) { + # grp.pos <- matrix(grp.pos,nrow=1) + # rownames(grp.pos) <- setdiff(colvar,NA)[1] + # } + # labels = rownames(grp.pos) + # boxes = sapply(nchar(labels),function(n) paste(rep("\u2588",n),collapse="")) + # cex2 = 0.9*cex1**0.33 + # text( grp.pos, labels=boxes, cex=cex2*0.95, col="#CCCCCC99") + # text( grp.pos, labels=labels, font=2, cex=cex2) + # } + # } + # }) - ## layout - par(mfrow = c(3,2), mar=c(0.3,0.7,2.8,0.7)) - if(length(pheno)>=6) par(mfrow = c(4,3), mar=c(0.3,0.4,2.8,0.4)*0.8) - if(length(pheno)>=12) par(mfrow = c(5,4), mar=c(0.2,0.2,2.5,0.2)*0.8) - i=1 + # clust_phenoplot.opts = shiny::tagList( + # shiny::radioButtons(ns('clust_phenoplot_labelmode'),"Label",c("groups","legend"),inline=TRUE) + # ) - cex1 <- 1.1*c(1.8,1.3,0.8,0.5)[cut(nrow(pos),breaks=c(-1,40,200,1000,1e10))] - cex1 = cex1 * ifelse(length(pheno)>6, 0.8, 1) - cex1 = cex1 * ifelse(length(pheno)>12, 0.8, 1) - - for(i in 1:min(20,length(pheno))) { - - ## ------- set colors - colvar = factor(Y[,1]) - colvar = factor(Y[,pheno[i]]) - colvar[which(colvar %in% c(NA,""," ","NA","na"))] <- NA - colvar = factor(as.character(colvar)) - klrpal = COLORS - klr1 = klrpal[colvar] - klr1 = paste0(gplots::col2hex(klr1),"99") - jj = which(is.na(klr1)) - if(length(jj)) klr1[jj] <- "#AAAAAA22" - tt = tolower(pheno[i]) - - ## ------- start plot - base::plot( pos[,], pch=19, cex=cex1, col=klr1, - fg = gray(0.5), bty = "o", xaxt='n', yaxt='n', - xlab="tSNE1", ylab="tSNE2") - title( tt, cex.main=1.3, line=0.5, col="grey40") - if(input$clust_phenoplot_labelmode=="legend") { - legend("bottomright", legend=levels(colvar), fill=klrpal, - cex=0.95, y.intersp=0.85, bg="white") - } else { - grp.pos <- apply(pos,2,function(x) tapply(x,colvar,mean,na.rm=TRUE)) - grp.pos <- apply(pos,2,function(x) tapply(x,colvar,median,na.rm=TRUE)) - nvar <- length(setdiff(colvar,NA)) - if(nvar==1) { - grp.pos <- matrix(grp.pos,nrow=1) - rownames(grp.pos) <- setdiff(colvar,NA)[1] - } - labels = rownames(grp.pos) - boxes = sapply(nchar(labels),function(n) paste(rep("\u2588",n),collapse="")) - cex2 = 0.9*cex1**0.33 - text( grp.pos, labels=boxes, cex=cex2*0.95, col="#CCCCCC99") - text( grp.pos, labels=labels, font=2, cex=cex2) - } - } - }) + # clust_phenoplot_info = tagsub("Phenotype distribution. This figure visualizes the distribution of the available phenotype data. You can choose to put the group labels in the figure or as separate legend in the {Label} setting, in the plot {{settings}}") - clust_phenoplot.opts = shiny::tagList( - shiny::radioButtons(ns('clust_phenoplot_labelmode'),"Label",c("groups","legend"),inline=TRUE) - ) + ## clust_phenoplot.module <- plotModule( - clust_phenoplot_info = tagsub("Phenotype distribution. This figure visualizes the distribution of the available phenotype data. You can choose to put the group labels in the figure or as separate legend in the {Label} setting, in the plot {{settings}}") + # shiny::callModule( + # plotModule, + # "clust_phenoplot", ## ns=ns, + # func = clust_phenoplot.RENDER, ## plotlib="base", + # func2 = clust_phenoplot.RENDER, ## plotlib="base", + # options = clust_phenoplot.opts, + # height = c(fullH-80,700), res = 85, + # pdf.width = 6, pdf.height = 9, + # info.text = clust_phenoplot_info, + # add.watermark = WATERMARK + # ) - ## clust_phenoplot.module <- plotModule( - shiny::callModule( - plotModule, - "clust_phenoplot", ## ns=ns, - func = clust_phenoplot.RENDER, ## plotlib="base", - func2 = clust_phenoplot.RENDER, ## plotlib="base", - options = clust_phenoplot.opts, - height = c(fullH-80,700), res = 85, - pdf.width = 6, pdf.height = 9, - info.text = clust_phenoplot_info, - add.watermark = WATERMARK - ) + # end clust_phenoplot refactoring into plotmodule ########## ## Feature ranking ########### diff --git a/components/board.clustering/R/clustering_ui.R b/components/board.clustering/R/clustering_ui.R index 45a36e8df..f7eea33aa 100644 --- a/components/board.clustering/R/clustering_ui.R +++ b/components/board.clustering/R/clustering_ui.R @@ -104,7 +104,7 @@ ClusteringUI <- function(id) { height=c(0.45*fullH,600)), br(), tableWidget(ns("hm_parcoord_table")), - tags$div( class="caption", + tags$div(class="caption", HTML("Parallel Coordinates plot. (a)The Parallel Coordinates plot displays the expression levels of selected genes across all conditions. On the x-axis the experimental conditions are plotted. The y-axis shows the expression level @@ -123,7 +123,11 @@ ClusteringUI <- function(id) { shiny::tabPanel("Annotate clusters", uiOutput(ns("hm_annotateUI"))), shiny::tabPanel("Phenotypes", - plotWidget(ns("clust_phenoplot")), + + clustering_plot_phenoplot_ui(id = ns("clust_phenoplot"), + label='', + height = c(fullH-80,700) + ), tags$div( class="caption", HTML("Phenotype distribution. The plots show the distribution of the phenotypes superposed on the t-SNE clustering. Often, we can expect the t-SNE distribution to be From e51089b6c3e49f510715fcdc765760822640948c Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Sun, 19 Feb 2023 19:14:45 +0100 Subject: [PATCH 09/44] fix missing argument --- components/board.clustering/R/clustering_plot_phenoplot.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/components/board.clustering/R/clustering_plot_phenoplot.R b/components/board.clustering/R/clustering_plot_phenoplot.R index 0cdb41906..6923dfa2f 100644 --- a/components/board.clustering/R/clustering_plot_phenoplot.R +++ b/components/board.clustering/R/clustering_plot_phenoplot.R @@ -59,6 +59,7 @@ clustering_plot_phenoplot_server <- function(id, return( list( pheno = pheno, + Y = Y, clust_phenoplot_labelmode = input$clust_phenoplot_labelmode, pos = pos)) }) @@ -67,6 +68,7 @@ clustering_plot_phenoplot_server <- function(id, plot.RENDER <- function(){ pd <- plot_data() + Y = pd[["Y"]] pheno <- pd[["pheno"]] clust_phenoplot_labelmode <- pd[["clust_phenoplot_labelmode"]] From 62492a30ce5897321e77cfe7c95a9d1acb57d6d9 Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Mon, 20 Feb 2023 07:54:25 +0100 Subject: [PATCH 10/44] `featurerank` refactored --- .../R/clustering_plot_featurerank.R | 204 +++++++++++ .../board.clustering/R/clustering_server.R | 319 +++++++++--------- components/board.clustering/R/clustering_ui.R | 8 +- 3 files changed, 376 insertions(+), 155 deletions(-) create mode 100644 components/board.clustering/R/clustering_plot_featurerank.R diff --git a/components/board.clustering/R/clustering_plot_featurerank.R b/components/board.clustering/R/clustering_plot_featurerank.R new file mode 100644 index 000000000..bb433afec --- /dev/null +++ b/components/board.clustering/R/clustering_plot_featurerank.R @@ -0,0 +1,204 @@ +## +## This file is part of the Omics Playground project. +## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. +## + + +clustering_plot_featurerank_ui <- function(id, + label='', + height, + width + ) +{ + ns <- shiny::NS(id) + + clust_featureRank_info = "Ranked discriminant score for top feature sets. The plot ranks the discriminitive power of the feature set (genes) as a cumulative discriminant score for all phenotype variables. In this way, we can find which feature set (or gene family/set) can explain the variance in the data the best.

Correlation-based discriminative power is calculated as the average '(1-cor)' between the groups. Thus, a feature set is highly discriminative if the between-group correlation is low. P-value based scoring is computed as the average negative log p-value from the ANOVA. The 'meta' method combines the score of the former methods in a multiplicative manner." + + + clust_featureRank.opts = shiny::tagList( + withTooltip( shiny::radioButtons( ns('clust_featureRank_method'),'Method:', + choices=c("p-value","correlation","meta"), + inline=TRUE), + "Choose ranking method: p-value based or correlation-based.", + placement="right", options = list(container = "body") ) + ) + + + + PlotModuleUI( + ns("pltmod"), + label = label, + plotlib = "base", + title = "Feature-set ranking", + info.text = clust_featureRank_info, + options = clust_featureRank.opts, + download.fmt=c("png","pdf","csv"), + width = width, + height = height + ) +} + +clustering_plot_featurerank_server <- function(id, + pgx, + hm_level, + watermark=FALSE + ) +{ + moduleServer( id, function(input, output, session) { + + ns <- session$ns + + calcFeatureRanking <- shiny::reactive({ + + pgx <- pgx() + hm_level <- hm_level() + + shiny::req(pgx$X, pgx$Y, pgx$gsetX, pgx$genes) + + features=X=NULL + if(hm_level=="geneset") { + features = COLLECTIONS + X = pgx$gsetX + } else { + features = pgx$families + X = pgx$X + } + + ## ------------ intersect features, set minimum set size + rownames(X) <- toupper(rownames(X)) + genes <- toupper(rownames(X)) + features <- lapply(features, toupper) + features <- lapply(features, function(f) intersect(toupper(f), genes)) + features <- features[sapply(features,length) >=10 ] + + ## ------------ Just to get current samples + ##samples = colnames(X) + samples <- selectSamplesFromSelectedLevels(pgx$Y, input_hm_samplefilter() ) + X = X[,samples] + cvar <- pgx.getCategoricalPhenotypes(pgx$Y, max.ncat=999) + cvar <- grep("sample|patient|years|days|months|gender", + cvar,invert=TRUE,value=TRUE) ## no sample IDs + cvar + Y = pgx$Y[colnames(X),cvar,drop=FALSE] + kk = which(apply(Y,2,function(y) length(unique(y))>1)) + Y = Y[,kk,drop=FALSE] + dim(Y) + + dbg("[calcFeatureRanking] dim(X)=",dim(X)) + dbg("[calcFeatureRanking] dim(Y)=",dim(Y)) + + ## ------------ Note: this takes a while. Maybe better precompute off-line... + sdx = apply(X,1,sd) + names(sdx) = rownames(X) + S = matrix(NA, nrow=length(features), ncol=ncol(Y)) + rownames(S) = names(features) + colnames(S) = colnames(Y) + + ## ------------ Create a Progress object + if(!interactive()) { + progress <- shiny::Progress$new() + on.exit(progress$close()) + progress$set(message = "Calculating feature-set scores", value = 0) + } + + gene.level = TRUE + gene.level = (input$hm_level=="gene") + i=1 + for(i in 1:ncol(Y)) { + + if(!interactive()) progress$inc(1/ncol(Y)) + + grp = Y[,i] + grp = as.character(grp) + + cat("[calcFeatureRanking] head(grp)=",head(grp),"\n") + + score = rep(NA, length(features)) + names(score) = names(features) + j=1 + for(j in 1:length(features)) { + + pp = features[[j]] + if(gene.level) { + pp = filterProbes(pgx$genes, features[[j]]) + } + pp = head(pp[order(-sdx[pp])],1000) ## how many top SD?? + pp = intersect(pp, rownames(X)) + X1 = X[pp,,drop=FALSE] + dim(X1) + ##cat(" dim(X1)=",dim(X1),"\n") + ##if( nrow(X1) + + s1 = s2 = 1 + method = input$clust_featureRank_method + if(method %in% c("correlation","meta")) { + mx = t(apply(X1, 1, function(x) tapply(x,grp,mean))) + if(nrow(mx)==0 || ncol(mx)==0) next + D = 1 - cor(mx, use="pairwise") + diag(D) = NA + s1 = mean(D,na.rm=TRUE) + } + + if(method %in% c("p-value","meta")) { + jj <- which(!is.na(grp)) + design = model.matrix( ~ grp[jj]) + suppressWarnings( fit <- limma::eBayes( limma::lmFit( X1[,jj], design)) ) + suppressWarnings( suppressMessages( top <- limma::topTable(fit) )) + ##s2 = mean(-log10(top$P.Value)) ## as score + s2 = mean(-log10(1e-99 + top$adj.P.Val),na.rm=TRUE) ## as score + } + + f = 1 + f <- (1 - exp(-(length(pp)/20)**2)) ## penalize smaller sets + score[j] = f * (s1 * s2) ** ifelse(method=="meta",0.5,1) + + } + S[,i] = score + } + S[is.na(S)] <- 0 ## missing values + return(S) + }) + + clust_featureRank.RENDER <- shiny::reactive({ + + S <- calcFeatureRanking() + + if(is.null(S) || nrow(S)==0 || ncol(S)==0 ) return(NULL) + + ## top scoring + S = tail( S[order(rowSums(S)),,drop=FALSE], 35) + + + par(mfrow=c(1,2), mar=c(5,5,3,2), oma=c(6,0,3,0)); frame() + + rownames(S) = substring(rownames(S),1,80) + + bpos = barplot( t(S), beside=FALSE, las=1, + cex.names=0.9, horiz=TRUE, + xlab="discriminant score" ) + ##title("feature-set score", cex=1.3) + cc1 = grey.colors(ncol(S)) + legend("bottomright",legend=colnames(S), fill=cc1, + cex=0.8, y.intersp=0.8, inset=c(0,0.035), bg="white") + + }) + + + PlotModuleServer( + "pltmod", + plotlib = "base", + ##plotlib2 = "plotly", + func = clust_featureRank.RENDER, + # csvFunc = plot_data, ## *** downloadable data as CSV + ##renderFunc = plotly::renderPlotly, + ##renderFunc2 = plotly::renderPlotly, + res = c(72,90), ## resolution of plots + pdf.width = 8, pdf.height = 10, + add.watermark = watermark + ) + + + + }) + +} diff --git a/components/board.clustering/R/clustering_server.R b/components/board.clustering/R/clustering_server.R index cfcecf35a..61559e74a 100644 --- a/components/board.clustering/R/clustering_server.R +++ b/components/board.clustering/R/clustering_server.R @@ -570,6 +570,12 @@ The Clustering Analysis module performs unsupervised clustering watermark=FALSE ) + clustering_plot_featurerank_server(id = "clust_featureRank", + pgx = inputData, + hm_level = input$hm_level, + watermark=FALSE + ) + @@ -1795,165 +1801,170 @@ The Clustering Analysis module performs unsupervised clustering ## Feature ranking ########### - calcFeatureRanking <- shiny::reactive({ - - shiny::req(pgx$X, pgx$Y, pgx$gsetX, pgx$genes) - - features=X=NULL - if(input$hm_level=="geneset") { - features = COLLECTIONS - X = pgx$gsetX - } else { - features = pgx$families - X = pgx$X - } - - ## ------------ intersect features, set minimum set size - rownames(X) <- toupper(rownames(X)) - genes <- toupper(rownames(X)) - features <- lapply(features, toupper) - features <- lapply(features, function(f) intersect(toupper(f), genes)) - features <- features[sapply(features,length) >=10 ] - - dbg("[calcFeatureRanking] length(features)=",length(features)) - - ## ------------ Just to get current samples - ##samples = colnames(X) - samples <- selectSamplesFromSelectedLevels(pgx$Y, input_hm_samplefilter() ) - X = X[,samples] - cvar <- pgx.getCategoricalPhenotypes(pgx$Y, max.ncat=999) - cvar <- grep("sample|patient|years|days|months|gender", - cvar,invert=TRUE,value=TRUE) ## no sample IDs - cvar - Y = pgx$Y[colnames(X),cvar,drop=FALSE] - kk = which(apply(Y,2,function(y) length(unique(y))>1)) - Y = Y[,kk,drop=FALSE] - dim(Y) - - dbg("[calcFeatureRanking] dim(X)=",dim(X)) - dbg("[calcFeatureRanking] dim(Y)=",dim(Y)) - - ## ------------ Note: this takes a while. Maybe better precompute off-line... - sdx = apply(X,1,sd) - names(sdx) = rownames(X) - S = matrix(NA, nrow=length(features), ncol=ncol(Y)) - rownames(S) = names(features) - colnames(S) = colnames(Y) - - ## ------------ Create a Progress object - if(!interactive()) { - progress <- shiny::Progress$new() - on.exit(progress$close()) - progress$set(message = "Calculating feature-set scores", value = 0) - } - - gene.level = TRUE - gene.level = (input$hm_level=="gene") - i=1 - for(i in 1:ncol(Y)) { - - if(!interactive()) progress$inc(1/ncol(Y)) - - grp = Y[,i] - grp = as.character(grp) - - cat("[calcFeatureRanking] head(grp)=",head(grp),"\n") - - score = rep(NA, length(features)) - names(score) = names(features) - j=1 - for(j in 1:length(features)) { - - pp = features[[j]] - if(gene.level) { - pp = filterProbes(pgx$genes, features[[j]]) - } - pp = head(pp[order(-sdx[pp])],1000) ## how many top SD?? - pp = intersect(pp, rownames(X)) - X1 = X[pp,,drop=FALSE] - dim(X1) - ##cat(" dim(X1)=",dim(X1),"\n") - ##if( nrow(X1) - - s1 = s2 = 1 - method = input$clust_featureRank_method - if(method %in% c("correlation","meta")) { - mx = t(apply(X1, 1, function(x) tapply(x,grp,mean))) - if(nrow(mx)==0 || ncol(mx)==0) next - D = 1 - cor(mx, use="pairwise") - diag(D) = NA - s1 = mean(D,na.rm=TRUE) - } - - if(method %in% c("p-value","meta")) { - jj <- which(!is.na(grp)) - design = model.matrix( ~ grp[jj]) - suppressWarnings( fit <- limma::eBayes( limma::lmFit( X1[,jj], design)) ) - suppressWarnings( suppressMessages( top <- limma::topTable(fit) )) - ##s2 = mean(-log10(top$P.Value)) ## as score - s2 = mean(-log10(1e-99 + top$adj.P.Val),na.rm=TRUE) ## as score - } - - f = 1 - f <- (1 - exp(-(length(pp)/20)**2)) ## penalize smaller sets - score[j] = f * (s1 * s2) ** ifelse(method=="meta",0.5,1) - - } - S[,i] = score - } - S[is.na(S)] <- 0 ## missing values - return(S) - }) - - clust_featureRank.RENDER <- shiny::reactive({ - - S <- calcFeatureRanking() - - if(is.null(S) || nrow(S)==0 || ncol(S)==0 ) return(NULL) - - ## top scoring - S = tail( S[order(rowSums(S)),,drop=FALSE], 35) - - par(mfrow=c(2,1), mar=c(1,5,3,3) ) - par(mfrow=c(1,2), mar=c(5,5,3,2), oma=c(6,0,3,0)); frame() - ## par(mfrow=c(1,1), mar=c(10,5,3,3) ) - rownames(S) = substring(rownames(S),1,80) - bpos = barplot( t(S), beside=FALSE, las=1, - cex.names=0.9, horiz=TRUE, - xlab="discriminant score" ) - ##title("feature-set score", cex=1.3) - cc1 = grey.colors(ncol(S)) - legend("bottomright",legend=colnames(S), fill=cc1, - cex=0.8, y.intersp=0.8, inset=c(0,0.035), bg="white") - - }) + # end clust_featureRank conversion to plotmodule ########### +# +# calcFeatureRanking <- shiny::reactive({ +# +# shiny::req(pgx$X, pgx$Y, pgx$gsetX, pgx$genes) +# +# features=X=NULL +# if(input$hm_level=="geneset") { +# features = COLLECTIONS +# X = pgx$gsetX +# } else { +# features = pgx$families +# X = pgx$X +# } +# +# ## ------------ intersect features, set minimum set size +# rownames(X) <- toupper(rownames(X)) +# genes <- toupper(rownames(X)) +# features <- lapply(features, toupper) +# features <- lapply(features, function(f) intersect(toupper(f), genes)) +# features <- features[sapply(features,length) >=10 ] +# +# dbg("[calcFeatureRanking] length(features)=",length(features)) +# +# ## ------------ Just to get current samples +# ##samples = colnames(X) +# samples <- selectSamplesFromSelectedLevels(pgx$Y, input_hm_samplefilter() ) +# X = X[,samples] +# cvar <- pgx.getCategoricalPhenotypes(pgx$Y, max.ncat=999) +# cvar <- grep("sample|patient|years|days|months|gender", +# cvar,invert=TRUE,value=TRUE) ## no sample IDs +# cvar +# Y = pgx$Y[colnames(X),cvar,drop=FALSE] +# kk = which(apply(Y,2,function(y) length(unique(y))>1)) +# Y = Y[,kk,drop=FALSE] +# dim(Y) +# +# dbg("[calcFeatureRanking] dim(X)=",dim(X)) +# dbg("[calcFeatureRanking] dim(Y)=",dim(Y)) +# +# ## ------------ Note: this takes a while. Maybe better precompute off-line... +# sdx = apply(X,1,sd) +# names(sdx) = rownames(X) +# S = matrix(NA, nrow=length(features), ncol=ncol(Y)) +# rownames(S) = names(features) +# colnames(S) = colnames(Y) +# +# ## ------------ Create a Progress object +# if(!interactive()) { +# progress <- shiny::Progress$new() +# on.exit(progress$close()) +# progress$set(message = "Calculating feature-set scores", value = 0) +# } +# +# gene.level = TRUE +# gene.level = (input$hm_level=="gene") +# i=1 +# for(i in 1:ncol(Y)) { +# +# if(!interactive()) progress$inc(1/ncol(Y)) +# +# grp = Y[,i] +# grp = as.character(grp) +# +# cat("[calcFeatureRanking] head(grp)=",head(grp),"\n") +# +# score = rep(NA, length(features)) +# names(score) = names(features) +# j=1 +# for(j in 1:length(features)) { +# +# pp = features[[j]] +# if(gene.level) { +# pp = filterProbes(pgx$genes, features[[j]]) +# } +# pp = head(pp[order(-sdx[pp])],1000) ## how many top SD?? +# pp = intersect(pp, rownames(X)) +# X1 = X[pp,,drop=FALSE] +# dim(X1) +# ##cat(" dim(X1)=",dim(X1),"\n") +# ##if( nrow(X1) +# +# s1 = s2 = 1 +# method = input$clust_featureRank_method +# if(method %in% c("correlation","meta")) { +# mx = t(apply(X1, 1, function(x) tapply(x,grp,mean))) +# if(nrow(mx)==0 || ncol(mx)==0) next +# D = 1 - cor(mx, use="pairwise") +# diag(D) = NA +# s1 = mean(D,na.rm=TRUE) +# } +# +# if(method %in% c("p-value","meta")) { +# jj <- which(!is.na(grp)) +# design = model.matrix( ~ grp[jj]) +# suppressWarnings( fit <- limma::eBayes( limma::lmFit( X1[,jj], design)) ) +# suppressWarnings( suppressMessages( top <- limma::topTable(fit) )) +# ##s2 = mean(-log10(top$P.Value)) ## as score +# s2 = mean(-log10(1e-99 + top$adj.P.Val),na.rm=TRUE) ## as score +# } +# +# f = 1 +# f <- (1 - exp(-(length(pp)/20)**2)) ## penalize smaller sets +# score[j] = f * (s1 * s2) ** ifelse(method=="meta",0.5,1) +# +# } +# S[,i] = score +# } +# S[is.na(S)] <- 0 ## missing values +# return(S) +# }) +# +# clust_featureRank.RENDER <- shiny::reactive({ +# +# S <- calcFeatureRanking() +# +# if(is.null(S) || nrow(S)==0 || ncol(S)==0 ) return(NULL) +# +# ## top scoring +# S = tail( S[order(rowSums(S)),,drop=FALSE], 35) +# +# par(mfrow=c(2,1), mar=c(1,5,3,3) ) +# par(mfrow=c(1,2), mar=c(5,5,3,2), oma=c(6,0,3,0)); frame() +# ## par(mfrow=c(1,1), mar=c(10,5,3,3) ) +# rownames(S) = substring(rownames(S),1,80) +# bpos = barplot( t(S), beside=FALSE, las=1, +# cex.names=0.9, horiz=TRUE, +# xlab="discriminant score" ) +# ##title("feature-set score", cex=1.3) +# cc1 = grey.colors(ncol(S)) +# legend("bottomright",legend=colnames(S), fill=cc1, +# cex=0.8, y.intersp=0.8, inset=c(0,0.035), bg="white") +# +# }) - clust_featureRank_info = "Ranked discriminant score for top feature sets. The plot ranks the discriminitive power of the feature set (genes) as a cumulative discriminant score for all phenotype variables. In this way, we can find which feature set (or gene family/set) can explain the variance in the data the best.

Correlation-based discriminative power is calculated as the average '(1-cor)' between the groups. Thus, a feature set is highly discriminative if the between-group correlation is low. P-value based scoring is computed as the average negative log p-value from the ANOVA. The 'meta' method combines the score of the former methods in a multiplicative manner." + # clust_featureRank_info = "Ranked discriminant score for top feature sets. The plot ranks the discriminitive power of the feature set (genes) as a cumulative discriminant score for all phenotype variables. In this way, we can find which feature set (or gene family/set) can explain the variance in the data the best.

Correlation-based discriminative power is calculated as the average '(1-cor)' between the groups. Thus, a feature set is highly discriminative if the between-group correlation is low. P-value based scoring is computed as the average negative log p-value from the ANOVA. The 'meta' method combines the score of the former methods in a multiplicative manner." + # + # + # clust_featureRank.opts = shiny::tagList( + # withTooltip( shiny::radioButtons( ns('clust_featureRank_method'),'Method:', + # choices=c("p-value","correlation","meta"), + # inline=TRUE), + # "Choose ranking method: p-value based or correlation-based.", + # placement="right", options = list(container = "body") ) + # ) - clust_featureRank.opts = shiny::tagList( - withTooltip( shiny::radioButtons( ns('clust_featureRank_method'),'Method:', - choices=c("p-value","correlation","meta"), - inline=TRUE), - "Choose ranking method: p-value based or correlation-based.", - placement="right", options = list(container = "body") ) - ) + # shiny::callModule( + # plotModule, + # id="clust_featureRank", + # title="Feature-set ranking", + # func = clust_featureRank.RENDER, + # func2 = clust_featureRank.RENDER, + # options = clust_featureRank.opts, + # pdf.width=8, pdf.height=10, + # height = c(fullH-80,700), + # width=c("auto",800), + # res = c(72,90), + # info.text = clust_featureRank_info, + # add.watermark = WATERMARK + # ) - shiny::callModule( - plotModule, - id="clust_featureRank", - title="Feature-set ranking", - func = clust_featureRank.RENDER, - func2 = clust_featureRank.RENDER, - options = clust_featureRank.opts, - pdf.width=8, pdf.height=10, - height = c(fullH-80,700), - width=c("auto",800), - res = c(72,90), - info.text = clust_featureRank_info, - add.watermark = WATERMARK - ) + # end clust_featureRank conversion to plotmodule ########### }) ## end of moduleServer } ## end of Board diff --git a/components/board.clustering/R/clustering_ui.R b/components/board.clustering/R/clustering_ui.R index f7eea33aa..3013c3c98 100644 --- a/components/board.clustering/R/clustering_ui.R +++ b/components/board.clustering/R/clustering_ui.R @@ -137,7 +137,13 @@ ClusteringUI <- function(id) { ) ), shiny::tabPanel("Feature ranking", - plotWidget(ns("clust_featureRank")), + + clustering_plot_featurerank_ui(id = ns("clust_featureRank"), + label='', + height = c(fullH-80,700), + width=c("auto",800) + ), + tags$div( class="caption", HTML("Feature-set ranking. Ranked discriminant score for top feature sets. The plot ranks the discriminative power of feature sets (or gene sets) as the From cf6ed2be457597e7ddbc04c14c5b4f334f7b7b67 Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Mon, 20 Feb 2023 08:42:38 +0100 Subject: [PATCH 11/44] `plots_clustannot` refactored --- .../R/clustering_plot_clustannot.R | 197 ++++++ .../board.clustering/R/clustering_server.R | 584 +++++++++--------- components/board.clustering/R/clustering_ui.R | 14 +- 3 files changed, 499 insertions(+), 296 deletions(-) create mode 100644 components/board.clustering/R/clustering_plot_clustannot.R diff --git a/components/board.clustering/R/clustering_plot_clustannot.R b/components/board.clustering/R/clustering_plot_clustannot.R new file mode 100644 index 000000000..a024359f8 --- /dev/null +++ b/components/board.clustering/R/clustering_plot_clustannot.R @@ -0,0 +1,197 @@ +## +## This file is part of the Omics Playground project. +## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. +## + + +clustering_plot_clusterannot_ui <- function(id, + label='', + height, + width + ) +{ + ns <- shiny::NS(id) + + clustannot_plots_text = paste0('The top features of the heatmap in the Heatmap panel are divided into gene (or gene set) clusters based on their expression profile patterns. For each cluster, the platform provides a functional annotation in the Annotate cluster panel by correlating annotation features from more than 42 published reference databases, including well-known databases such as ',a_MSigDB,', ',a_KEGG,' and ',a_GO,'. In the plot settings, users can specify the level and reference set to be used under the Reference level and Reference set settings, respectively.') + + clustannot_plots.opts = shiny::tagList( + withTooltip( shiny::selectInput(ns("xann_level"), "Reference level:", + choices=c("gene","geneset","phenotype"), + selected="geneset", width='80%'), + "Select the level of an anotation analysis.", + placement="left", options = list(container = "body")), + shiny::conditionalPanel( + "input.xann_level == 'geneset'", ns=ns, + withTooltip( shiny::checkboxInput(ns("xann_odds_weighting"), "Fisher test weighting"), + "Enable weighting with Fisher test probability for gene sets. This will effectively penalize small clusters and increase robustness.", + placement="left", options = list(container = "body")) + ), + withTooltip( shiny::selectInput( ns("xann_refset"), "Reference set:", choices="", width='80%'), + "Specify a reference set to be used in the annotation.", + placement="left",options = list(container = "body")) + ) + + + + PlotModuleUI( + ns("pltmod"), + label = label, + plotlib = "plotly", + title = "Functional annotation of clusters", + info.text = clustannot_plots_text, + options = clustannot_plots.opts, + download.fmt=c("png","pdf","csv"), + width = width, + height = height + ) +} + +clustering_plot_clusterannot_server <- function(id, + getClustAnnotCorrelation, + watermark=FALSE + ) +{ + moduleServer( id, function(input, output, session) { + + ns <- session$ns + + clustannot_plots.PLOTLY <- shiny::reactive({ + + rho = getClustAnnotCorrelation() + ##if(is.null(rho)) return(NULL) + shiny::req(rho) + + ##par(mfrow=c(2,3), mar=c(3.5,2,2,1), mgp=c(2,0.8,0)) + NTERMS = 6 + NTERMS = 12 + slen=40 + if(ncol(rho)>=5) { + slen=20 + } + if(ncol(rho)>6) { + NTERMS=6 + } + if(ncol(rho)<=2) { + NTERMS=22 + } + + klrpal <- omics_pal_d("muted_light")(ncol(rho)) + #klrpal <- paste0(klrpal, "B3") + + plot_list <- list() + i = 1 + for(i in 1:min(9, ncol(rho))) { + + x <- rev(head(sort(rho[,i], decreasing = TRUE), NTERMS)) + names(x) <- sub(".*:", "", names(x)) + names(x) <- gsub(GSET.PREFIX.REGEX, "", names(x)) + + y <- names(x) + y <- factor(y, levels = y) + anntitle <- function(tt) { + list( + x = 0.5, y = 1.02, + xref = "paper", yref = "paper", + xanchor = "center", yanchor = "bottom", + text = tt, font = list(size = 13), + align = "center", showarrow = FALSE + ) + } + ## NOTE: The same plotly code (originally) as in `plot_clustannot.R` + ## -> Seems it uses the function from this file, not the other one + ## TODO: clean-up; we should stick to the general setup of individual + ## scripts for the plotting functions, not inside the server scripts as agreed + plot_list[[i]] <- + plotly::plot_ly( + x = x, + y = y, + type = 'bar', + orientation = 'h', + hoverinfo = 'text', + hovertemplate = ~paste0( + ## TODO: the cluster ID in the tooltip is assigned wrongly (it's always S4), + ## needs to be fixed (or that information to be removed) + "Annotation: %{y}
", + "Cluster: ", colnames(rho)[i], "
", + "Correlation (R): ", sprintf("%1.2f", x), "", + "" + ), + ## NOTE: I suggest to not use a categorical palette for the different clusters; + ## the panels alone highlight the different groups and a single color would + ## allow for a fair comparison (in terms of visual weight), solve all + ## readability problems and would make the page much more calm + ## TODO: if you agree, set to single color instead + marker = list(color = klrpal[i]) + ) %>% + ## labeling the y-axis inside bars + plotly::add_annotations( + x = .01, + y = y, + xref = 'paper', + yref = 'y', + xanchor = 'left', + text = shortstring(y, slen), + font = list(size = 10), + showarrow = FALSE, + align = 'right' + ) %>% + plotly::layout( + ## TODO: check x axis ranges! while in the lower row x is scaled from 0 to .9, + ## in the upper it's ranging free (kinda; when you plot the axis, + ## the axis range is the same but the tooltip and axis are out of sync) + xaxis = list( + range = c(0, .9), + font = list(family = "Lato"), + titlefont = list(size = 11), + tickfont = list(size = 10), + showgrid = FALSE, + title = "\ncorrelation (R)" + ), + yaxis = list( + title = FALSE, + showgrid = FALSE, + showline = FALSE, + showticklabels = FALSE, + showgrid = FALSE, + zeroline = FALSE + ), + showlegend = FALSE, + annotations = anntitle(colnames(rho)[i]), + bargap = .2, + margin = list(l = 5, r = 0, b = 25, t = 20) + ) %>% + plotly_default1() + } + + if(length(plot_list) <= 4) { + nrows = ceiling(length(plot_list) / 2 ) + } else { + nrows = ceiling(length(plot_list) / 3 ) + } + + plotly::subplot( + plot_list, + nrows = nrows, + shareX = TRUE, + margin = c(0, 0, .05, .05) + ) %>% + plotly::config(displayModeBar = FALSE) + }) + + + PlotModuleServer( + "pltmod", + plotlib = "plotly", + ##plotlib2 = "plotly", + func = clustannot_plots.PLOTLY, + # csvFunc = plot_data, ## *** downloadable data as CSV + ##renderFunc = plotly::renderPlotly, + ##renderFunc2 = plotly::renderPlotly, + res = 80, ## resolution of plots + pdf.width = 8, pdf.height = 5, + add.watermark = watermark + ) + + }) + +} diff --git a/components/board.clustering/R/clustering_server.R b/components/board.clustering/R/clustering_server.R index 61559e74a..0c5bb6e59 100644 --- a/components/board.clustering/R/clustering_server.R +++ b/components/board.clustering/R/clustering_server.R @@ -151,10 +151,37 @@ The Clustering Analysis module performs unsupervised clustering } }) + shiny::observe({ + ##pgx <- inputData() + shiny::req(pgx$X,pgx$gsetX,pgx$families) - - + if(is.null(input$xann_level)) return(NULL) + ann.types=sel=NULL + if(input$xann_level!="phenotype") { + if(input$xann_level=="geneset") { + ann.types <- names(COLLECTIONS) + cc = sapply(COLLECTIONS,function(s) length(intersect(s,rownames(pgx$gsetX)))) + ann.types <- ann.types[cc>=3] + } + if(input$xann_level=="gene") { + ann.types <- names(pgx$families) + cc = sapply(pgx$families,function(g) length(intersect(g,rownames(pgx$X)))) + ann.types <- ann.types[cc>=3] + } + ann.types <- setdiff(ann.types,"") ## avoid slow... + ann.types <- grep("^<",ann.types,invert=TRUE,value=TRUE) ## remove special groups + sel = ann.types[1] + if("H" %in% ann.types) sel = "H" + j <- grep("^transcription",ann.types,ignore.case=TRUE) + if(input$xann_level=="geneset") j <- grep("hallmark",ann.types,ignore.case=TRUE) + if(length(j)>0) sel = ann.types[j[1]] + ann.types <- sort(ann.types) + } else { + ann.types = sel = "" + } + shiny::updateSelectInput(session, "xann_refset", choices=ann.types, selected=sel) + }) # reactive functions ############## @@ -543,6 +570,112 @@ The Clustering Analysis module performs unsupervised clustering list(mat=zx, clust=filt$idx) }) + getClustAnnotCorrelation <- shiny::reactive({ + + ##pgx <- inputData() + shiny::req(pgx$X,pgx$Y,pgx$gsetX,pgx$families) + + filt <- getTopMatrix() + shiny::req(filt) + + zx <- filt$mat + idx <- filt$idx + samples <- filt$samples + + if(nrow(zx) <= 1) return(NULL) + + ann.level="geneset" + ann.refset="Hallmark collection" + ann.level = input$xann_level + ##if(is.null(ann.level)) return(NULL) + ann.refset = input$xann_refset + ##if(is.null(ann.refset)) return(NULL) + shiny::req(input$xann_level, input$xann_refset) + + ref = NULL + ref = pgx$gsetX[,,drop=FALSE] + ref = pgx$X[,,drop=FALSE] + if(ann.level=="gene" && ann.refset %in% names(pgx$families) ) { + gg = pgx$families[[ann.refset]] + jj = match(toupper(gg), toupper(pgx$genes$gene_name)) + jj <- setdiff(jj,NA) + pp = rownames(pgx$genes)[jj] + ref = pgx$X[intersect(pp,rownames(pgx$X)),,drop=FALSE] + } + if(ann.level=="geneset" && ann.refset %in% names(COLLECTIONS)) { + ss = COLLECTIONS[[ann.refset]] + ss = intersect(ss, rownames(pgx$gsetX)) + length(ss) + ref = pgx$gsetX[ss,] + } + if(ann.level=="phenotype") { + ref = t(expandAnnotationMatrix(pgx$Y)) + } + if(is.null(ref)) { + cat(" WARNING:: ref error\n") + return(NULL) + } + + ##----------- restrict to top?? + dim(ref) + if(nrow(ref)>1000) { + ref = head(ref[order(-apply(ref,1,sd)),],1000) + } + + ##----------- get original data level + X = pgx$X + if(input$hm_level=="geneset") X <- pgx$gsetX + + ##----------- for each gene cluster compute average correlation + hm_topmode = "sd" + hm_topmode <- input$hm_topmode + idxx = setdiff(idx, c(NA," "," ")) + rho <- matrix(NA, nrow(ref), length(idxx)) + colnames(rho) <- idxx + rownames(rho) <- rownames(ref) + + i=1 + if(nrow(ref)>0) { + for(i in 1:length(idxx)) { + gg = rownames(zx)[which(idx==idxx[i])] + aa <- t(X[gg,samples,drop=FALSE]) + bb <- t(ref[,samples,drop=FALSE]) + ##rr = cor(aa , bb, use="pairwise", method="spearman") + rr = cor(apply(aa,2,rank), apply(bb,2,rank), use="pairwise") + if(hm_topmode=="pca") rr <- abs(rr) + rho[,i] <- colMeans(rr,na.rm=TRUE) + } + } + + if(input$hm_level=="gene" && ann.level=="geneset" && input$xann_odds_weighting ) { + table(idx) + grp <- tapply( toupper(rownames(zx)), idx, list) ## toupper for mouse!! + ##gmt <- GSETS[rownames(rho)] + gmt <- getGSETS(rownames(rho)) + bg.genes <- toupper(rownames(X)) + P <- c() + for(i in 1:ncol(rho)) { + k <- colnames(rho)[i] + res <- gset.fisher( + grp[[k]], gmt, fdr=1, min.genes=0, max.genes=Inf, + background = bg.genes ) + res <- res[rownames(rho),] + r <- res[,"odd.ratio"] + odd.prob <- r / (1+r) + ##odd.1mpv <- 1 - res[,"p.value"] + ##P <- cbind(P,odd.1mpv) + P <- cbind(P,odd.prob) + } + colnames(P) <- colnames(rho) + rownames(P) <- rownames(rho) + rho <- rho * (P/max(P)) + } + + ##rho = round(rho, digits=3) + dim(rho) + return(rho) + }) + # plots ########## @@ -576,6 +709,11 @@ The Clustering Analysis module performs unsupervised clustering watermark=FALSE ) + clustering_plot_clusterannot_server(id = "plots_clustannot", + getClustAnnotCorrelation = getClustAnnotCorrelation, + watermark=FALSE + ) + @@ -1352,301 +1490,163 @@ The Clustering Analysis module performs unsupervised clustering # clustannot_plots clustannot_table refactoring into plot module ######### - clustannot_plots_text = paste0('The top features of the heatmap in the Heatmap panel are divided into gene (or gene set) clusters based on their expression profile patterns. For each cluster, the platform provides a functional annotation in the Annotate cluster panel by correlating annotation features from more than 42 published reference databases, including well-known databases such as ',a_MSigDB,', ',a_KEGG,' and ',a_GO,'. In the plot settings, users can specify the level and reference set to be used under the Reference level and Reference set settings, respectively.') - - shiny::observe({ - - ##pgx <- inputData() - shiny::req(pgx$X,pgx$gsetX,pgx$families) - - if(is.null(input$xann_level)) return(NULL) - ann.types=sel=NULL - if(input$xann_level!="phenotype") { - if(input$xann_level=="geneset") { - ann.types <- names(COLLECTIONS) - cc = sapply(COLLECTIONS,function(s) length(intersect(s,rownames(pgx$gsetX)))) - ann.types <- ann.types[cc>=3] - } - if(input$xann_level=="gene") { - ann.types <- names(pgx$families) - cc = sapply(pgx$families,function(g) length(intersect(g,rownames(pgx$X)))) - ann.types <- ann.types[cc>=3] - } - ann.types <- setdiff(ann.types,"") ## avoid slow... - ann.types <- grep("^<",ann.types,invert=TRUE,value=TRUE) ## remove special groups - sel = ann.types[1] - if("H" %in% ann.types) sel = "H" - j <- grep("^transcription",ann.types,ignore.case=TRUE) - if(input$xann_level=="geneset") j <- grep("hallmark",ann.types,ignore.case=TRUE) - if(length(j)>0) sel = ann.types[j[1]] - ann.types <- sort(ann.types) - } else { - ann.types = sel = "" - } - shiny::updateSelectInput(session, "xann_refset", choices=ann.types, selected=sel) - }) - - - getClustAnnotCorrelation <- shiny::reactive({ - - ##pgx <- inputData() - shiny::req(pgx$X,pgx$Y,pgx$gsetX,pgx$families) - - filt <- getTopMatrix() - shiny::req(filt) - - zx <- filt$mat - idx <- filt$idx - samples <- filt$samples - - if(nrow(zx) <= 1) return(NULL) - - ann.level="geneset" - ann.refset="Hallmark collection" - ann.level = input$xann_level - ##if(is.null(ann.level)) return(NULL) - ann.refset = input$xann_refset - ##if(is.null(ann.refset)) return(NULL) - shiny::req(input$xann_level, input$xann_refset) - - ref = NULL - ref = pgx$gsetX[,,drop=FALSE] - ref = pgx$X[,,drop=FALSE] - if(ann.level=="gene" && ann.refset %in% names(pgx$families) ) { - gg = pgx$families[[ann.refset]] - jj = match(toupper(gg), toupper(pgx$genes$gene_name)) - jj <- setdiff(jj,NA) - pp = rownames(pgx$genes)[jj] - ref = pgx$X[intersect(pp,rownames(pgx$X)),,drop=FALSE] - } - if(ann.level=="geneset" && ann.refset %in% names(COLLECTIONS)) { - ss = COLLECTIONS[[ann.refset]] - ss = intersect(ss, rownames(pgx$gsetX)) - length(ss) - ref = pgx$gsetX[ss,] - } - if(ann.level=="phenotype") { - ref = t(expandAnnotationMatrix(pgx$Y)) - } - if(is.null(ref)) { - cat(" WARNING:: ref error\n") - return(NULL) - } - - ##----------- restrict to top?? - dim(ref) - if(nrow(ref)>1000) { - ref = head(ref[order(-apply(ref,1,sd)),],1000) - } - - ##----------- get original data level - X = pgx$X - if(input$hm_level=="geneset") X <- pgx$gsetX - - ##----------- for each gene cluster compute average correlation - hm_topmode = "sd" - hm_topmode <- input$hm_topmode - idxx = setdiff(idx, c(NA," "," ")) - rho <- matrix(NA, nrow(ref), length(idxx)) - colnames(rho) <- idxx - rownames(rho) <- rownames(ref) - - i=1 - if(nrow(ref)>0) { - for(i in 1:length(idxx)) { - gg = rownames(zx)[which(idx==idxx[i])] - aa <- t(X[gg,samples,drop=FALSE]) - bb <- t(ref[,samples,drop=FALSE]) - ##rr = cor(aa , bb, use="pairwise", method="spearman") - rr = cor(apply(aa,2,rank), apply(bb,2,rank), use="pairwise") - if(hm_topmode=="pca") rr <- abs(rr) - rho[,i] <- colMeans(rr,na.rm=TRUE) - } - } + # clustannot_plots_text = paste0('The top features of the heatmap in the Heatmap panel are divided into gene (or gene set) clusters based on their expression profile patterns. For each cluster, the platform provides a functional annotation in the Annotate cluster panel by correlating annotation features from more than 42 published reference databases, including well-known databases such as ',a_MSigDB,', ',a_KEGG,' and ',a_GO,'. In the plot settings, users can specify the level and reference set to be used under the Reference level and Reference set settings, respectively.') - if(input$hm_level=="gene" && ann.level=="geneset" && input$xann_odds_weighting ) { - table(idx) - grp <- tapply( toupper(rownames(zx)), idx, list) ## toupper for mouse!! - ##gmt <- GSETS[rownames(rho)] - gmt <- getGSETS(rownames(rho)) - bg.genes <- toupper(rownames(X)) - P <- c() - for(i in 1:ncol(rho)) { - k <- colnames(rho)[i] - res <- gset.fisher( - grp[[k]], gmt, fdr=1, min.genes=0, max.genes=Inf, - background = bg.genes ) - res <- res[rownames(rho),] - r <- res[,"odd.ratio"] - odd.prob <- r / (1+r) - ##odd.1mpv <- 1 - res[,"p.value"] - ##P <- cbind(P,odd.1mpv) - P <- cbind(P,odd.prob) - } - colnames(P) <- colnames(rho) - rownames(P) <- rownames(rho) - rho <- rho * (P/max(P)) - } - - ##rho = round(rho, digits=3) - dim(rho) - return(rho) - }) - - clustannot_plots.PLOTLY <- shiny::reactive({ - rho = getClustAnnotCorrelation() - ##if(is.null(rho)) return(NULL) - shiny::req(rho) - - ##par(mfrow=c(2,3), mar=c(3.5,2,2,1), mgp=c(2,0.8,0)) - NTERMS = 6 - NTERMS = 12 - slen=40 - if(ncol(rho)>=5) { - slen=20 - } - if(ncol(rho)>6) { - NTERMS=6 - } - if(ncol(rho)<=2) { - NTERMS=22 - } - - klrpal <- omics_pal_d("muted_light")(ncol(rho)) - #klrpal <- paste0(klrpal, "B3") - - plot_list <- list() - i = 1 - for(i in 1:min(9, ncol(rho))) { - - x <- rev(head(sort(rho[,i], decreasing = TRUE), NTERMS)) - names(x) <- sub(".*:", "", names(x)) - names(x) <- gsub(GSET.PREFIX.REGEX, "", names(x)) - - y <- names(x) - y <- factor(y, levels = y) - anntitle <- function(tt) { - list( - x = 0.5, y = 1.02, - xref = "paper", yref = "paper", - xanchor = "center", yanchor = "bottom", - text = tt, font = list(size = 13), - align = "center", showarrow = FALSE - ) - } - ## NOTE: The same plotly code (originally) as in `plot_clustannot.R` - ## -> Seems it uses the function from this file, not the other one - ## TODO: clean-up; we should stick to the general setup of individual - ## scripts for the plotting functions, not inside the server scripts as agreed - plot_list[[i]] <- - plotly::plot_ly( - x = x, - y = y, - type = 'bar', - orientation = 'h', - hoverinfo = 'text', - hovertemplate = ~paste0( - ## TODO: the cluster ID in the tooltip is assigned wrongly (it's always S4), - ## needs to be fixed (or that information to be removed) - "Annotation: %{y}
", - "Cluster: ", colnames(rho)[i], "
", - "Correlation (R): ", sprintf("%1.2f", x), "", - "" - ), - ## NOTE: I suggest to not use a categorical palette for the different clusters; - ## the panels alone highlight the different groups and a single color would - ## allow for a fair comparison (in terms of visual weight), solve all - ## readability problems and would make the page much more calm - ## TODO: if you agree, set to single color instead - marker = list(color = klrpal[i]) - ) %>% - ## labeling the y-axis inside bars - plotly::add_annotations( - x = .01, - y = y, - xref = 'paper', - yref = 'y', - xanchor = 'left', - text = shortstring(y, slen), - font = list(size = 10), - showarrow = FALSE, - align = 'right' - ) %>% - plotly::layout( - ## TODO: check x axis ranges! while in the lower row x is scaled from 0 to .9, - ## in the upper it's ranging free (kinda; when you plot the axis, - ## the axis range is the same but the tooltip and axis are out of sync) - xaxis = list( - range = c(0, .9), - font = list(family = "Lato"), - titlefont = list(size = 11), - tickfont = list(size = 10), - showgrid = FALSE, - title = "\ncorrelation (R)" - ), - yaxis = list( - title = FALSE, - showgrid = FALSE, - showline = FALSE, - showticklabels = FALSE, - showgrid = FALSE, - zeroline = FALSE - ), - showlegend = FALSE, - annotations = anntitle(colnames(rho)[i]), - bargap = .2, - margin = list(l = 5, r = 0, b = 25, t = 20) - ) %>% - plotly_default1() - } - - if(length(plot_list) <= 4) { - nrows = ceiling(length(plot_list) / 2 ) - } else { - nrows = ceiling(length(plot_list) / 3 ) - } - - plotly::subplot( - plot_list, - nrows = nrows, - shareX = TRUE, - margin = c(0, 0, .05, .05) - ) %>% - plotly::config(displayModeBar = FALSE) - }) + # clustannot_plots.PLOTLY <- shiny::reactive({ + # + # rho = getClustAnnotCorrelation() + # ##if(is.null(rho)) return(NULL) + # shiny::req(rho) + # + # ##par(mfrow=c(2,3), mar=c(3.5,2,2,1), mgp=c(2,0.8,0)) + # NTERMS = 6 + # NTERMS = 12 + # slen=40 + # if(ncol(rho)>=5) { + # slen=20 + # } + # if(ncol(rho)>6) { + # NTERMS=6 + # } + # if(ncol(rho)<=2) { + # NTERMS=22 + # } + # + # klrpal <- omics_pal_d("muted_light")(ncol(rho)) + # #klrpal <- paste0(klrpal, "B3") + # + # plot_list <- list() + # i = 1 + # for(i in 1:min(9, ncol(rho))) { + # + # x <- rev(head(sort(rho[,i], decreasing = TRUE), NTERMS)) + # names(x) <- sub(".*:", "", names(x)) + # names(x) <- gsub(GSET.PREFIX.REGEX, "", names(x)) + # + # y <- names(x) + # y <- factor(y, levels = y) + # anntitle <- function(tt) { + # list( + # x = 0.5, y = 1.02, + # xref = "paper", yref = "paper", + # xanchor = "center", yanchor = "bottom", + # text = tt, font = list(size = 13), + # align = "center", showarrow = FALSE + # ) + # } + # ## NOTE: The same plotly code (originally) as in `plot_clustannot.R` + # ## -> Seems it uses the function from this file, not the other one + # ## TODO: clean-up; we should stick to the general setup of individual + # ## scripts for the plotting functions, not inside the server scripts as agreed + # plot_list[[i]] <- + # plotly::plot_ly( + # x = x, + # y = y, + # type = 'bar', + # orientation = 'h', + # hoverinfo = 'text', + # hovertemplate = ~paste0( + # ## TODO: the cluster ID in the tooltip is assigned wrongly (it's always S4), + # ## needs to be fixed (or that information to be removed) + # "Annotation: %{y}
", + # "Cluster: ", colnames(rho)[i], "
", + # "Correlation (R): ", sprintf("%1.2f", x), "", + # "" + # ), + # ## NOTE: I suggest to not use a categorical palette for the different clusters; + # ## the panels alone highlight the different groups and a single color would + # ## allow for a fair comparison (in terms of visual weight), solve all + # ## readability problems and would make the page much more calm + # ## TODO: if you agree, set to single color instead + # marker = list(color = klrpal[i]) + # ) %>% + # ## labeling the y-axis inside bars + # plotly::add_annotations( + # x = .01, + # y = y, + # xref = 'paper', + # yref = 'y', + # xanchor = 'left', + # text = shortstring(y, slen), + # font = list(size = 10), + # showarrow = FALSE, + # align = 'right' + # ) %>% + # plotly::layout( + # ## TODO: check x axis ranges! while in the lower row x is scaled from 0 to .9, + # ## in the upper it's ranging free (kinda; when you plot the axis, + # ## the axis range is the same but the tooltip and axis are out of sync) + # xaxis = list( + # range = c(0, .9), + # font = list(family = "Lato"), + # titlefont = list(size = 11), + # tickfont = list(size = 10), + # showgrid = FALSE, + # title = "\ncorrelation (R)" + # ), + # yaxis = list( + # title = FALSE, + # showgrid = FALSE, + # showline = FALSE, + # showticklabels = FALSE, + # showgrid = FALSE, + # zeroline = FALSE + # ), + # showlegend = FALSE, + # annotations = anntitle(colnames(rho)[i]), + # bargap = .2, + # margin = list(l = 5, r = 0, b = 25, t = 20) + # ) %>% + # plotly_default1() + # } + # + # if(length(plot_list) <= 4) { + # nrows = ceiling(length(plot_list) / 2 ) + # } else { + # nrows = ceiling(length(plot_list) / 3 ) + # } + # + # plotly::subplot( + # plot_list, + # nrows = nrows, + # shareX = TRUE, + # margin = c(0, 0, .05, .05) + # ) %>% + # plotly::config(displayModeBar = FALSE) + # }) - clustannot_plots_opts = shiny::tagList( - withTooltip( shiny::selectInput(ns("xann_level"), "Reference level:", - choices=c("gene","geneset","phenotype"), - selected="geneset", width='80%'), - "Select the level of an anotation analysis.", - placement="left", options = list(container = "body")), - shiny::conditionalPanel( - "input.xann_level == 'geneset'", ns=ns, - withTooltip( shiny::checkboxInput(ns("xann_odds_weighting"), "Fisher test weighting"), - "Enable weighting with Fisher test probability for gene sets. This will effectively penalize small clusters and increase robustness.", - placement="left", options = list(container = "body")) - ), - withTooltip( shiny::selectInput( ns("xann_refset"), "Reference set:", choices="", width='80%'), - "Specify a reference set to be used in the annotation.", - placement="left",options = list(container = "body")) - ) + # clustannot_plots_opts = shiny::tagList( + # withTooltip( shiny::selectInput(ns("xann_level"), "Reference level:", + # choices=c("gene","geneset","phenotype"), + # selected="geneset", width='80%'), + # "Select the level of an anotation analysis.", + # placement="left", options = list(container = "body")), + # shiny::conditionalPanel( + # "input.xann_level == 'geneset'", ns=ns, + # withTooltip( shiny::checkboxInput(ns("xann_odds_weighting"), "Fisher test weighting"), + # "Enable weighting with Fisher test probability for gene sets. This will effectively penalize small clusters and increase robustness.", + # placement="left", options = list(container = "body")) + # ), + # withTooltip( shiny::selectInput( ns("xann_refset"), "Reference set:", choices="", width='80%'), + # "Specify a reference set to be used in the annotation.", + # placement="left",options = list(container = "body")) + # ) ##clustannot_plots_module <- plotModule( - shiny::callModule( - plotModule, - id="clustannot_plots", ##ns=ns, - ##func=clustannot_plots.RENDER, plotlib = "base", - func = clustannot_plots.PLOTLY, plotlib="plotly", - download.fmt = c("png","pdf"), - options = clustannot_plots_opts, - height = c(360,600), width = c("100%",1000), - pdf.width=8, pdf.height=5, res=80, - title="Functional annotation of clusters", label="a", - info.text = clustannot_plots_text, - add.watermark = WATERMARK - ) + # shiny::callModule( + # plotModule, + # id="clustannot_plots", ##ns=ns, + # ##func=clustannot_plots.RENDER, plotlib = "base", + # func = clustannot_plots.PLOTLY, plotlib="plotly", + # download.fmt = c("png","pdf"), + # options = clustannot_plots_opts, + # height = c(360,600), width = c("100%",1000), + # pdf.width=8, pdf.height=5, res=80, + # title="Functional annotation of clusters", label="a", + # info.text = clustannot_plots_text, + # add.watermark = WATERMARK + # ) clustannot_table.RENDER <- shiny::reactive({ diff --git a/components/board.clustering/R/clustering_ui.R b/components/board.clustering/R/clustering_ui.R index 3013c3c98..ea1e9a854 100644 --- a/components/board.clustering/R/clustering_ui.R +++ b/components/board.clustering/R/clustering_ui.R @@ -121,7 +121,15 @@ ClusteringUI <- function(id) { shiny::tabsetPanel( id = ns("tabs2"), shiny::tabPanel("Annotate clusters", - uiOutput(ns("hm_annotateUI"))), + clustering_plot_clusterannot_ui(id = ns("plots_clustannot"), + label='a', + height = c(360,600), + width = c("100%",1000) + ), + + # uiOutput(ns("hm_annotateUI"))), + ), + shiny::tabPanel("Phenotypes", clustering_plot_phenoplot_ui(id = ns("clust_phenoplot"), @@ -154,6 +162,4 @@ ClusteringUI <- function(id) { ) ) ) - - -} + } From 90903110a90d16716935f27d91963c7894452eb0 Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Mon, 20 Feb 2023 10:37:30 +0100 Subject: [PATCH 12/44] `table_clustannot` refactored --- .../board.clustering/R/clustering_server.R | 102 +++++++++--------- components/board.clustering/R/clustering_ui.R | 8 +- .../R/expression_table_clustannot.R | 80 ++++++++++++++ 3 files changed, 136 insertions(+), 54 deletions(-) create mode 100644 components/board.clustering/R/expression_table_clustannot.R diff --git a/components/board.clustering/R/clustering_server.R b/components/board.clustering/R/clustering_server.R index 0c5bb6e59..74072de0c 100644 --- a/components/board.clustering/R/clustering_server.R +++ b/components/board.clustering/R/clustering_server.R @@ -714,12 +714,12 @@ The Clustering Analysis module performs unsupervised clustering watermark=FALSE ) + # tables ########## - - - - - + clustering_table_clustannot_server(id = "tables_clustannot", + getClustAnnotCorrelation = getClustAnnotCorrelation, + xann_level = input$xann_level, + watermark = FALSE) # start hm_splitmap refactoring ######## @@ -1648,52 +1648,52 @@ The Clustering Analysis module performs unsupervised clustering # add.watermark = WATERMARK # ) - clustannot_table.RENDER <- shiny::reactive({ - - rho = getClustAnnotCorrelation() - if(is.null(rho)) return(NULL) - - ##rownames(rho) = shortstring(rownames(rho),50) - rho.name = shortstring(sub(".*:","",rownames(rho)),60) - ##rho = data.frame(cbind( name=rho.name, rho)) - df = data.frame( feature=rho.name, round(as.matrix(rho),digits=3)) - rownames(df) = rownames(rho) - if(input$xann_level=="geneset") { - df$feature <- wrapHyperLink(df$feature, rownames(df)) - } - - DT::datatable( - df, rownames=FALSE, escape = c(-1,-2), - extensions = c('Buttons','Scroller'), - selection=list(mode='single', target='row', selected=c(1)), - class = 'compact hover', - fillContainer = TRUE, - options=list( - dom = 'lfrtip', buttons = c('copy','csv','pdf'), - ##pageLength = 20,## lengthMenu = c(20, 30, 40, 60, 100, 250), - scrollX = TRUE, ##scrollY = TRUE, - ##scrollY = 170, - scrollY = '70vh', - scroller=TRUE, - deferRender=TRUE - ) ## end of options.list - ) %>% - DT::formatStyle(0, target='row', fontSize='11px', lineHeight='70%') - }) - - clustannot_table_info_text = "In this table, users can check mean correlation values of features in the clusters with respect to the annotation references database selected in the settings." - - ##clustannot_table_module <- tableModule( - clustannot_table_module <- shiny::callModule( - tableModule, - id = "clustannot_table", - func = clustannot_table.RENDER, - ##options = clustannot_table_opts, - info.text = clustannot_table_info_text, - title="Annotation scores", label="b", - height = c(240,700), width=c('auto',1000), - ##caption = clustannot_caption - ) + # clustannot_table.RENDER <- shiny::reactive({ + # + # rho = getClustAnnotCorrelation() + # if(is.null(rho)) return(NULL) + # + # ##rownames(rho) = shortstring(rownames(rho),50) + # rho.name = shortstring(sub(".*:","",rownames(rho)),60) + # ##rho = data.frame(cbind( name=rho.name, rho)) + # df = data.frame( feature=rho.name, round(as.matrix(rho),digits=3)) + # rownames(df) = rownames(rho) + # if(input$xann_level=="geneset") { + # df$feature <- wrapHyperLink(df$feature, rownames(df)) + # } + # + # DT::datatable( + # df, rownames=FALSE, escape = c(-1,-2), + # extensions = c('Buttons','Scroller'), + # selection=list(mode='single', target='row', selected=c(1)), + # class = 'compact hover', + # fillContainer = TRUE, + # options=list( + # dom = 'lfrtip', buttons = c('copy','csv','pdf'), + # ##pageLength = 20,## lengthMenu = c(20, 30, 40, 60, 100, 250), + # scrollX = TRUE, ##scrollY = TRUE, + # ##scrollY = 170, + # scrollY = '70vh', + # scroller=TRUE, + # deferRender=TRUE + # ) ## end of options.list + # ) %>% + # DT::formatStyle(0, target='row', fontSize='11px', lineHeight='70%') + # }) + # + # clustannot_table_info_text = "In this table, users can check mean correlation values of features in the clusters with respect to the annotation references database selected in the settings." + # + # ##clustannot_table_module <- tableModule( + # clustannot_table_module <- shiny::callModule( + # tableModule, + # id = "clustannot_table", + # func = clustannot_table.RENDER, + # ##options = clustannot_table_opts, + # info.text = clustannot_table_info_text, + # title="Annotation scores", label="b", + # height = c(240,700), width=c('auto',1000), + # ##caption = clustannot_caption + # ) clustannot_caption = "Cluster annotation. (a) Top ranked annotation features (by correlation) for each gene cluster as defined in the heatmap. (b) Table of average correlation values of annotation features, for each gene cluster." diff --git a/components/board.clustering/R/clustering_ui.R b/components/board.clustering/R/clustering_ui.R index ea1e9a854..4a14088f9 100644 --- a/components/board.clustering/R/clustering_ui.R +++ b/components/board.clustering/R/clustering_ui.R @@ -70,7 +70,6 @@ ClusteringUI <- function(id) { label = "a", height = fullH-80, width = '100%'), - # plotWidget(ns("hm_splitmap")), #FIXME tags$div( class="caption", HTML("Clustered heatmap. Heatmap showing gene expression sorted by 2-way hierarchical @@ -126,10 +125,13 @@ ClusteringUI <- function(id) { height = c(360,600), width = c("100%",1000) ), - + clustering_table_clustannot_ui(id = ns("tables_clustannot")), # uiOutput(ns("hm_annotateUI"))), + tags$div(class="caption", + HTML("Cluster annotation. (a) Top ranked annotation features (by correlation) for each gene cluster as defined in the heatmap. (b) Table of average correlation values of annotation features, for each gene cluster." + ) + ) ), - shiny::tabPanel("Phenotypes", clustering_plot_phenoplot_ui(id = ns("clust_phenoplot"), diff --git a/components/board.clustering/R/expression_table_clustannot.R b/components/board.clustering/R/expression_table_clustannot.R new file mode 100644 index 000000000..30fd408d0 --- /dev/null +++ b/components/board.clustering/R/expression_table_clustannot.R @@ -0,0 +1,80 @@ +## +## 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 +clustering_table_clustannot_ui <- function(id) { + ns <- shiny::NS(id) + + tableWidget(ns("tablemod")) +} + +#' Server side table code: expression board +#' +#' @param id +#' @param watermark +#' +#' @export +clustering_table_clustannot_server <- function(id, + getClustAnnotCorrelation, + xann_level, + watermark = FALSE) { + moduleServer(id, function(input, output, session) { + ns <- session$ns + + clustannot_table.RENDER <- shiny::reactive({ + + rho = getClustAnnotCorrelation() + xann_level <- xann_level() + if(is.null(rho)) return(NULL) + + ##rownames(rho) = shortstring(rownames(rho),50) + rho.name = shortstring(sub(".*:","",rownames(rho)),60) + ##rho = data.frame(cbind( name=rho.name, rho)) + df = data.frame( feature=rho.name, round(as.matrix(rho),digits=3)) + rownames(df) = rownames(rho) + if(xann_level=="geneset") { + df$feature <- wrapHyperLink(df$feature, rownames(df)) + } + + DT::datatable( + df, rownames=FALSE, escape = c(-1,-2), + extensions = c('Buttons','Scroller'), + selection=list(mode='single', target='row', selected=c(1)), + class = 'compact hover', + fillContainer = TRUE, + options=list( + dom = 'lfrtip', buttons = c('copy','csv','pdf'), + ##pageLength = 20,## lengthMenu = c(20, 30, 40, 60, 100, 250), + scrollX = TRUE, ##scrollY = TRUE, + ##scrollY = 170, + scrollY = '70vh', + scroller=TRUE, + deferRender=TRUE + ) ## end of options.list + ) %>% + DT::formatStyle(0, target='row', fontSize='11px', lineHeight='70%') + }) + + # clustannot_table_info_text = "In this table, users can check mean correlation values of features in the clusters with respect to the annotation references database selected in the settings." + + ##clustannot_table_module <- tableModule( + shiny::callModule( + tableModule, + id = "tablemod", + func = clustannot_table.RENDER, + ##options = clustannot_table_opts, + title="Annotation scores", label="b", + height = c(240,700), width=c('auto',1000), + ##caption = clustannot_caption + ) + }) # end module server +} # end server From 9d9653cb67585dbc41f6c0d9c72ce9e77202635f Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Mon, 20 Feb 2023 11:19:05 +0100 Subject: [PATCH 13/44] `hm_parcoord` refactored; adjust file names to match standard --- .../board.clustering/R/clustering_server.R | 4 + ...tannot.R => clustering_table_clustannot.R} | 0 .../R/clustering_table_hm_parcoord.R | 73 +++++++++++++++++++ components/board.clustering/R/clustering_ui.R | 8 +- 4 files changed, 84 insertions(+), 1 deletion(-) rename components/board.clustering/R/{expression_table_clustannot.R => clustering_table_clustannot.R} (100%) create mode 100644 components/board.clustering/R/clustering_table_hm_parcoord.R diff --git a/components/board.clustering/R/clustering_server.R b/components/board.clustering/R/clustering_server.R index 74072de0c..dfe497ccb 100644 --- a/components/board.clustering/R/clustering_server.R +++ b/components/board.clustering/R/clustering_server.R @@ -721,6 +721,10 @@ The Clustering Analysis module performs unsupervised clustering xann_level = input$xann_level, watermark = FALSE) + clustering_table_hm_parcoord_server(id = "", + hm_parcoord.selected = hm_parcoord.selected, + watermark = FALSE) + # start hm_splitmap refactoring ######## # hm_splitmap_text = tagsub("Under the Heatmap panel, hierarchical clustering can be performed on gene level or gene set level expression in which users have to specify it under the {Level} dropdown list.

Under the plot configuration {{Settings}}, users can split the samples by a phenotype class (e.g., tissue, cell type, or gender) using the {split by} setting. In addition, users can specify the top N = (50, 150, 500) features to be used in the heatmap. The ordering of top features is selected under {top mode}. The criteria to select the top features are:

  1. SD - features with the highest standard deviation across all the samples,
  2. specific - features that are overexpressed in each phenotype class compared to the rest, or by
  3. PCA - by principal components.

Users can also choose between 'relative' or 'absolute' expression scale. Under the {cexCol} and {cexRow} settings, it is also possible to adjust the cex for the column and row labels.") diff --git a/components/board.clustering/R/expression_table_clustannot.R b/components/board.clustering/R/clustering_table_clustannot.R similarity index 100% rename from components/board.clustering/R/expression_table_clustannot.R rename to components/board.clustering/R/clustering_table_clustannot.R diff --git a/components/board.clustering/R/clustering_table_hm_parcoord.R b/components/board.clustering/R/clustering_table_hm_parcoord.R new file mode 100644 index 000000000..f0833e730 --- /dev/null +++ b/components/board.clustering/R/clustering_table_hm_parcoord.R @@ -0,0 +1,73 @@ +## +## This file is part of the Omics Playground project. +## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. +## + +#' UI code for table code: clustering board +#' +#' @param id +#' @param label +#' @param height +#' @param width +#' +#' @export +clustering_table_hm_parcoord_ui <- function(id) { + ns <- shiny::NS(id) + + tableWidget(ns("tablemod")) +} + +#' Server side table code: clustering board +#' +#' @param id +#' @param watermark +#' +#' @export +clustering_table_hm_parcoord_server <- function(id = "hm_parcoord_table", + hm_parcoord.selected, + watermark = FALSE) { + moduleServer(id, function(input, output, session) { + ns <- session$ns + + hm_parcoord_table.RENDER <- shiny::reactive({ + hm_parcoord.selected <- hm_parcoord.selected() + + mat = hm_parcoord.selected$mat + clust = hm_parcoord.selected$clust + df <- data.frame(cluster=clust, mat, check.names=FALSE) + numeric.cols <- 2:ncol(df) + DT::datatable( + df, rownames=TRUE, ## escape = c(-1,-2), + extensions = c('Buttons','Scroller'), + selection=list(mode='single', target='row', selected=NULL), + class = 'compact hover', + fillContainer = TRUE, + options=list( + dom = 'lfrtip', ##buttons = c('copy','csv','pdf'), + ##pageLength = 20,## lengthMenu = c(20, 30, 40, 60, 100, 250), + scrollX = TRUE, ##scrollY = TRUE, + ##scrollY = 170, + scrollY = '70vh', + scroller=TRUE, deferRender=TRUE + ) ## end of options.list + ) %>% + DT::formatSignif(numeric.cols,3) %>% + DT::formatStyle(0, target='row', fontSize='11px', lineHeight='70%') + }) + + hm_parcoord_table_info = "In this table, users can check mean expression values of features across the conditions for the selected genes." + + shiny::callModule( + tableModule, + id = "tablemod", + func = hm_parcoord_table.RENDER, + info.text = hm_parcoord_table_info, + ##options = clustannot_table_opts, + title="Selected genes", + label="b", + height = c(240,700), + width=c('auto',1000), + ##caption = clustannot_caption + ) + }) # end module server +} # end server diff --git a/components/board.clustering/R/clustering_ui.R b/components/board.clustering/R/clustering_ui.R index 4a14088f9..d3077708a 100644 --- a/components/board.clustering/R/clustering_ui.R +++ b/components/board.clustering/R/clustering_ui.R @@ -102,7 +102,13 @@ ClusteringUI <- function(id) { width = c("100%",1000), height=c(0.45*fullH,600)), br(), - tableWidget(ns("hm_parcoord_table")), + + clustering_table_hm_parcoord_ui(ns("hm_parcoord_table")), + + #FIXME + #tableWidget(ns("hm_parcoord_table")), #FIXME + #FIXME + tags$div(class="caption", HTML("Parallel Coordinates plot. (a)The Parallel Coordinates plot displays the expression levels of selected genes across all conditions. From 8f1f817dbd3603f7a1431c059ec2c0e5798fcc28 Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Mon, 20 Feb 2023 12:05:59 +0100 Subject: [PATCH 14/44] moved hm_getClusterPositions to board server; fixed inputData --- .../R/clustering_plot_PCAplot.R | 80 +------------------ .../R/clustering_plot_featurerank.R | 2 +- .../R/clustering_plot_phenoplot.R | 3 +- .../board.clustering/R/clustering_server.R | 78 +++++++++++++++++- 4 files changed, 81 insertions(+), 82 deletions(-) diff --git a/components/board.clustering/R/clustering_plot_PCAplot.R b/components/board.clustering/R/clustering_plot_PCAplot.R index ce9ecf6c4..80260acbd 100644 --- a/components/board.clustering/R/clustering_plot_PCAplot.R +++ b/components/board.clustering/R/clustering_plot_PCAplot.R @@ -62,82 +62,6 @@ clustering_plot_clustpca_server <- function(id, moduleServer( id, function(input, output, session) { ns <- session$ns - ## Functions ############ - - hm_getClusterPositions <- shiny::reactive({ - - dbg("[plot_clustpca_server:hm_getClusterPositions] reacted!") - - ##pgx <- inputData() - ##shiny::req(pgx$tsne2d,pgx$tsne3d,pgx$cluster) - - ## take full matrix - #flt <- getFilteredMatrix() - #zx <- flt$zx - sel.samples <- r.samples() - - clustmethod="tsne";pdim=2 - do3d <- ("3D" %in% input$hmpca_options) - pdim = c(2,3)[ 1 + 1*do3d] - - pos = NULL - force.compute = FALSE - clustmethod = input$hm_clustmethod - clustmethod0 <- paste0(clustmethod,pdim,"d") - - if(clustmethod=="default" && !force.compute) { - if(pdim==2 && !is.null(pgx$tsne2d) ) { - pos <- pgx$tsne2d[sel.samples,] - } else if(pdim==3 && !is.null(pgx$tsne3d) ) { - pos <- pgx$tsne3d[sel.samples,] - } - } else if( clustmethod0 %in% names(pgx$cluster$pos)) { - shiny::showNotification(paste("switching to ",clustmethod0," layout...\n")) - pos <- pgx$cluster$pos[[clustmethod0]] - if(pdim==2) pos <- pos[sel.samples,1:2] - if(pdim==3) pos <- pos[sel.samples,1:3] - } else { - ##!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ## This should not be necessary anymore as we prefer to - ## precompute all clusterings. - shiny::showNotification(paste("computing ",clustmethod,"...\n")) - - ntop = 1000 - ## ntop = as.integer(input$hm_ntop2) - zx <- pgx$X - zx = zx[order(-apply(zx,1,sd)),,drop=FALSE] ## OK? - if(nrow(zx) > ntop) { - ##zx = head(zx,ntop) ## OK? - zx = zx[1:ntop,,drop=FALSE] ## OK? - } - if("normalize" %in% input$hmpca_options) { - zx <- scale(t(scale(t(zx)))) - } - perplexity = max(1,min((ncol(zx)-1)/3, 30)) - perplexity - res <- pgx.clusterMatrix( - zx, dims = pdim, perplexity = perplexity, - ntop = 999999, prefix = "C", - find.clusters = FALSE, kclust = 1, - row.center = TRUE, row.scale = FALSE, - method = clustmethod) - if(pdim==2) pos <- res$pos2d - if(pdim==3) pos <- res$pos3d - } - - pos <- pos[sel.samples,] - pos <- scale(pos) ## scale - ##colnames(pos) = paste0("dim",1:ncol(pos)) - ##rownames(pos) = colnames(zx) - - idx <- NULL - dbg("[hm_getClusterPositions] done") - - clust = list(pos=pos, clust=idx) - - return(clust) - }) - ## Plot ############ plot_data <- shiny::reactive({ @@ -149,7 +73,8 @@ clustering_plot_clustpca_server <- function(id, hmpca_options = input$hmpca_options, hmpca.colvar = hmpca.colvar(), hmpca.shapevar = hmpca.shapevar(), - df = data.frame( x=clust$pos[,1], y=clust$pos[,2]) + df = data.frame( x=clust$pos[,1], y=clust$pos[,2]), + pgx = pgx ) ) @@ -164,6 +89,7 @@ clustering_plot_clustpca_server <- function(id, hmpca.colvar <- pd[['hmpca.colvar']] hmpca.shapevar <- pd[['hmpca.shapevar']] pos <- pd[['df']] + pgx <- pd[['pgx']] dbg("[plot_clustpca_server:plot.RENDER] function called!") diff --git a/components/board.clustering/R/clustering_plot_featurerank.R b/components/board.clustering/R/clustering_plot_featurerank.R index bb433afec..24eb13258 100644 --- a/components/board.clustering/R/clustering_plot_featurerank.R +++ b/components/board.clustering/R/clustering_plot_featurerank.R @@ -50,7 +50,7 @@ clustering_plot_featurerank_server <- function(id, calcFeatureRanking <- shiny::reactive({ - pgx <- pgx() + pgx <- pgx hm_level <- hm_level() shiny::req(pgx$X, pgx$Y, pgx$gsetX, pgx$genes) diff --git a/components/board.clustering/R/clustering_plot_phenoplot.R b/components/board.clustering/R/clustering_plot_phenoplot.R index 6923dfa2f..ae3143c02 100644 --- a/components/board.clustering/R/clustering_plot_phenoplot.R +++ b/components/board.clustering/R/clustering_plot_phenoplot.R @@ -40,8 +40,9 @@ clustering_plot_phenoplot_server <- function(id, ns <- session$ns plot_data <- reactive({ + browser() - ##pgx <- inputData() + pgx <- pgx shiny::req(pgx$Y) ## get t-SNE positions diff --git a/components/board.clustering/R/clustering_server.R b/components/board.clustering/R/clustering_server.R index dfe497ccb..a8fb54302 100644 --- a/components/board.clustering/R/clustering_server.R +++ b/components/board.clustering/R/clustering_server.R @@ -676,6 +676,78 @@ The Clustering Analysis module performs unsupervised clustering return(rho) }) + hm_getClusterPositions <- shiny::reactive({ + + pgx <- pgx + ##shiny::req(pgx$tsne2d,pgx$tsne3d,pgx$cluster) + + ## take full matrix + #flt <- getFilteredMatrix() + #zx <- flt$zx + sel.samples <- r.samples() + + clustmethod="tsne";pdim=2 + do3d <- ("3D" %in% input$hmpca_options) + pdim = c(2,3)[ 1 + 1*do3d] + + pos = NULL + force.compute = FALSE + clustmethod = input$hm_clustmethod + clustmethod0 <- paste0(clustmethod,pdim,"d") + + if(clustmethod=="default" && !force.compute) { + if(pdim==2 && !is.null(pgx$tsne2d) ) { + pos <- pgx$tsne2d[sel.samples,] + } else if(pdim==3 && !is.null(pgx$tsne3d) ) { + pos <- pgx$tsne3d[sel.samples,] + } + } else if( clustmethod0 %in% names(pgx$cluster$pos)) { + shiny::showNotification(paste("switching to ",clustmethod0," layout...\n")) + pos <- pgx$cluster$pos[[clustmethod0]] + if(pdim==2) pos <- pos[sel.samples,1:2] + if(pdim==3) pos <- pos[sel.samples,1:3] + } else { + ##!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ## This should not be necessary anymore as we prefer to + ## precompute all clusterings. + shiny::showNotification(paste("computing ",clustmethod,"...\n")) + + ntop = 1000 + ## ntop = as.integer(input$hm_ntop2) + zx <- pgx$X + zx = zx[order(-apply(zx,1,sd)),,drop=FALSE] ## OK? + if(nrow(zx) > ntop) { + ##zx = head(zx,ntop) ## OK? + zx = zx[1:ntop,,drop=FALSE] ## OK? + } + if("normalize" %in% input$hmpca_options) { + zx <- scale(t(scale(t(zx)))) + } + perplexity = max(1,min((ncol(zx)-1)/3, 30)) + perplexity + res <- pgx.clusterMatrix( + zx, dims = pdim, perplexity = perplexity, + ntop = 999999, prefix = "C", + find.clusters = FALSE, kclust = 1, + row.center = TRUE, row.scale = FALSE, + method = clustmethod) + if(pdim==2) pos <- res$pos2d + if(pdim==3) pos <- res$pos3d + } + + pos <- pos[sel.samples,] + pos <- scale(pos) ## scale + ##colnames(pos) = paste0("dim",1:ncol(pos)) + ##rownames(pos) = colnames(zx) + + idx <- NULL + dbg("[hm_getClusterPositions] done") + + clust = list(pos=pos, clust=idx) + + return(clust) + }) + # plots ########## @@ -685,7 +757,7 @@ The Clustering Analysis module performs unsupervised clustering watermark = FALSE) clustering_plot_clustpca_server("PCAplot", - pgx = inputData(), + pgx = pgx, r.samples = r.samples, hmpca.colvar = shiny::reactive(input$hmpca.colvar), hmpca.shapevar = shiny::reactive(input$hmpca.shapevar), @@ -698,13 +770,13 @@ The Clustering Analysis module performs unsupervised clustering ) clustering_plot_phenoplot_server(id = "clust_phenoplot", - pgx = inputData(), + pgx = pgx, hm_getClusterPositions = hm_getClusterPositions, watermark=FALSE ) clustering_plot_featurerank_server(id = "clust_featureRank", - pgx = inputData, + pgx = pgx, hm_level = input$hm_level, watermark=FALSE ) From 181d5688537d3f09422a25b76b1e0b1c5cef05ef Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Tue, 21 Feb 2023 11:33:22 +0100 Subject: [PATCH 15/44] reactive fix --- .../R/clustering_plot_featurerank.R | 5 +- .../R/clustering_plot_phenoplot.R | 1 - .../board.clustering/R/clustering_server.R | 56 +++++++++---------- 3 files changed, 30 insertions(+), 32 deletions(-) diff --git a/components/board.clustering/R/clustering_plot_featurerank.R b/components/board.clustering/R/clustering_plot_featurerank.R index 24eb13258..95329a507 100644 --- a/components/board.clustering/R/clustering_plot_featurerank.R +++ b/components/board.clustering/R/clustering_plot_featurerank.R @@ -41,6 +41,7 @@ clustering_plot_featurerank_ui <- function(id, clustering_plot_featurerank_server <- function(id, pgx, hm_level, + hm_samplefilter, watermark=FALSE ) { @@ -51,7 +52,7 @@ clustering_plot_featurerank_server <- function(id, calcFeatureRanking <- shiny::reactive({ pgx <- pgx - hm_level <- hm_level() + hm_level <- hm_level shiny::req(pgx$X, pgx$Y, pgx$gsetX, pgx$genes) @@ -73,7 +74,7 @@ clustering_plot_featurerank_server <- function(id, ## ------------ Just to get current samples ##samples = colnames(X) - samples <- selectSamplesFromSelectedLevels(pgx$Y, input_hm_samplefilter() ) + samples <- selectSamplesFromSelectedLevels(pgx$Y, hm_samplefilter) X = X[,samples] cvar <- pgx.getCategoricalPhenotypes(pgx$Y, max.ncat=999) cvar <- grep("sample|patient|years|days|months|gender", diff --git a/components/board.clustering/R/clustering_plot_phenoplot.R b/components/board.clustering/R/clustering_plot_phenoplot.R index ae3143c02..7b6839acc 100644 --- a/components/board.clustering/R/clustering_plot_phenoplot.R +++ b/components/board.clustering/R/clustering_plot_phenoplot.R @@ -40,7 +40,6 @@ clustering_plot_phenoplot_server <- function(id, ns <- session$ns plot_data <- reactive({ - browser() pgx <- pgx shiny::req(pgx$Y) diff --git a/components/board.clustering/R/clustering_server.R b/components/board.clustering/R/clustering_server.R index a8fb54302..6bdd0123c 100644 --- a/components/board.clustering/R/clustering_server.R +++ b/components/board.clustering/R/clustering_server.R @@ -25,10 +25,12 @@ The Clustering Analysis module performs unsupervised clustering # modules ######## r.samples <- reactive({ - ##colnames(getFilteredMatrix()) - selectSamplesFromSelectedLevels(pgx$Y, input_hm_samplefilter() ) - }) + ##colnames(getFilteredMatrix()) + req(input$hm_samplefilter) + req(pgx$Y) + selectSamplesFromSelectedLevels(pgx$Y, input$hm_samplefilter) + }) # observe functions ######## @@ -59,31 +61,30 @@ The Clustering Analysis module performs unsupervised clustering ## update filter choices upon change of data set shiny::observe({ - shiny::req(pgx$X) + levels = getLevels(pgx$Y) - levels = getLevels(pgx$Y) - shiny::updateSelectInput(session, "hm_samplefilter", choices=levels) + shiny::updateSelectInput(session, "hm_samplefilter", choices=levels) - if(DEV && !is.null(pgx$gset.meta$matrices) ) { - jj = which(!sapply(pgx$gset.meta$matrices,is.null)) - mat.names = names(pgx$gset.meta$matrices)[jj] - shiny::updateRadioButtons(session, "hm_gsetmatrix", choices=mat.names, - selected="meta", inline=TRUE) - } + if(DEV && !is.null(pgx$gset.meta$matrices) ) { + jj = which(!sapply(pgx$gset.meta$matrices,is.null)) + mat.names = names(pgx$gset.meta$matrices)[jj] + shiny::updateRadioButtons(session, "hm_gsetmatrix", choices=mat.names, + selected="meta", inline=TRUE) + } - shiny::updateRadioButtons(session, "hm_splitby", selected='none') + shiny::updateRadioButtons(session, "hm_splitby", selected='none') - ## update defaults?? - ##if(ncol(pgx$X) > 80) shiny::updateNumericInput(session,"hm_cexCol", value=0) + ## update defaults?? + ##if(ncol(pgx$X) > 80) shiny::updateNumericInput(session,"hm_cexCol", value=0) - ## update defaults?? - n1 <- nrow(pgx$samples)-1 - groupings <- colnames(pgx$samples) - ## groupings <- pgx.getCategoricalPhenotypes(pgx$samples, min.ncat=2, max.ncat=n1) - groupings <- c("",sort(groupings)) - shiny::updateSelectInput(session,"hm_group", choices=groupings) - contrasts <- pgx.getContrasts(pgx) - shiny::updateSelectInput(session,"hm_contrast", choices=contrasts) + ## update defaults?? + n1 <- nrow(pgx$samples)-1 + groupings <- colnames(pgx$samples) + ## groupings <- pgx.getCategoricalPhenotypes(pgx$samples, min.ncat=2, max.ncat=n1) + groupings <- c("",sort(groupings)) + shiny::updateSelectInput(session,"hm_group", choices=groupings) + contrasts <- pgx.getContrasts(pgx) + shiny::updateSelectInput(session,"hm_contrast", choices=contrasts) }) @@ -106,10 +107,6 @@ The Clustering Analysis module performs unsupervised clustering } }) - input_hm_samplefilter <- shiny::reactive({ - input$hm_samplefilter - }) %>% shiny::debounce(3000) - ## update choices upon change of level shiny::observe({ @@ -280,7 +277,7 @@ The Clustering Analysis module performs unsupervised clustering if(nrow(zx)==0) return(NULL) dim(zx) - kk <- selectSamplesFromSelectedLevels(pgx$Y, input_hm_samplefilter() ) + kk <- selectSamplesFromSelectedLevels(pgx$Y, reactive(input$hm_samplefilter() )) zx <- zx[,kk,drop=FALSE] if( input$hm_level=="gene" && @@ -777,7 +774,8 @@ The Clustering Analysis module performs unsupervised clustering clustering_plot_featurerank_server(id = "clust_featureRank", pgx = pgx, - hm_level = input$hm_level, + hm_level = shiny::reactive(input$hm_level), + hm_samplefilter = shiny::reactive(input$hm_samplefilter), watermark=FALSE ) From 20e604b438dda5200987932962efb280e29ef030 Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Tue, 21 Feb 2023 19:52:16 +0100 Subject: [PATCH 16/44] pgx.stackedBarplot converted to plotly --- components/base/R/pgx-plotting.R | 43 +++++-------- .../R/connectivity_plot_cumEnrichmentPlot.R | 60 ++++--------------- .../R/connectivity_plot_cumFCplot.R | 25 ++------ .../board.correlation/R/correlation_ui.R | 6 +- 4 files changed, 36 insertions(+), 98 deletions(-) diff --git a/components/base/R/pgx-plotting.R b/components/base/R/pgx-plotting.R index afa30ebe2..df699e098 100644 --- a/components/base/R/pgx-plotting.R +++ b/components/base/R/pgx-plotting.R @@ -3388,38 +3388,27 @@ pgx.plotSampleClustering <- function(x, dim=2, } -pgx.stackedBarplot <- function(x, hz=FALSE, srt=NULL, cex.text=0.9, ...) -{ - ##x <- x[order(rowMeans(x,na.rm=TRUE)),] - ##barplot( t(x), beside=FALSE, las=3) - x.pos <- pmax(x,0) - x.neg <- pmin(x,0) - y0 <- max(abs(rowSums(x,na.rm=TRUE))) - y0 <- max(rowSums(pmax(x,0),na.rm=TRUE), - rowSums(pmax(-x,0),na.rm=TRUE)) - - rownames(x.neg) <- NULL - p <- NULL - if(hz==TRUE) { - ##p <- barplot( t(x.pos), horiz=TRUE, beside=FALSE, las=1, xlim=c(-1,1)*y0 ) - ##barplot( t(x.neg), horiz=TRUE, beside=FALSE, las=1, add=TRUE ) - - p <- barplot( t(x.pos), horiz=TRUE, beside=FALSE, las=1, xlim=c(-1,1)*y0, ... ) - barplot( t(x.neg), horiz=TRUE, beside=FALSE, las=1, add=TRUE, ... ) - - - } else { - p <- barplot( t(x.pos), beside=FALSE, las=3, ylim=c(-1.1,1.1)*y0, ... ) - barplot( t(x.neg), beside=FALSE, las=3, add=TRUE, ... ) +pgx.stackedBarplot <- function(x, + ylab = NULL, + showlegend + ) + { + x_plot <- cbind(data.frame(groups = rownames(x)), x) - if(!is.null(srt)) { - text(p, par("usr")[3], labels=rownames(x), srt=srt, adj=1, xpd=TRUE, cex=cex.text) - } + x_plot <- data.table::melt(x_plot, id.vars='groups',value.name = "Effect") - } + x_plot$groups <- factor(x_plot$groups, levels = rownames(x)) + plotly::plot_ly(x_plot, x = ~groups, + y = ~Effect, + type = 'bar', + name = ~variable, + color = ~variable) %>% + plotly::layout(showlegend = showlegend, barmode = 'stack', yaxis = list(title = ylab)) %>% + plotly_default1() } + ## for plotly darkmode <- function(p, dim=2) { font.par <- list( diff --git a/components/board.connectivity/R/connectivity_plot_cumEnrichmentPlot.R b/components/board.connectivity/R/connectivity_plot_cumEnrichmentPlot.R index 8722b65f3..cde766ad5 100644 --- a/components/board.connectivity/R/connectivity_plot_cumEnrichmentPlot.R +++ b/components/board.connectivity/R/connectivity_plot_cumEnrichmentPlot.R @@ -13,8 +13,8 @@ #' #' @export connectivity_plot_cumEnrichmentPlot_ui <- function(id, - label = "", - rowH = 660) { + label = "" + ) { ns <- shiny::NS(id) info_text <- strwrap( "Meta-enrichment. The barplot visualizes the cumulative enrichment @@ -42,10 +42,11 @@ connectivity_plot_cumEnrichmentPlot_ui <- function(id, PlotModuleUI(ns("plot"), title = "Cumulative enrichment", label = label, - plotlib = "base", + plotlib = "plotly", info.text = info_text, options = plot_opts, - height = c(300, 720), width = c("auto", 1000) + height = c("auto", 720), + width = c("auto", 1000) ) } @@ -134,57 +135,18 @@ connectivity_plot_cumEnrichmentPlot_server <- function(id, maxfc <- max(abs(rowSums(F, na.rm = TRUE))) xlim <- c(-1 * (min(F, na.rm = TRUE) < 0), 1.2) * maxfc - par(mfrow = c(1, 2), mar = c(4, 1, 0, 0.5), mgp = c(2.4, 1, 0)) - frame() - col1 <- grey.colors(ncol(F), start = 0.15) - pgx.stackedBarplot( - F, - las = 1, cex.names = 0.8, col = col1, hz = TRUE, - xlab = "cumulative enrichment" - ) - - fname <- sub("\\].*", "]", colnames(F)) + pgx.stackedBarplot(x = data.frame(F), + ylab = "cumulative enrichment",showlegend = FALSE + ) }) plot_RENDER2 <- shiny::reactive({ - ## - F <- cumEnrichmentTable() - if (is.null(F)) { - frame() - return(NULL) - } - - NSETS <- 40 - if (input$cumgsea_order == "FC") { - F <- F[order(-abs(F[, 1])), ] - F <- head(F, NSETS) - F <- F[order(F[, 1]), , drop = FALSE] - } else { - F <- F[order(-rowMeans(F**2)), ] - F <- head(F, NSETS) - F <- F[order(rowMeans(F)), , drop = FALSE] - } - - rownames(F) <- gsub("H:HALLMARK_", "", rownames(F)) - rownames(F) <- gsub("C2:KEGG_", "", rownames(F)) - rownames(F) <- shortstring(rownames(F), 72) - maxfc <- max(abs(rowSums(F, na.rm = TRUE))) - xlim <- c(-1 * (min(F, na.rm = TRUE) < 0), 1.2) * maxfc - - par(mfrow = c(1, 2), mar = c(4.5, 1, 0.4, 1), mgp = c(2.4, 1, 0)) - frame() - col1 <- grey.colors(ncol(F), start = 0.15) - pgx.stackedBarplot( - F, - las = 1, cex.names = 0.78, col = col1, hz = TRUE, - xlab = "cumulative enrichment" - ) - - fname <- sub("\\].*", "]", colnames(F)) + plot_RENDER() %>% plotly::layout(showlegend = TRUE) }) + PlotModuleServer( "plot", - plotlib = "base", + plotlib = "plotly", func = plot_RENDER, func2 = plot_RENDER2, csvFunc = cumEnrichmentTable, diff --git a/components/board.connectivity/R/connectivity_plot_cumFCplot.R b/components/board.connectivity/R/connectivity_plot_cumFCplot.R index 0e44bfb94..6243384b2 100644 --- a/components/board.connectivity/R/connectivity_plot_cumFCplot.R +++ b/components/board.connectivity/R/connectivity_plot_cumFCplot.R @@ -40,7 +40,7 @@ connectivity_plot_cumFCplot_ui <- function(id, PlotModuleUI(ns("plot"), title = "Cumulative foldchange", label = label, - plotlib = "base", + plotlib = "plotly", info.text = info_text, options = plot_opts, height = c(300, 600), width = c("auto", 1300), @@ -109,33 +109,20 @@ connectivity_plot_cumFCplot_server <- function(id, F1 <- F1[order(rowMeans(F1)), , drop = FALSE] } - par(mfrow = c(1, 1), mar = c(7, 3.5, 0, 0), mgp = c(2.4, 1, 0)) - maxfc <- max(abs(rowSums(F1, na.rm = TRUE))) - ylim <- c(-1 * (min(F1, na.rm = TRUE) < 0), 1.2) * maxfc - - col1 <- grey.colors(ncol(F1), start = 0.15) - pgx.stackedBarplot(F1, - cex.names = 0.85, col = col1, - ## ylim=ylim, - ylab = "cumulative logFC" - ) - F1 + pgx.stackedBarplot(x = data.frame(F1), + ylab = "Cumulative logFC", + showlegend = FALSE) }) plot_RENDER2 <- shiny::reactive({ - F1 <- plot_RENDER() - col1 <- grey.colors(ncol(F1), start = 0.15) - legend("topleft", - legend = rev(colnames(F1)), - fill = rev(col1), cex = 0.72, y.intersp = 0.85 - ) + plot_RENDER() %>% plotly::layout(showlegend = TRUE) }) PlotModuleServer( "plot", - plotlib = "base", func = plot_RENDER, func2 = plot_RENDER2, + plotlib = "plotly", csvFunc = cumulativeFCtable, pdf.height = 6, pdf.width = 9, res = c(72, 90), diff --git a/components/board.correlation/R/correlation_ui.R b/components/board.correlation/R/correlation_ui.R index 9c07e3473..7107da327 100644 --- a/components/board.correlation/R/correlation_ui.R +++ b/components/board.correlation/R/correlation_ui.R @@ -61,14 +61,14 @@ CorrelationUI <- function(id) { correlation_plot_table_corr_ui(ns("cor_barplot"), label = "a", height = c(0.45 * fullH, 700), - width = c("auto", 1200) + width = c("auto", 700) ), ), div( class = "col-md-6", correlation_plot_scattercorr_ui(ns("cor_scatter"), - height = c(fullH - 50, 760), - width = c("auto", 900) + height = c(fullH - 50, 600), + width = c("auto", 700) ) ) ), From 05b3d617f1bb8fca9991f538c47c1ed536391554 Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Wed, 22 Feb 2023 09:43:39 +0100 Subject: [PATCH 17/44] pgx.stackedBaplot code cleaning --- components/base/R/pgx-plotting.R | 16 ------ .../board.compare/R/compare_plot_cum_fc1.R | 48 ----------------- .../board.compare/R/compare_plot_cum_fc2.R | 52 +------------------ 3 files changed, 1 insertion(+), 115 deletions(-) diff --git a/components/base/R/pgx-plotting.R b/components/base/R/pgx-plotting.R index df699e098..3b2556a2b 100644 --- a/components/base/R/pgx-plotting.R +++ b/components/base/R/pgx-plotting.R @@ -7,22 +7,6 @@ ## Plotting functions ######################################################################## -if(0) { - - fc <- pgx.getMetaMatrix(ngs, level='geneset')$fc - x <- Matrix::head( fc[order(-rowMeans(fc**2)),], 60 ) - - par(mar=c(20,4,4,2), mfrow=c(1,1)) - barplot( t(x), beside=FALSE, las=3) - ##par(mgp=c(2,1,0)) - pgx.stackedBarplot(x, ylab="cumulative logFC", cex.names=0.001, srt=60, adj=1) - - par(mar=c(4,0,4,2), mfrow=c(1,2)); frame() - pgx.stackedBarplot(Matrix::head(x,40), xlab="cumulative logFC", hz=TRUE, cex.names=0.8) - - x=zx0;dim=2;method="pca" -} - heatmapWithAnnot <- function(F, anno.type=c('boxplot','barplot'), bar.height=NULL, map.height=NULL, row_fontsize=9, column_fontsize=9, diff --git a/components/board.compare/R/compare_plot_cum_fc1.R b/components/board.compare/R/compare_plot_cum_fc1.R index 71026eca5..a37a93eb2 100644 --- a/components/board.compare/R/compare_plot_cum_fc1.R +++ b/components/board.compare/R/compare_plot_cum_fc1.R @@ -73,56 +73,8 @@ compare_plot_cum_fc1_server <- function(id, plotRawValues = TRUE ) - # fig2 <- pgx.barplot.PLOTLY( - # data = data.frame( - # x = factor(rownames(F2),levels =rownames(F2)), - # y = as.numeric(F2) - # ), - # x = "x", - # y = "y", - # yaxistitle = "Cumulative foldchange", - # xaxistitle = "Genes", - # type = "bar", - # plotRawValues = TRUE - # ) - fig - # par(mfrow = c(1, 1), mar = c(4.5, 0, 1, 2), mgp = c(2.2, 0.8, 0)) - # graphics::layout(matrix(c(1, 2, 3), nrow = 1, byrow = T), widths = c(0.5, 1, 1)) - # - # frame() - # mtext(rownames(F), - # cex = 0.80, side = 2, at = (1:nrow(F) - 0.5) / nrow(F), - # las = 1, line = -12 - # ) - # col1 <- grey.colors(ncol(F1)) - # if (ncol(F1) == 1) col1 <- "grey50" - # pgx.stackedBarplot(F1, - # hz = TRUE, las = 1, col = col1, - # cex.names = 0.01, cex.lab = 1.4, space = 0.25, - # xlab = "cumulative foldchange", ylab = "" - # ) - # legend("bottomright", colnames(F1), - # fill = grey.colors(ncol(F1)), - # cex = 0.9, y.intersp = 0.9, inset = c(-0.03, 0.02), xpd = TRUE - # ) - # title("DATASET1", line = -0.35, cex.main = 1.2) - # - # col2 <- grey.colors(ncol(F2)) - # if (ncol(F2) == 1) col2 <- "grey50" - # pgx.stackedBarplot(F2, - # hz = TRUE, las = 1, col = col2, - # cex.names = 0.01, cex.lab = 1.4, space = 0.25, - # xlab = "cumulative foldchange", ylab = "" - # ) - # legend("bottomright", colnames(F2), - # fill = grey.colors(ncol(F2)), - # cex = 0.9, y.intersp = 0.9, inset = c(-0.03, 0.02), xpd = TRUE - # ) - # title("DATASET2", line = -0.35, cex.main = 1.2) - # p <- grDevices::recordPlot() - # p }) PlotModuleServer( diff --git a/components/board.compare/R/compare_plot_cum_fc2.R b/components/board.compare/R/compare_plot_cum_fc2.R index 9de125995..212035f37 100644 --- a/components/board.compare/R/compare_plot_cum_fc2.R +++ b/components/board.compare/R/compare_plot_cum_fc2.R @@ -72,57 +72,7 @@ compare_plot_cum_fc2_server <- function(id, type = "bar", plotRawValues = TRUE ) - - # fig2 <- pgx.barplot.PLOTLY( - # data = data.frame( - # x = factor(rownames(F2),levels =rownames(F2)), - # y = as.numeric(F2) - # ), - # x = "x", - # y = "y", - # yaxistitle = "Cumulative foldchange", - # xaxistitle = "Genes", - # type = "bar", - # plotRawValues = TRUE - # ) - - fig - - # par(mfrow = c(1, 1), mar = c(4.5, 0, 1, 2), mgp = c(2.2, 0.8, 0)) - # graphics::layout(matrix(c(1, 2, 3), nrow = 1, byrow = T), widths = c(0.5, 1, 1)) - # - # frame() - # mtext(rownames(F), - # cex = 0.80, side = 2, at = (1:nrow(F) - 0.5) / nrow(F), - # las = 1, line = -12 - # ) - # col1 <- grey.colors(ncol(F1)) - # if (ncol(F1) == 1) col1 <- "grey50" - # pgx.stackedBarplot(F1, - # hz = TRUE, las = 1, col = col1, - # cex.names = 0.01, cex.lab = 1.4, space = 0.25, - # xlab = "cumulative foldchange", ylab = "" - # ) - # legend("bottomright", colnames(F1), - # fill = grey.colors(ncol(F1)), - # cex = 0.9, y.intersp = 0.9, inset = c(-0.03, 0.02), xpd = TRUE - # ) - # title("DATASET1", line = -0.35, cex.main = 1.2) - # - # col2 <- grey.colors(ncol(F2)) - # if (ncol(F2) == 1) col2 <- "grey50" - # pgx.stackedBarplot(F2, - # hz = TRUE, las = 1, col = col2, - # cex.names = 0.01, cex.lab = 1.4, space = 0.25, - # xlab = "cumulative foldchange", ylab = "" - # ) - # legend("bottomright", colnames(F2), - # fill = grey.colors(ncol(F2)), - # cex = 0.9, y.intersp = 0.9, inset = c(-0.03, 0.02), xpd = TRUE - # ) - # title("DATASET2", line = -0.35, cex.main = 1.2) - # p <- grDevices::recordPlot() - # p + fig }) PlotModuleServer( From 72bdce77b874ee45a1849fa051cdec3b1099e893 Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Wed, 22 Feb 2023 10:39:06 +0100 Subject: [PATCH 18/44] fix: height, width now set correctly --- .../R/connectivity_plot_cumEnrichmentPlot.R | 8 +++++--- .../R/connectivity_plot_cumFCplot.R | 9 ++++++--- components/board.connectivity/R/connectivity_ui.R | 11 +++++++++-- 3 files changed, 20 insertions(+), 8 deletions(-) diff --git a/components/board.connectivity/R/connectivity_plot_cumEnrichmentPlot.R b/components/board.connectivity/R/connectivity_plot_cumEnrichmentPlot.R index cde766ad5..af169c847 100644 --- a/components/board.connectivity/R/connectivity_plot_cumEnrichmentPlot.R +++ b/components/board.connectivity/R/connectivity_plot_cumEnrichmentPlot.R @@ -13,7 +13,9 @@ #' #' @export connectivity_plot_cumEnrichmentPlot_ui <- function(id, - label = "" + label = "", + height, + width ) { ns <- shiny::NS(id) info_text <- strwrap( @@ -45,8 +47,8 @@ connectivity_plot_cumEnrichmentPlot_ui <- function(id, plotlib = "plotly", info.text = info_text, options = plot_opts, - height = c("auto", 720), - width = c("auto", 1000) + height = height, + width = width ) } diff --git a/components/board.connectivity/R/connectivity_plot_cumFCplot.R b/components/board.connectivity/R/connectivity_plot_cumFCplot.R index 6243384b2..9bf5208ed 100644 --- a/components/board.connectivity/R/connectivity_plot_cumFCplot.R +++ b/components/board.connectivity/R/connectivity_plot_cumFCplot.R @@ -14,7 +14,9 @@ #' @export connectivity_plot_cumFCplot_ui <- function(id, label = "", - rowH = 660) { + height, + width + ) { ns <- shiny::NS(id) info_text <- strwrap("Meta-foldchange. The barplot visualizes the cumulative foldchange between the top-10 most similar @@ -43,8 +45,9 @@ connectivity_plot_cumFCplot_ui <- function(id, plotlib = "plotly", info.text = info_text, options = plot_opts, - height = c(300, 600), width = c("auto", 1300), - ) + height = height, + width = width + ) } #' Importance plot Server function diff --git a/components/board.connectivity/R/connectivity_ui.R b/components/board.connectivity/R/connectivity_ui.R index 00ed28037..33262f996 100644 --- a/components/board.connectivity/R/connectivity_ui.R +++ b/components/board.connectivity/R/connectivity_ui.R @@ -87,11 +87,18 @@ ConnectivityUI <- function(id) { class = "row", div( class = "col-md-6", - connectivity_plot_cumFCplot_ui(ns("cumFCplot"),label = "a") + connectivity_plot_cumFCplot_ui(ns("cumFCplot"), + label = "a", + height = c("auto", 600), + width = c("auto", 900)) ), div( class = "col-md-6", - connectivity_plot_cumEnrichmentPlot_ui(ns("cumEnrichmentPlot"),label = "b") + connectivity_plot_cumEnrichmentPlot_ui(ns("cumEnrichmentPlot"), + label = "b", + height = c("auto", 600), + width = c("auto", 900) + ) ) ), shiny::br(), From ae3e72ddc9df9a467f58005e94b562fbb05a87e7 Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Wed, 22 Feb 2023 11:31:48 +0100 Subject: [PATCH 19/44] correlation_plot_table_corr stacked barplot converted to plotly --- .../R/correlation_plot_table_corr.R | 85 ++++++++++++------- 1 file changed, 52 insertions(+), 33 deletions(-) diff --git a/components/board.correlation/R/correlation_plot_table_corr.R b/components/board.correlation/R/correlation_plot_table_corr.R index a400f1d02..f6e6736d6 100644 --- a/components/board.correlation/R/correlation_plot_table_corr.R +++ b/components/board.correlation/R/correlation_plot_table_corr.R @@ -23,7 +23,7 @@ correlation_plot_table_corr_ui <- function(id, PlotModuleUI(ns("plot"), title = "Top correlated genes", label = label, - plotlib = "base", + plotlib = "plotly", info.text = info_text, download.fmt = c("png", "pdf", "csv"), width = width, @@ -69,40 +69,48 @@ correlation_plot_table_corr_server <- function(id, }) cor_barplot.PLOTFUN <- function() { - df <- plot_data() - rho <- df[[1]] - prho <- df[[2]] - - ylim0 <- c(-1, 1) * max(abs(rho)) * 1.05 - - par(mfrow = c(1, 1), mar = c(10, 4, 1, 0.5)) - barplot(rho, - beside = FALSE, las = 3, - ylim = ylim0, - ylab = "correlation", - cex.names = 0.85 - ) - barplot(prho, - beside = FALSE, add = TRUE, - col = "grey40", names.arg = "" - ) - legend("topright", - cex = 0.85, y.intersp = 0.85, - inset = c(0.035, 0), - c("correlation", "partial correlation"), - fill = c("grey70", "grey40") - ) + + pd <- plot_data() + + pd_rho <- data.frame(genes = names(pd[[1]]), rho = pd[[1]]) + pd_prho <- data.frame(genes = names(pd[[2]]), rho = pd[[2]]) + + pd_plot <- base::merge(pd_rho,pd_prho, by = "genes") + + pd_plot <- pd_plot[complete.cases(pd_plot),] + + rownames(pd_plot) <-pd_plot$genes + + pd_plot$genes <- NULL + + colnames(pd_plot) <- c("Correlation", "Partial correlation") + + pd_plot <- pd_plot[order(pd_plot$Correlation,decreasing = TRUE),] + + pgx.stackedBarplot(x = pd_plot, + ylab = "Correlation", + showlegend = TRUE) + + + # par(mfrow = c(1, 1), mar = c(10, 4, 1, 0.5)) + # barplot(rho, + # beside = FALSE, las = 3, + # ylim = ylim0, + # ylab = "correlation", + # cex.names = 0.85 + # ) + # barplot(prho, + # beside = FALSE, add = TRUE, + # col = "grey40", names.arg = "" + # ) + # legend("topright", + # cex = 0.85, y.intersp = 0.85, + # inset = c(0.035, 0), + # c("correlation", "partial correlation"), + # fill = c("grey70", "grey40") + # ) } - PlotModuleServer( - "plot", - plotlib = "base", - func = cor_barplot.PLOTFUN, - csvFunc = plot_data, ## *** downloadable data as CSV - res = c(63, 100), ## resolution of plots - pdf.width = 6, pdf.height = 6, - add.watermark = watermark - ) ### TABLE @@ -169,5 +177,16 @@ correlation_plot_table_corr_server <- function(id, height = c(360, 700), width = c("auto", 1400) ## caption = dgca_caption ) + + PlotModuleServer( + "plot", + plotlib = "plotly", + func = cor_barplot.PLOTFUN, + csvFunc = plot_data, ## *** downloadable data as CSV + res = c(63, 100), ## resolution of plots + pdf.width = 6, pdf.height = 6, + add.watermark = watermark + ) + }) ## end of moduleServer } From 8f27450af177bef15ef8f69c8aa2ccd1e33ea33d Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Wed, 22 Feb 2023 12:27:23 +0100 Subject: [PATCH 20/44] fix: now `connectivity_ui` has correct height and width params --- .../R/connectivity_plot_cumEnrichmentPlot.R | 8 ++++---- .../board.connectivity/R/connectivity_plot_cumFCplot.R | 3 +-- components/board.connectivity/R/connectivity_ui.R | 9 ++++----- 3 files changed, 9 insertions(+), 11 deletions(-) diff --git a/components/board.connectivity/R/connectivity_plot_cumEnrichmentPlot.R b/components/board.connectivity/R/connectivity_plot_cumEnrichmentPlot.R index af169c847..31903aae2 100644 --- a/components/board.connectivity/R/connectivity_plot_cumEnrichmentPlot.R +++ b/components/board.connectivity/R/connectivity_plot_cumEnrichmentPlot.R @@ -13,10 +13,10 @@ #' #' @export connectivity_plot_cumEnrichmentPlot_ui <- function(id, - label = "", - height, - width - ) { + label = "", + height, + width + ) { ns <- shiny::NS(id) info_text <- strwrap( "Meta-enrichment. The barplot visualizes the cumulative enrichment diff --git a/components/board.connectivity/R/connectivity_plot_cumFCplot.R b/components/board.connectivity/R/connectivity_plot_cumFCplot.R index 9bf5208ed..405f47a47 100644 --- a/components/board.connectivity/R/connectivity_plot_cumFCplot.R +++ b/components/board.connectivity/R/connectivity_plot_cumFCplot.R @@ -15,8 +15,7 @@ connectivity_plot_cumFCplot_ui <- function(id, label = "", height, - width - ) { + width) { ns <- shiny::NS(id) info_text <- strwrap("Meta-foldchange. The barplot visualizes the cumulative foldchange between the top-10 most similar diff --git a/components/board.connectivity/R/connectivity_ui.R b/components/board.connectivity/R/connectivity_ui.R index 33262f996..a285e467b 100644 --- a/components/board.connectivity/R/connectivity_ui.R +++ b/components/board.connectivity/R/connectivity_ui.R @@ -89,16 +89,15 @@ ConnectivityUI <- function(id) { class = "col-md-6", connectivity_plot_cumFCplot_ui(ns("cumFCplot"), label = "a", - height = c("auto", 600), - width = c("auto", 900)) + height = c(300, 600), + width = c("auto", 1300)) ), div( class = "col-md-6", connectivity_plot_cumEnrichmentPlot_ui(ns("cumEnrichmentPlot"), label = "b", - height = c("auto", 600), - width = c("auto", 900) - ) + height = c(300, 600), + width = c("auto", 1000)) ) ), shiny::br(), From ff93b18895ecffd71ac049f0ec4614d0b94d7d0c Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Wed, 22 Feb 2023 14:52:01 +0100 Subject: [PATCH 21/44] feat: freq_top_gsets converted to plotly --- .../R/enrichment_plot_freq_top_gsets.R | 97 +++++++++---------- 1 file changed, 45 insertions(+), 52 deletions(-) diff --git a/components/board.enrichment/R/enrichment_plot_freq_top_gsets.R b/components/board.enrichment/R/enrichment_plot_freq_top_gsets.R index 211de183f..d5cf91c60 100644 --- a/components/board.enrichment/R/enrichment_plot_freq_top_gsets.R +++ b/components/board.enrichment/R/enrichment_plot_freq_top_gsets.R @@ -51,43 +51,8 @@ enrichment_plot_freq_top_gsets_server <- function(id, gseatable, watermark = FALSE) { moduleServer(id, function(input, output, session) { - plotEnrichFreq <- function(ngs, rpt, ntop, ngenes, gset.weight, fcweight) { - fx.col <- grep("score|fx|fc|sign|NES|logFC", colnames(rpt))[1] - fx <- rpt[, fx.col] - names(fx) <- rownames(rpt) - - top <- rownames(rpt) - top <- head(top, ntop) - if (!all(top %in% colnames(ngs$GMT))) { - return(NULL) - } - - F <- 1 * (ngs$GMT[, top, drop = FALSE] > 0) - F <- as.matrix(F) - wt <- FALSE - if (gset.weight) { - F <- Matrix::t(Matrix::t(F) / Matrix::colSums(F, na.rm = TRUE)) - wt <- TRUE - } - F <- Matrix::t(Matrix::t(F) * sign(fx[top])) - if (fcweight) { - F <- Matrix::t(Matrix::t(F) * abs(fx[top])) - wt <- TRUE - } - F <- head(F[order(-Matrix::rowSums(abs(F))), , drop = FALSE], ngenes) - F <- F[order(-Matrix::rowSums(F)), , drop = FALSE] - sel.zero <- which(Matrix::rowSums(abs(F)) < 1e-4) - if (length(sel.zero)) rownames(F)[sel.zero] <- "" - - par(mfrow = c(1, 1), mar = c(6, 4, 2, 0.5), mgp = c(2.2, 0.8, 0)) - col1 <- grey.colors(ncol(F), start = 0.15) - ylab <- ifelse(wt, "weighted frequency", "frequency") - barplot(t(F), - beside = FALSE, las = 3, cex.names = 0.90, col = col1, - ylab = ylab - ) - } + req(inputData()) plot_data <- shiny::reactive({ ngs <- inputData() @@ -130,28 +95,56 @@ enrichment_plot_freq_top_gsets_server <- function(id, ntop <- dt[[3]] gset.weight <- dt[[4]] fcweight <- dt[[5]] - plotEnrichFreq(ngs, rpt, ntop = ntop, ngenes = 35, gset.weight, fcweight) - p <- grDevices::recordPlot() - p - }) + ngenes = 35 + fx.col <- grep("score|fx|fc|sign|NES|logFC", colnames(rpt))[1] + fx <- rpt[, fx.col] + names(fx) <- rownames(rpt) - topEnrichedFreq.RENDER2 <- shiny::reactive({ - dt <- plot_data() - ngs <- dt[[1]] - rpt <- dt[[2]] - ntop <- dt[[3]] - gset.weight <- dt[[4]] - fcweight <- dt[[5]] - plotEnrichFreq(ngs, rpt, ntop = ntop, ngenes = 60, gset.weight, fcweight) - p <- grDevices::recordPlot() - p + top <- rownames(rpt) + top <- head(top, ntop) + if (!all(top %in% colnames(ngs$GMT))) { + return(NULL) + } + + F <- 1 * (ngs$GMT[, top, drop = FALSE] > 0) + F <- as.matrix(F) + wt <- FALSE + if (gset.weight) { + F <- Matrix::t(Matrix::t(F) / Matrix::colSums(F, na.rm = TRUE)) + wt <- TRUE + } + F <- Matrix::t(Matrix::t(F) * sign(fx[top])) + if (fcweight) { + F <- Matrix::t(Matrix::t(F) * abs(fx[top])) + wt <- TRUE + } + F <- head(F[order(-Matrix::rowSums(abs(F))), , drop = FALSE], ngenes) + F <- F[order(-Matrix::rowSums(F)), , drop = FALSE] + + sel.zero <- which(Matrix::rowSums(abs(F)) < 1e-4) + if (length(sel.zero)) rownames(F)[sel.zero] <- "" + + pgx.stackedBarplot(x = F,ylab = ifelse(wt, "weighted frequency", "frequency"), showlegend = FALSE) }) + # topEnrichedFreq.RENDER2 <- shiny::reactive({ + # dt <- plot_data() + # ngs <- dt[[1]] + # rpt <- dt[[2]] + # ntop <- dt[[3]] + # gset.weight <- dt[[4]] + # fcweight <- dt[[5]] + # plotEnrichFreq(ngs, rpt, ntop = ntop, ngenes = 60, gset.weight, fcweight) + # p <- grDevices::recordPlot() + # p + # }) + PlotModuleServer( "plot", func = topEnrichedFreq.RENDER, - func2 = topEnrichedFreq.RENDER2, - pdf.width = 5, pdf.height = 5, + plotlib = "plotly", + pdf.width = 5, + pdf.height = 5, res = c(68, 100), csvFunc = plot_data, add.watermark = watermark From 63b413f17678e6a45d8749e3fe813cc6f6d0492c Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Wed, 22 Feb 2023 15:28:06 +0100 Subject: [PATCH 22/44] fix: remove legend to allow more groups --- components/board.correlation/R/correlation_plot_table_corr.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/components/board.correlation/R/correlation_plot_table_corr.R b/components/board.correlation/R/correlation_plot_table_corr.R index f6e6736d6..1111cd306 100644 --- a/components/board.correlation/R/correlation_plot_table_corr.R +++ b/components/board.correlation/R/correlation_plot_table_corr.R @@ -89,7 +89,7 @@ correlation_plot_table_corr_server <- function(id, pgx.stackedBarplot(x = pd_plot, ylab = "Correlation", - showlegend = TRUE) + showlegend = FALSE) # par(mfrow = c(1, 1), mar = c(10, 4, 1, 0.5)) From d70f21a8591a3399d123d03eda5340cde362176e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Wed, 22 Feb 2023 22:50:51 +0100 Subject: [PATCH 23/44] fix: hm_samplefilter --- .../board.clustering/R/clustering_plot_featurerank.R | 9 +++++---- components/board.clustering/R/clustering_server.R | 2 +- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/components/board.clustering/R/clustering_plot_featurerank.R b/components/board.clustering/R/clustering_plot_featurerank.R index 95329a507..f0c896808 100644 --- a/components/board.clustering/R/clustering_plot_featurerank.R +++ b/components/board.clustering/R/clustering_plot_featurerank.R @@ -52,7 +52,7 @@ clustering_plot_featurerank_server <- function(id, calcFeatureRanking <- shiny::reactive({ pgx <- pgx - hm_level <- hm_level + hm_level <- hm_level() shiny::req(pgx$X, pgx$Y, pgx$gsetX, pgx$genes) @@ -74,7 +74,7 @@ clustering_plot_featurerank_server <- function(id, ## ------------ Just to get current samples ##samples = colnames(X) - samples <- selectSamplesFromSelectedLevels(pgx$Y, hm_samplefilter) + samples <- selectSamplesFromSelectedLevels(pgx$Y, hm_samplefilter()) X = X[,samples] cvar <- pgx.getCategoricalPhenotypes(pgx$Y, max.ncat=999) cvar <- grep("sample|patient|years|days|months|gender", @@ -103,7 +103,7 @@ clustering_plot_featurerank_server <- function(id, } gene.level = TRUE - gene.level = (input$hm_level=="gene") + gene.level = (hm_level=="gene") i=1 for(i in 1:ncol(Y)) { @@ -181,7 +181,8 @@ clustering_plot_featurerank_server <- function(id, cc1 = grey.colors(ncol(S)) legend("bottomright",legend=colnames(S), fill=cc1, cex=0.8, y.intersp=0.8, inset=c(0,0.035), bg="white") - + p <- grDevices::recordPlot() + p }) diff --git a/components/board.clustering/R/clustering_server.R b/components/board.clustering/R/clustering_server.R index 6bdd0123c..e08694f1b 100644 --- a/components/board.clustering/R/clustering_server.R +++ b/components/board.clustering/R/clustering_server.R @@ -277,7 +277,7 @@ The Clustering Analysis module performs unsupervised clustering if(nrow(zx)==0) return(NULL) dim(zx) - kk <- selectSamplesFromSelectedLevels(pgx$Y, reactive(input$hm_samplefilter() )) + kk <- selectSamplesFromSelectedLevels(pgx$Y, reactive(input$hm_samplefilter )) zx <- zx[,kk,drop=FALSE] if( input$hm_level=="gene" && From d41b0dfc9ecf46ddddac5f5d8fdeb250bfaa84c9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Thu, 23 Feb 2023 00:21:01 +0100 Subject: [PATCH 24/44] fix: heatmap --- .../R/clustering_plot_hm_splitmap.R | 205 +++++------------- .../board.clustering/R/clustering_server.R | 80 +++---- 2 files changed, 96 insertions(+), 189 deletions(-) diff --git a/components/board.clustering/R/clustering_plot_hm_splitmap.R b/components/board.clustering/R/clustering_plot_hm_splitmap.R index 6571edabd..d2fd275df 100644 --- a/components/board.clustering/R/clustering_plot_hm_splitmap.R +++ b/components/board.clustering/R/clustering_plot_hm_splitmap.R @@ -22,11 +22,11 @@ clustering_plot_hm_splitmap_ui <- function(id, topmodes <- c("sd","pca","specific") hm_splitmap_opts = shiny::tagList( - withTooltip( shiny::radioButtons(ns("hm_plottype"), "Plot type:", - choices=c("ComplexHeatmap","iHeatmap"), - selected="ComplexHeatmap", inline=TRUE, width='100%'), - "Choose plot type: ComplexHeatmap (static) or iHeatmap (interactive)", - placement="right",options = list(container = "body")), + # withTooltip( shiny::radioButtons(ns("hm_plottype"), "Plot type:", + # choices=c("ComplexHeatmap","iHeatmap"), + # selected="ComplexHeatmap", inline=TRUE, width='100%'), + # "Choose plot type: ComplexHeatmap (static) or iHeatmap (interactive)", + # placement="right",options = list(container = "body")), withTooltip( shiny::radioButtons( ns("hm_splitby"), "Split samples by:", inline=TRUE, ## selected="phenotype", @@ -79,9 +79,7 @@ clustering_plot_hm_splitmap_ui <- function(id, ns("pltmod"), title = "Clustered Heatmap", label = label, - plotlib = "generic", #generic - outputFunc = plotly::plotlyOutput, #"uiOutput" - outputFunc2 = plotly::plotlyOutput, #"uiOutput", + # plotlib = "iheatmapr", info.text = info_text, options = hm_splitmap_opts, download.fmt = c("png", "pdf", "csv"), @@ -101,7 +99,9 @@ clustering_plot_hm_splitmap_ui <- function(id, #' #' @export clustering_plot_hm_splitmap_server <- function(id, + pgx, getTopMatrix, + hm_level, watermark = FALSE) { moduleServer(id, function(input, output, session) { @@ -109,8 +109,28 @@ clustering_plot_hm_splitmap_server <- function(id, ns <- session$ns - # reactive function listening for changes in input - topmodes <- c("sd","pca","specific") + shiny::observeEvent( input$hm_splitby, { + shiny::req(pgx$X, pgx$samples) + + if(input$hm_splitby=='none') return() + if(input$hm_splitby=='gene') { + xgenes <- sort(rownames(pgx$X)) + shiny::updateSelectizeInput(session, "hm_splitvar", choices=xgenes, server=TRUE) + } + if(input$hm_splitby=='phenotype') { + cvar <- sort(pgx.getCategoricalPhenotypes(pgx$samples, min.ncat=2, max.ncat=999)) + sel <- cvar[1] + cvar0 <- grep("^[.]",cvar,value=TRUE,invert=TRUE) ## no estimated vars + sel <- head(c(grep("type|family|class|stat",cvar0,ignore.case=TRUE,value=TRUE), + cvar0,cvar),1) + shiny::updateSelectInput(session, "hm_splitvar", choices=cvar, selected=sel) + } + }) + + ## update filter choices upon change of data set + shiny::observe({ + shiny::updateRadioButtons(session, "hm_splitby", selected='none') + }) plot_data_hm1 <- shiny::reactive({ @@ -128,7 +148,8 @@ clustering_plot_hm_splitmap_server <- function(id, return(list( zx = zx, annot = annot, - zx.idx = zx.idx + zx.idx = zx.idx, + filt = filt )) }) @@ -138,6 +159,8 @@ clustering_plot_hm_splitmap_server <- function(id, zx = pd[["zx"]] annot = pd[["annot"]] zx.idx = pd[["zx.idx"]] + filt = pd[["filt"]] + if(nrow(zx) <= 1) return(NULL) @@ -165,20 +188,20 @@ clustering_plot_hm_splitmap_server <- function(id, show_legend=show_colnames=TRUE show_legend <- input$hm_legend - if(input$hm_level=="geneset" || !is.null(splitx)) show_legend = FALSE + if(hm_level()=="geneset" || !is.null(splitx)) show_legend = FALSE annot$group = NULL ## no group in annotation?? show_colnames <- (input$hm_cexCol != 0) ##if(ncol(zx) > 200) show_colnames <- FALSE ## never... - if(input$hm_level=="gene") { + if(hm_level()=="gene") { ## strip any prefix rownames(zx) = sub(".*:","",rownames(zx)) } rownames(zx) <- sub("HALLMARK:HALLMARK_","HALLMARK:",rownames(zx)) rownames(zx) = gsub(GSET.PREFIX.REGEX,"",rownames(zx)) rownames(zx) = substring(rownames(zx),1,50) ## cut long names... - if(input$hm_level=="geneset") rownames(zx) <- tolower(rownames(zx)) + if(hm_level()=="geneset") rownames(zx) <- tolower(rownames(zx)) cex2 <- ifelse( nrow(zx) > 60, 0.8, 0.9) cex1 <- as.numeric(input$hm_cexCol)*0.85 @@ -195,8 +218,8 @@ clustering_plot_hm_splitmap_server <- function(id, nrownames = 9999 if(input$hm_cexRow==0) nrownames <- 0 - shiny::showNotification('rendering heatmap...') - plt <- grid::grid.grabExpr( + shiny::showNotification('Rendering heatmap...') + # plt <- grid::grid.grabExpr( gx.splitmap( zx, split = splity, splitx = splitx, @@ -211,9 +234,11 @@ clustering_plot_hm_splitmap_server <- function(id, key.offset = c(0.89,1.01), main=" ", nmax = -1, mar = c(8,16) ) - ) - plt - + p <- grDevices::recordPlot() + p + # ) + # browser() + # plt } hm2_splitmap.RENDER<- function() { @@ -251,7 +276,7 @@ clustering_plot_hm_splitmap_server <- function(id, rowcex = as.numeric(input$hm_cexRow) tooltips = NULL - if(input$hm_level=="gene") { + if(hm_level()=="gene") { getInfo <- function(g) { aa = paste0("",pgx$genes[g,"gene_name"],". ", ## pgx$genes[g,"map"],". ", @@ -265,7 +290,7 @@ clustering_plot_hm_splitmap_server <- function(id, } ##genetips = rownames(X) - shiny::showNotification('rendering iHeatmap...') + shiny::showNotification('Rendering iHeatmap...') plt <- pgx.splitHeatmapFromMatrix( X=X, annot=annotF, ytips=tooltips, @@ -278,141 +303,23 @@ clustering_plot_hm_splitmap_server <- function(id, } - output$hm1_splitmap <- shiny::renderPlot({ - plt <- hm1_splitmap.RENDER() - grid::grid.draw(plt, recording=FALSE) - }, res=90) - - output$hm2_splitmap <- renderIheatmap({ - hm2_splitmap.RENDER() - }) - - hm_splitmap.switchRENDER <- shiny::reactive({ - ##req(input$hm_plottype) - p = NULL - if(input$hm_plottype %in% c("ComplexHeatmap","static") ) { - p = shiny::plotOutput(ns("hm1_splitmap"), height=fullH-80) ## height defined here!! - } else { - p = iheatmaprOutput(ns("hm2_splitmap"), height=fullH-80) ## height defined here!! - } - return(p) - }) - - ##output$hm_splitmap_pdf <- shiny::downloadHandler( - hm_splitmap_downloadPDF <- shiny::downloadHandler( - filename = "plot.pdf", - content = function(file) { - ##PDFFILE = hm_splitmap_module$.tmpfile["pdf"] ## from above! - PDFFILE = paste0(gsub("file","plot",tempfile()),".pdf") - dbg("[ClusteringBoard] hm_splitmap_downloadPDF: exporting SWITCH to PDF...") - ##showNotification("exporting to PDF") - ##wd <- input$hm_pdfwidth - ##ht <- input$hm_pdfheight - ##wd <- input$pdf_width - ##ht <- input$pdf_height - wd <- input[["hm_splitmap-pdf_width"]] ## ugly!! - ht <- input[["hm_splitmap-pdf_height"]] ## ugly!! - - if(1 && input$hm_plottype %in% c("ComplexHeatmap","static")) { - pdf(PDFFILE, width=wd, height=ht) - grid::grid.draw(hm1_splitmap.RENDER()) - ##print(hm1_splitmap.RENDER()) - ##hm1_splitmap.RENDER() - dev.off() - } else { - save_iheatmap(hm2_splitmap.RENDER(), filename=PDFFILE, - vwidth=wd*100, vheight=ht*100) - } - if(WATERMARK) { - dbg("[ClusteringBoard] adding watermark to PDF...\n") - addWatermark.PDF(PDFFILE) ## from pgx-modules.R - } - dbg("[ClusteringBoard] hm_splitmap_downloadPDF: exporting done...") - file.copy(PDFFILE,file) - } - ) - - hm_splitmap_downloadPNG <- shiny::downloadHandler( - filename = "plot.png", - content = function(file) { - PNGFILE = paste0(gsub("file","plot",tempfile()),".png") - dbg("[ClusteringBoard] hm_splitmap_downloadPDF:: exporting SWITCH to PNG...") - ##showNotification("exporting to PNG") - wd <- 100*as.integer(input[["hm_splitmap-pdf_width"]]) - ht <- 100*as.integer(input[["hm_splitmap-pdf_height"]]) - if(1 && input$hm_plottype %in% c("ComplexHeatmap","static")) { - png(PNGFILE, width=wd, height=ht, pointsize=24) - grid::grid.draw(hm1_splitmap.RENDER()) - ##print(hm1_splitmap.RENDER()) ## should be done inside render for base plot... - ##hm1_splitmap.RENDER() ## should be done inside render for base plot... - ##plot(sin) - dev.off() - } else { - save_iheatmap(hm2_splitmap.RENDER(), filename=PNGFILE, vwidth=wd, vheight=ht) - } - dbg("[ClusteringBoard] hm_splitmap_downloadPNG: exporting done...") - file.copy(PNGFILE,file) - } - ) - - # hm_splitmap_downloadHTML <- shiny::downloadHandler( - # filename = "plot.html", - # content = function(file) { - # ##HTMLFILE = hm_splitmap_module$.tmpfile["html"] ## from above! - # HTMLFILE = paste0(gsub("file","plot",tempfile()),".html") - # dbg("renderIheatmap:: exporting SWITCH to HTML...") - # shiny::withProgress({ - # ##write("HTML export error", file=HTMLFILE) - # p <- hm2_splitmap.RENDER() - # shiny::incProgress(0.5) - # save_iheatmap(p, filename=HTMLFILE) - # }, message="exporting to HTML", value=0 ) - # dbg("renderIheatmap:: ... exporting done") - # file.copy(HTMLFILE,file) - # } - # ) - PlotModuleServer( "pltmod", - plotlib = "generic", - func = hm_splitmap.switchRENDER, - renderFunc = shiny::renderUI, - renderFunc2 = shiny::renderUI, - func2 = hm_splitmap.switchRENDER, + # plotlib = "iheatmapr", + func = hm1_splitmap.RENDER, res = c(80, 95), ## resolution of plots pdf.width = 10, pdf.height = 8, - download.pdf = hm_splitmap_downloadPDF, - download.png = hm_splitmap_downloadPNG, add.watermark = watermark - ) - - # ## call plotModule - # hm_splitmap_module <- shiny::callModule( - # plotModule, - # id = "hm_splitmap", - # func = hm_splitmap.switchRENDER, ## ns=ns, - # ## func2 = hm_splitmap.switchRENDER, ## ns=ns, - # show.maximize = FALSE, - # plotlib = "generic", - # renderFunc = "renderUI", - # outputFunc = "uiOutput", - # download.fmt = c("pdf","png"), - # options = hm_splitmap_opts, - # height = fullH-80, ##??? - # width = '100%', - # pdf.width = 10, pdf.height = 8, - # title ="Clustered Heatmap", - # info.text = hm_splitmap_text, - # info.width = "350px", - # ## caption = hm_splitmap_caption, - # download.pdf = hm_splitmap_downloadPDF, - # download.png = hm_splitmap_downloadPNG, - # download.html = hm_splitmap_downloadHTML, - # # add.watermark = WATERMARK - # ) - # + return(list( + hm_ntop = shiny::reactive(input$hm_ntop), + hm_splitvar = shiny::reactive(input$hm_splitvar), + hm_splitby = shiny::reactive(input$hm_splitby), + hm_scale = shiny::reactive(input$hm_scale), + hm_topmode = shiny::reactive(input$hm_topmode), + hm_clustk = shiny::reactive(input$hm_clustk) + )) }) ## end of moduleServer diff --git a/components/board.clustering/R/clustering_server.R b/components/board.clustering/R/clustering_server.R index e08694f1b..a5484401a 100644 --- a/components/board.clustering/R/clustering_server.R +++ b/components/board.clustering/R/clustering_server.R @@ -65,14 +65,14 @@ The Clustering Analysis module performs unsupervised clustering shiny::updateSelectInput(session, "hm_samplefilter", choices=levels) - if(DEV && !is.null(pgx$gset.meta$matrices) ) { - jj = which(!sapply(pgx$gset.meta$matrices,is.null)) - mat.names = names(pgx$gset.meta$matrices)[jj] - shiny::updateRadioButtons(session, "hm_gsetmatrix", choices=mat.names, - selected="meta", inline=TRUE) - } + # if(DEV && !is.null(pgx$gset.meta$matrices) ) { + # jj = which(!sapply(pgx$gset.meta$matrices,is.null)) + # mat.names = names(pgx$gset.meta$matrices)[jj] + # shiny::updateRadioButtons(session, "hm_gsetmatrix", choices=mat.names, + # selected="meta", inline=TRUE) + # } - shiny::updateRadioButtons(session, "hm_splitby", selected='none') + # shiny::updateRadioButtons(session, "hm_splitby", selected='none') ## update defaults?? ##if(ncol(pgx$X) > 80) shiny::updateNumericInput(session,"hm_cexCol", value=0) @@ -88,24 +88,23 @@ The Clustering Analysis module performs unsupervised clustering }) - shiny::observeEvent( input$hm_splitby, { - - shiny::req(pgx$X, pgx$samples) - - if(input$hm_splitby=='none') return() - if(input$hm_splitby=='gene') { - xgenes <- sort(rownames(pgx$X)) - shiny::updateSelectizeInput(session, "hm_splitvar", choices=xgenes, server=TRUE) - } - if(input$hm_splitby=='phenotype') { - cvar <- sort(pgx.getCategoricalPhenotypes(pgx$samples, min.ncat=2, max.ncat=999)) - sel <- cvar[1] - cvar0 <- grep("^[.]",cvar,value=TRUE,invert=TRUE) ## no estimated vars - sel <- head(c(grep("type|family|class|stat",cvar0,ignore.case=TRUE,value=TRUE), - cvar0,cvar),1) - shiny::updateSelectInput(session, "hm_splitvar", choices=cvar, selected=sel) - } - }) + # shiny::observeEvent( input$hm_splitby, { + # shiny::req(pgx$X, pgx$samples) + # + # if(input$hm_splitby=='none') return() + # if(input$hm_splitby=='gene') { + # xgenes <- sort(rownames(pgx$X)) + # shiny::updateSelectizeInput(session, "hm_splitvar", choices=xgenes, server=TRUE) + # } + # if(input$hm_splitby_clust_featureRank=='phenotype') { + # cvar <- sort(pgx.getCategoricalPhenotypes(pgx$samples, min.ncat=2, max.ncat=999)) + # sel <- cvar[1] + # cvar0 <- grep("^[.]",cvar,value=TRUE,invert=TRUE) ## no estimated vars + # sel <- head(c(grep("type|family|class|stat",cvar0,ignore.case=TRUE,value=TRUE), + # cvar0,cvar),1) + # shiny::updateSelectInput(session, "hm_splitvar", choices=cvar, selected=sel) + # } + # }) ## update choices upon change of level shiny::observe({ @@ -192,6 +191,7 @@ The Clustering Analysis module performs unsupervised clustering genes = as.character(pgx$genes[rownames(pgx$X),"gene_name"]) genesets = rownames(pgx$gsetX) + ft <- input$hm_features shiny::req(ft) @@ -222,9 +222,9 @@ The Clustering Analysis module performs unsupervised clustering } else if(ft =="") { ct <- input$hm_contrast shiny::req(ct) - shiny::req(input$hm_ntop) + shiny::req(hm_splitmap$hm_ntop()) fc <- names(sort(pgx.getMetaMatrix(pgx)$fc[,ct])) - n1 <- floor(as.integer(input$hm_ntop)/2) + n1 <- floor(as.integer(hm_splitmap$hm_ntop())/2) gg <- unique(c(head(fc,n1),tail(fc,n1))) } else if(ft %in% names(pgx$families)) { gg = pgx$families[[ft]] @@ -277,7 +277,7 @@ The Clustering Analysis module performs unsupervised clustering if(nrow(zx)==0) return(NULL) dim(zx) - kk <- selectSamplesFromSelectedLevels(pgx$Y, reactive(input$hm_samplefilter )) + kk <- selectSamplesFromSelectedLevels(pgx$Y, input$hm_samplefilter) zx <- zx[,kk,drop=FALSE] if( input$hm_level=="gene" && @@ -309,8 +309,6 @@ The Clustering Analysis module performs unsupervised clustering getTopMatrix <- shiny::reactive({ - - ##pgx <- inputData() shiny::req(pgx$X, pgx$samples) flt <- getFilteredMatrix() @@ -319,11 +317,11 @@ The Clustering Analysis module performs unsupervised clustering if(is.null(zx) || nrow(zx)==0) return(NULL) nmax = 4000 - nmax = as.integer(input$hm_ntop) + nmax = as.integer(hm_splitmap$hm_ntop()) idx <- NULL splitvar ="none" - splitvar <- input$hm_splitvar - splitby <- input$hm_splitby + splitvar <- hm_splitmap$hm_splitvar() + splitby <- hm_splitmap$hm_splitby() do.split <- splitby!='none' if(splitby=="gene" && !splitvar %in% rownames(pgx$X)) return(NULL) @@ -379,7 +377,7 @@ The Clustering Analysis module performs unsupervised clustering ## Any BMC scaling?? ########## - if(do.split && input$hm_scale=="BMC") { + if(do.split && hm_splitmap$hm_scale()=="BMC") { dbg("[ClusteringBoard:getTopMatrix] batch-mean centering...") for(g in unique(grp)) { jj <- which(grp == g) @@ -392,7 +390,7 @@ The Clustering Analysis module performs unsupervised clustering topmode="specific" topmode="sd" - topmode <- input$hm_topmode + topmode <- hm_splitmap$hm_topmode() if(topmode == "specific" && length(table(grp))<=1) { topmode <- "sd" } @@ -412,7 +410,7 @@ The Clustering Analysis module performs unsupervised clustering NPCA=5 svdres <- irlba::irlba(zx - rowMeans(zx), nv=NPCA) ntop = 12 - ntop <- as.integer(input$hm_ntop) / NPCA + ntop <- as.integer(hm_splitmap$hm_ntop()) / NPCA gg <- rownames(zx) sv.top <- lapply(1:NPCA,function(i) gg[head(order(-abs(svdres$u[,i])),ntop)] ) gg.top <- unlist(sv.top) @@ -444,7 +442,7 @@ The Clustering Analysis module performs unsupervised clustering } gg <- rownames(zx) ntop = 12 - ntop <- ceiling( as.integer(input$hm_ntop) / ncol(grp.dx) ) + ntop <- ceiling( as.integer(hm_splitmap$hm_ntop()) / ncol(grp.dx) ) grp.top <- lapply(1:nc,function(i) gg[head(order(-grp.dx[,i]),ntop)] ) ##idx <- unlist(sapply(1:nc,function(i) rep(i,length(grp.top[[i]])))) idx <- unlist(mapply(rep,1:nc,sapply(grp.top,length))) @@ -472,7 +470,7 @@ The Clustering Analysis module performs unsupervised clustering } CLUSTK = 4 ## number of gene groups (NEED RETHINK) - CLUSTK <- as.integer(input$hm_clustk) + CLUSTK <- as.integer(hm_splitmap$hm_clustk()) if(is.null(idx)) { D <- as.dist(1 - cor(t(zx),use="pairwise")) system.time( hc <- fastcluster::hclust(D, method="ward.D2" ) ) @@ -625,7 +623,7 @@ The Clustering Analysis module performs unsupervised clustering ##----------- for each gene cluster compute average correlation hm_topmode = "sd" - hm_topmode <- input$hm_topmode + hm_topmode <- hm_splitmap$hm_topmode() idxx = setdiff(idx, c(NA," "," ")) rho <- matrix(NA, nrow(ref), length(idxx)) colnames(rho) <- idxx @@ -749,8 +747,10 @@ The Clustering Analysis module performs unsupervised clustering # plots ########## - clustering_plot_hm_splitmap_server(id = "hm_splitmap", + hm_splitmap <- clustering_plot_hm_splitmap_server(id = "hm_splitmap", + pgx = pgx, getTopMatrix = getTopMatrix, + hm_level = shiny::reactive(input$hm_level), watermark = FALSE) clustering_plot_clustpca_server("PCAplot", From 93ac8dc38d4372eba49da93805890753fbc78844 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Thu, 23 Feb 2023 00:30:44 +0100 Subject: [PATCH 25/44] fix: clustannot --- .../R/clustering_plot_clustannot.R | 41 ++++++++++ .../board.clustering/R/clustering_server.R | 75 ++++++++++--------- 2 files changed, 79 insertions(+), 37 deletions(-) diff --git a/components/board.clustering/R/clustering_plot_clustannot.R b/components/board.clustering/R/clustering_plot_clustannot.R index a024359f8..e65186383 100644 --- a/components/board.clustering/R/clustering_plot_clustannot.R +++ b/components/board.clustering/R/clustering_plot_clustannot.R @@ -47,6 +47,7 @@ clustering_plot_clusterannot_ui <- function(id, } clustering_plot_clusterannot_server <- function(id, + pgx, getClustAnnotCorrelation, watermark=FALSE ) @@ -55,6 +56,38 @@ clustering_plot_clusterannot_server <- function(id, ns <- session$ns + shiny::observe({ + + ##pgx <- inputData() + shiny::req(pgx$X,pgx$gsetX,pgx$families) + + if(is.null(input$xann_level)) return(NULL) + ann.types=sel=NULL + if(input$xann_level!="phenotype") { + if(input$xann_level=="geneset") { + ann.types <- names(COLLECTIONS) + cc = sapply(COLLECTIONS,function(s) length(intersect(s,rownames(pgx$gsetX)))) + ann.types <- ann.types[cc>=3] + } + if(input$xann_level=="gene") { + ann.types <- names(pgx$families) + cc = sapply(pgx$families,function(g) length(intersect(g,rownames(pgx$X)))) + ann.types <- ann.types[cc>=3] + } + ann.types <- setdiff(ann.types,"") ## avoid slow... + ann.types <- grep("^<",ann.types,invert=TRUE,value=TRUE) ## remove special groups + sel = ann.types[1] + if("H" %in% ann.types) sel = "H" + j <- grep("^transcription",ann.types,ignore.case=TRUE) + if(input$xann_level=="geneset") j <- grep("hallmark",ann.types,ignore.case=TRUE) + if(length(j)>0) sel = ann.types[j[1]] + ann.types <- sort(ann.types) + } else { + ann.types = sel = "" + } + shiny::updateSelectInput(session, "xann_refset", choices=ann.types, selected=sel) + }) + clustannot_plots.PLOTLY <- shiny::reactive({ rho = getClustAnnotCorrelation() @@ -192,6 +225,14 @@ clustering_plot_clusterannot_server <- function(id, add.watermark = watermark ) + return( + list( + xann_level = shiny::reactive(input$xann_level), + xann_odds_weighting = shiny::reactive(input$xann_odds_weighting), + xann_refset = shiny::reactive(input$xann_refset) + ) + ) + }) } diff --git a/components/board.clustering/R/clustering_server.R b/components/board.clustering/R/clustering_server.R index a5484401a..2f7cd7b11 100644 --- a/components/board.clustering/R/clustering_server.R +++ b/components/board.clustering/R/clustering_server.R @@ -147,37 +147,37 @@ The Clustering Analysis module performs unsupervised clustering } }) - shiny::observe({ - - ##pgx <- inputData() - shiny::req(pgx$X,pgx$gsetX,pgx$families) - - if(is.null(input$xann_level)) return(NULL) - ann.types=sel=NULL - if(input$xann_level!="phenotype") { - if(input$xann_level=="geneset") { - ann.types <- names(COLLECTIONS) - cc = sapply(COLLECTIONS,function(s) length(intersect(s,rownames(pgx$gsetX)))) - ann.types <- ann.types[cc>=3] - } - if(input$xann_level=="gene") { - ann.types <- names(pgx$families) - cc = sapply(pgx$families,function(g) length(intersect(g,rownames(pgx$X)))) - ann.types <- ann.types[cc>=3] - } - ann.types <- setdiff(ann.types,"") ## avoid slow... - ann.types <- grep("^<",ann.types,invert=TRUE,value=TRUE) ## remove special groups - sel = ann.types[1] - if("H" %in% ann.types) sel = "H" - j <- grep("^transcription",ann.types,ignore.case=TRUE) - if(input$xann_level=="geneset") j <- grep("hallmark",ann.types,ignore.case=TRUE) - if(length(j)>0) sel = ann.types[j[1]] - ann.types <- sort(ann.types) - } else { - ann.types = sel = "" - } - shiny::updateSelectInput(session, "xann_refset", choices=ann.types, selected=sel) - }) + # shiny::observe({ + # + # ##pgx <- inputData() + # shiny::req(pgx$X,pgx$gsetX,pgx$families) + # + # if(is.null(input$xann_level)) return(NULL) + # ann.types=sel=NULL + # if(input$xann_level!="phenotype") { + # if(input$xann_level=="geneset") { + # ann.types <- names(COLLECTIONS) + # cc = sapply(COLLECTIONS,function(s) length(intersect(s,rownames(pgx$gsetX)))) + # ann.types <- ann.types[cc>=3] + # } + # if(input$xann_level=="gene") { + # ann.types <- names(pgx$families) + # cc = sapply(pgx$families,function(g) length(intersect(g,rownames(pgx$X)))) + # ann.types <- ann.types[cc>=3] + # } + # ann.types <- setdiff(ann.types,"") ## avoid slow... + # ann.types <- grep("^<",ann.types,invert=TRUE,value=TRUE) ## remove special groups + # sel = ann.types[1] + # if("H" %in% ann.types) sel = "H" + # j <- grep("^transcription",ann.types,ignore.case=TRUE) + # if(input$xann_level=="geneset") j <- grep("hallmark",ann.types,ignore.case=TRUE) + # if(length(j)>0) sel = ann.types[j[1]] + # ann.types <- sort(ann.types) + # } else { + # ann.types = sel = "" + # } + # shiny::updateSelectInput(session, "xann_refset", choices=ann.types, selected=sel) + # }) # reactive functions ############## @@ -581,11 +581,11 @@ The Clustering Analysis module performs unsupervised clustering ann.level="geneset" ann.refset="Hallmark collection" - ann.level = input$xann_level + ann.level = clusterannot$xann_level() ##if(is.null(ann.level)) return(NULL) - ann.refset = input$xann_refset + ann.refset = clusterannot$xann_refset() ##if(is.null(ann.refset)) return(NULL) - shiny::req(input$xann_level, input$xann_refset) + shiny::req(clusterannot$xann_level(), clusterannot$xann_refset()) ref = NULL ref = pgx$gsetX[,,drop=FALSE] @@ -642,7 +642,7 @@ The Clustering Analysis module performs unsupervised clustering } } - if(input$hm_level=="gene" && ann.level=="geneset" && input$xann_odds_weighting ) { + if(input$hm_level=="gene" && ann.level=="geneset" && clusterannot$xann_odds_weighting() ) { table(idx) grp <- tapply( toupper(rownames(zx)), idx, list) ## toupper for mouse!! ##gmt <- GSETS[rownames(rho)] @@ -779,7 +779,8 @@ The Clustering Analysis module performs unsupervised clustering watermark=FALSE ) - clustering_plot_clusterannot_server(id = "plots_clustannot", + clusterannot <- clustering_plot_clusterannot_server(id = "plots_clustannot", + pgx, getClustAnnotCorrelation = getClustAnnotCorrelation, watermark=FALSE ) @@ -788,7 +789,7 @@ The Clustering Analysis module performs unsupervised clustering clustering_table_clustannot_server(id = "tables_clustannot", getClustAnnotCorrelation = getClustAnnotCorrelation, - xann_level = input$xann_level, + xann_level = clusterannot$xann_level, watermark = FALSE) clustering_table_hm_parcoord_server(id = "", From 62d44b5351052ac2b70a91fc64e56ede39a2336e Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Thu, 23 Feb 2023 11:36:56 +0100 Subject: [PATCH 26/44] minor improvements on 'enrichment_plot_freq_plot_gsets' --- .../R/enrichment_plot_freq_top_gsets.R | 24 +++++-------------- 1 file changed, 6 insertions(+), 18 deletions(-) diff --git a/components/board.enrichment/R/enrichment_plot_freq_top_gsets.R b/components/board.enrichment/R/enrichment_plot_freq_top_gsets.R index d5cf91c60..4d7de75e0 100644 --- a/components/board.enrichment/R/enrichment_plot_freq_top_gsets.R +++ b/components/board.enrichment/R/enrichment_plot_freq_top_gsets.R @@ -36,6 +36,7 @@ enrichment_plot_freq_top_gsets_ui <- function(id, height, width) { ns("plot"), title = "Frequency in top gene sets", label = "b", + plotlib = "plotly", info.text = info_text, options = topEnrichedFreq.opts, height = height, @@ -52,11 +53,8 @@ enrichment_plot_freq_top_gsets_server <- function(id, watermark = FALSE) { moduleServer(id, function(input, output, session) { - req(inputData()) - plot_data <- shiny::reactive({ ngs <- inputData() - rpt <- getFilteredGeneSetTable() shiny::req(ngs, rpt, gs_contrast()) @@ -88,7 +86,7 @@ enrichment_plot_freq_top_gsets_server <- function(id, ) }) - topEnrichedFreq.RENDER <- shiny::reactive({ + topEnrichedFreq.RENDER <- function(){ dt <- plot_data() ngs <- dt[[1]] rpt <- dt[[2]] @@ -124,20 +122,10 @@ enrichment_plot_freq_top_gsets_server <- function(id, sel.zero <- which(Matrix::rowSums(abs(F)) < 1e-4) if (length(sel.zero)) rownames(F)[sel.zero] <- "" - pgx.stackedBarplot(x = F,ylab = ifelse(wt, "weighted frequency", "frequency"), showlegend = FALSE) - }) - - # topEnrichedFreq.RENDER2 <- shiny::reactive({ - # dt <- plot_data() - # ngs <- dt[[1]] - # rpt <- dt[[2]] - # ntop <- dt[[3]] - # gset.weight <- dt[[4]] - # fcweight <- dt[[5]] - # plotEnrichFreq(ngs, rpt, ntop = ntop, ngenes = 60, gset.weight, fcweight) - # p <- grDevices::recordPlot() - # p - # }) + pgx.stackedBarplot(x = F, + ylab = ifelse(wt, "weighted frequency", "frequency"), + showlegend = FALSE) + } PlotModuleServer( "plot", From ce383b14eeb7450c93941591f3f64213a1b13476 Mon Sep 17 00:00:00 2001 From: mauromiguelm Date: Thu, 23 Feb 2023 13:49:43 +0100 Subject: [PATCH 27/44] feat: input `hm$clustmethod` now in board UI --- components/board.clustering/R/clustering_ui.R | 3 +++ 1 file changed, 3 insertions(+) diff --git a/components/board.clustering/R/clustering_ui.R b/components/board.clustering/R/clustering_ui.R index d3077708a..8a45c37ea 100644 --- a/components/board.clustering/R/clustering_ui.R +++ b/components/board.clustering/R/clustering_ui.R @@ -11,6 +11,9 @@ ClusteringInputs <- function(id) { # shiny::hr(), shiny::br(), withTooltip( shiny::selectInput(ns("hm_features"),"Features:", choices=NULL, multiple=FALSE), "Select a family of features.", placement="top"), + withTooltip( shiny::radioButtons( ns('hm_clustmethod'),"Layout:", + c("default","tsne","pca","umap"),inline=TRUE), + "Choose the layout method for clustering to visualise.",), shiny::conditionalPanel( "input.hm_features == ''", ns=ns, withTooltip( shiny::textAreaInput(ns("hm_customfeatures"), NULL, value = NULL, From 0da14327bcadbfc95ea816954fbb6bec324a2972 Mon Sep 17 00:00:00 2001 From: mauromiguelm Date: Thu, 23 Feb 2023 13:50:18 +0100 Subject: [PATCH 28/44] fix: remove `r.samples` reactive function --- .../board.clustering/R/clustering_server.R | 35 +++++++++++++------ 1 file changed, 24 insertions(+), 11 deletions(-) diff --git a/components/board.clustering/R/clustering_server.R b/components/board.clustering/R/clustering_server.R index 2f7cd7b11..d22061873 100644 --- a/components/board.clustering/R/clustering_server.R +++ b/components/board.clustering/R/clustering_server.R @@ -23,15 +23,6 @@ The Clustering Analysis module performs unsupervised clustering ') # modules ######## - - r.samples <- reactive({ - ##colnames(getFilteredMatrix()) - - req(input$hm_samplefilter) - req(pgx$Y) - selectSamplesFromSelectedLevels(pgx$Y, input$hm_samplefilter) - }) - # observe functions ######## shiny::observe({ @@ -147,6 +138,25 @@ The Clustering Analysis module performs unsupervised clustering } }) + hm_parcoord.ranges <- shiny::reactiveValues() + + hm_parcoord.matrix <- shiny::reactive({ + + browser() + + filt <- getTopMatrix() + shiny::req(filt) + zx <- filt$mat[,] + if(input$hm_pcscale) { + zx <- t(scale(t(zx))) + } + rr <- shiny::isolate(shiny::reactiveValuesToList(hm_parcoord.ranges)) + nrange <- length(rr) + for(i in names(rr)) hm_parcoord.ranges[[i]] <- NULL + zx <- round(zx, digits=3) + list(mat=zx, clust=filt$idx) + }) + # shiny::observe({ # # ##pgx <- inputData() @@ -673,13 +683,15 @@ The Clustering Analysis module performs unsupervised clustering hm_getClusterPositions <- shiny::reactive({ + browser() + pgx <- pgx ##shiny::req(pgx$tsne2d,pgx$tsne3d,pgx$cluster) ## take full matrix #flt <- getFilteredMatrix() #zx <- flt$zx - sel.samples <- r.samples() + sel.samples <- selectSamplesFromSelectedLevels(pgx$Y, input$hm_samplefilter) clustmethod="tsne";pdim=2 do3d <- ("3D" %in% input$hmpca_options) @@ -755,9 +767,10 @@ The Clustering Analysis module performs unsupervised clustering clustering_plot_clustpca_server("PCAplot", pgx = pgx, - r.samples = r.samples, + hm_getClusterPositions = hm_getClusterPositions, hmpca.colvar = shiny::reactive(input$hmpca.colvar), hmpca.shapevar = shiny::reactive(input$hmpca.shapevar), + hm_clustmethod = shiny::reactive(input$hm_clustmethod), watermark=FALSE, parent = ns) From 7027c88bdd51b7a7840f82aa35d1d3beed1df7cb Mon Sep 17 00:00:00 2001 From: mauromiguelm Date: Thu, 23 Feb 2023 13:52:15 +0100 Subject: [PATCH 29/44] fix: `PCAplot` --- .../R/clustering_plot_PCAplot.R | 37 +++++++++---------- 1 file changed, 17 insertions(+), 20 deletions(-) diff --git a/components/board.clustering/R/clustering_plot_PCAplot.R b/components/board.clustering/R/clustering_plot_PCAplot.R index 80260acbd..ec955bf2f 100644 --- a/components/board.clustering/R/clustering_plot_PCAplot.R +++ b/components/board.clustering/R/clustering_plot_PCAplot.R @@ -31,10 +31,7 @@ clustering_plot_clustpca_ui <- function(id, "Normalize matrix before calculating distances."), withTooltip( shiny::checkboxGroupInput( ns('hmpca_options'),"Other:", choices=c('sample label','3D','normalize'), inline=TRUE), - "Normalize matrix before calculating distances."), - withTooltip( shiny::radioButtons( ns('hm_clustmethod'),"Layout:", - c("default","tsne","pca","umap"),inline=TRUE), - "Choose the layout method for clustering to visualise.",) + "Normalize matrix before calculating distances.") ) PlotModuleUI( @@ -53,9 +50,10 @@ clustering_plot_clustpca_ui <- function(id, clustering_plot_clustpca_server <- function(id, pgx, - r.samples = reactive(""), hmpca.colvar, + hm_getClusterPositions, hmpca.shapevar, + hm_clustmethod, watermark=FALSE, parent) { @@ -65,17 +63,21 @@ clustering_plot_clustpca_server <- function(id, ## Plot ############ plot_data <- shiny::reactive({ - dbg("[plot_clustpca_server:plot_data] reacted!") + clust <- hm_getClusterPositions() ##data.frame( x=clust$pos[,1], y=clust$pos[,2], clust=clust$clust ) + + browser() + return( list( hmpca_options = input$hmpca_options, hmpca.colvar = hmpca.colvar(), hmpca.shapevar = hmpca.shapevar(), df = data.frame( x=clust$pos[,1], y=clust$pos[,2]), - pgx = pgx - + pgx = pgx, + hm_clustmethod = hm_clustmethod(), + hmpca_legend = input$hmpca_legend ) ) @@ -85,18 +87,14 @@ clustering_plot_clustpca_server <- function(id, ##pgx <- inputData() pd <- plot_data() + hmpca_options <- pd[['hmpca_options']] hmpca.colvar <- pd[['hmpca.colvar']] hmpca.shapevar <- pd[['hmpca.shapevar']] pos <- pd[['df']] pgx <- pd[['pgx']] - - - dbg("[plot_clustpca_server:plot.RENDER] function called!") - dbg("[plot_clustpca_server:plot.RENDER] names(df) = ",names(df)) - - shiny::req(pgx$Y) - shiny::req(df) + hm_clustmethod <- pd[["hm_clustmethod"]] + hmpca_legend <- pd[["hmpca_legend"]] do3d = ("3D" %in% hmpca_options) ##clust <- hm_getClusterPositions() @@ -199,11 +197,11 @@ clustering_plot_clustpca_server <- function(id, } ## add group/cluster annotation labels - req(input$hmpca_legend) - if(input$hmpca_legend == 'inside') { + + if(hmpca_legend == 'inside') { plt <- plt %>% plotly::layout(legend = list(x=0.05, y=0.95)) - } else if(input$hmpca_legend == 'bottom') { + } else if(hmpca_legend == 'bottom') { plt <- plt %>% plotly::layout(legend = list(orientation='h')) } else { @@ -225,7 +223,7 @@ clustering_plot_clustpca_server <- function(id, } title = paste0("PCA (",nrow(pos)," samples)") - if(input$hm_clustmethod=="tsne") title = paste0("tSNE (",nrow(pos)," samples)") + if(hm_clustmethod=="tsne") title = paste0("tSNE (",nrow(pos)," samples)") ## plt <- plt %>% plotly::layout(title=title) %>% ## plotly::config(displayModeBar = FALSE) plt <- plt %>% @@ -245,7 +243,6 @@ clustering_plot_clustpca_server <- function(id, PlotModuleServer( "pltmod", plotlib = "plotly", - ##plotlib2 = "plotly", func = plot.RENDER, func2 = modal_plot.RENDER, csvFunc = plot_data, ## *** downloadable data as CSV From 30a72f03ae2aec51b05d58d33e356d0cfd8ac632 Mon Sep 17 00:00:00 2001 From: mauromiguelm Date: Thu, 23 Feb 2023 13:53:32 +0100 Subject: [PATCH 30/44] remove `browser()` --- components/board.clustering/R/clustering_plot_PCAplot.R | 2 -- components/board.clustering/R/clustering_server.R | 2 -- 2 files changed, 4 deletions(-) diff --git a/components/board.clustering/R/clustering_plot_PCAplot.R b/components/board.clustering/R/clustering_plot_PCAplot.R index ec955bf2f..f014f679b 100644 --- a/components/board.clustering/R/clustering_plot_PCAplot.R +++ b/components/board.clustering/R/clustering_plot_PCAplot.R @@ -67,8 +67,6 @@ clustering_plot_clustpca_server <- function(id, clust <- hm_getClusterPositions() ##data.frame( x=clust$pos[,1], y=clust$pos[,2], clust=clust$clust ) - browser() - return( list( hmpca_options = input$hmpca_options, diff --git a/components/board.clustering/R/clustering_server.R b/components/board.clustering/R/clustering_server.R index d22061873..e9698359f 100644 --- a/components/board.clustering/R/clustering_server.R +++ b/components/board.clustering/R/clustering_server.R @@ -683,8 +683,6 @@ The Clustering Analysis module performs unsupervised clustering hm_getClusterPositions <- shiny::reactive({ - browser() - pgx <- pgx ##shiny::req(pgx$tsne2d,pgx$tsne3d,pgx$cluster) From e9dfe0c885756dff3bb1c036d22bd0e7959c2cfa Mon Sep 17 00:00:00 2001 From: mauromiguelm Date: Thu, 23 Feb 2023 14:30:29 +0100 Subject: [PATCH 31/44] fix: `hm_parcoord` --- .../R/clustering_plot_hm_parcoord.R | 146 ++++++++++++------ .../board.clustering/R/clustering_server.R | 63 +------- components/board.clustering/R/clustering_ui.R | 2 +- 3 files changed, 98 insertions(+), 113 deletions(-) diff --git a/components/board.clustering/R/clustering_plot_hm_parcoord.R b/components/board.clustering/R/clustering_plot_hm_parcoord.R index fb728919f..16beb06b4 100644 --- a/components/board.clustering/R/clustering_plot_hm_parcoord.R +++ b/components/board.clustering/R/clustering_plot_hm_parcoord.R @@ -39,66 +39,110 @@ displays the expression levels of selected genes across all conditions in the an } clustering_plot_hm_parcoord_server <- function(id, - pgx, hm_parcoord.matrix, - watermark=FALSE + watermark=FALSE, + getTopMatrix ) { moduleServer( id, function(input, output, session) { + ns <- session$ns - hm_parcoord.RENDER <- shiny::reactive({ - - pc <- hm_parcoord.matrix() - shiny::req(pc) - zx <- pc$mat - ## build dimensions - dimensions <- list() - for(i in 1:ncol(zx)) { - dimensions[[i]] <- list( - range = c(min(zx[,i]),max(zx[,i])), - ## constraintrange = c(100000,150000), - ## tickvals = c(0,0.5,1,2,3), - ## ticktext = c('A','AB','B','Y','Z'), - visible = TRUE, - label = colnames(zx)[i], - values = zx[,i] - ) - } - - clust.id <- as.integer(factor(pc$clust)) - table(clust.id) - - df <- data.frame(clust.id=clust.id, zx) - klrpal = rep(RColorBrewer::brewer.pal(8,"Set2"),99) - ##klrpal = rep(c("red","blue","green","yellow","magenta","cyan","black","grey"),99) - klrpal = klrpal[1:max(clust.id)] - ##klrpal <- setNames(klrpal, sort(unique(clust.id))) - klrpal2 <- lapply(1:length(klrpal),function(i) c((i-1)/(length(klrpal)-1),klrpal[i])) - - plt <- plotly::plot_ly(df, source = "pcoords") %>% - plotly::add_trace(type = 'parcoords', - line = list(color = ~clust.id, - ## colorscale = list(c(0,'red'),c(0.5,'green'),c(1,'blue')) - ##colorscale = 'Jet', - colorscale = klrpal2, - cmin = min(clust.id), cmax = max(clust.id), - showscale = FALSE - ##reversescale = TRUE - ), - dimensions = dimensions) - plt <- plt %>% - plotly::layout(margin = list(l=60, r=60, t=0, b=30)) %>% - ##config(displayModeBar = FALSE) %>% - ##config(modeBarButtonsToRemove = setdiff(all.plotly.buttons,"toImage") ) %>% - plotly::config(toImageButtonOptions = list(format='svg', width=900, height=350, scale=1.2)) %>% - plotly::config(displaylogo = FALSE) %>% - plotly::event_register("plotly_restyle") - - plt + shiny::observeEvent( plotly::event_data("plotly_restyle", source = "pcoords"), { + ## From: https://rdrr.io/cran/plotly/src/inst/examples/shiny/event_data_parcoords/app.R + ## + d <- plotly::event_data("plotly_restyle", source = "pcoords") + ## what is the relevant dimension (i.e. variable)? + dimension <- as.numeric(stringr::str_extract(names(d[[1]]), "[0-9]+")) + ## If the restyle isn't related to a dimension, exit early. + if (!length(dimension)) return() + if (is.na(dimension)) return() + + pc <- hm_parcoord.matrix() + shiny::req(pc) + ## careful of the indexing in JS (0) versus R (1)! + dimension_name <- colnames(pc$mat)[[dimension + 1]] + ## a given dimension can have multiple selected ranges + ## these will come in as 3D arrays, but a list of vectors + ## is nicer to work with + info <- d[[1]][[1]] + if (length(dim(info)) == 3) { + hm_parcoord.ranges[[dimension_name]] <- lapply(seq_len(dim(info)[2]), function(i) info[,i,]) + } else { + hm_parcoord.ranges[[dimension_name]] <- list(as.numeric(info)) + } + }) + + hm_parcoord.ranges <- shiny::reactiveValues() + + hm_parcoord.matrix <- shiny::reactive({ + + filt <- getTopMatrix() + shiny::req(filt) + zx <- filt$mat[,] + if(input$hm_pcscale) { + zx <- t(scale(t(zx))) + } + rr <- shiny::isolate(shiny::reactiveValuesToList(hm_parcoord.ranges)) + nrange <- length(rr) + for(i in names(rr)) hm_parcoord.ranges[[i]] <- NULL + zx <- round(zx, digits=3) + list(mat=zx, clust=filt$idx) }) + hm_parcoord.RENDER <- function(){ + + pc <- hm_parcoord.matrix() + shiny::req(pc) + zx <- pc$mat + ## build dimensions + dimensions <- list() + for(i in 1:ncol(zx)) { + dimensions[[i]] <- list( + range = c(min(zx[,i]),max(zx[,i])), + ## constraintrange = c(100000,150000), + ## tickvals = c(0,0.5,1,2,3), + ## ticktext = c('A','AB','B','Y','Z'), + visible = TRUE, + label = colnames(zx)[i], + values = zx[,i] + ) + } + + clust.id <- as.integer(factor(pc$clust)) + table(clust.id) + + df <- data.frame(clust.id=clust.id, zx) + klrpal = rep(RColorBrewer::brewer.pal(8,"Set2"),99) + ##klrpal = rep(c("red","blue","green","yellow","magenta","cyan","black","grey"),99) + klrpal = klrpal[1:max(clust.id)] + ##klrpal <- setNames(klrpal, sort(unique(clust.id))) + klrpal2 <- lapply(1:length(klrpal),function(i) c((i-1)/(length(klrpal)-1),klrpal[i])) + + plt <- plotly::plot_ly(df, source = "pcoords") %>% + plotly::add_trace(type = 'parcoords', + line = list(color = ~clust.id, + ## colorscale = list(c(0,'red'),c(0.5,'green'),c(1,'blue')) + ##colorscale = 'Jet', + colorscale = klrpal2, + cmin = min(clust.id), cmax = max(clust.id), + showscale = FALSE + ##reversescale = TRUE + ), + dimensions = dimensions) + plt <- plt %>% + plotly::layout(margin = list(l=60, r=60, t=0, b=30)) %>% + ##config(displayModeBar = FALSE) %>% + ##config(modeBarButtonsToRemove = setdiff(all.plotly.buttons,"toImage") ) %>% + plotly::config(toImageButtonOptions = list(format='svg', width=900, height=350, scale=1.2)) %>% + plotly::config(displaylogo = FALSE) %>% + plotly::event_register("plotly_restyle") + + plt + + } + PlotModuleServer( "pltmod", diff --git a/components/board.clustering/R/clustering_server.R b/components/board.clustering/R/clustering_server.R index e9698359f..cc57f7a6c 100644 --- a/components/board.clustering/R/clustering_server.R +++ b/components/board.clustering/R/clustering_server.R @@ -113,50 +113,6 @@ The Clustering Analysis module performs unsupervised clustering shiny::updateSelectInput(session, "hm_features", choices=choices) }) - shiny::observeEvent( plotly::event_data("plotly_restyle", source = "pcoords"), { - ## From: https://rdrr.io/cran/plotly/src/inst/examples/shiny/event_data_parcoords/app.R - ## - d <- plotly::event_data("plotly_restyle", source = "pcoords") - ## what is the relevant dimension (i.e. variable)? - dimension <- as.numeric(stringr::str_extract(names(d[[1]]), "[0-9]+")) - ## If the restyle isn't related to a dimension, exit early. - if (!length(dimension)) return() - if (is.na(dimension)) return() - - pc <- hm_parcoord.matrix() - shiny::req(pc) - ## careful of the indexing in JS (0) versus R (1)! - dimension_name <- colnames(pc$mat)[[dimension + 1]] - ## a given dimension can have multiple selected ranges - ## these will come in as 3D arrays, but a list of vectors - ## is nicer to work with - info <- d[[1]][[1]] - if (length(dim(info)) == 3) { - hm_parcoord.ranges[[dimension_name]] <- lapply(seq_len(dim(info)[2]), function(i) info[,i,]) - } else { - hm_parcoord.ranges[[dimension_name]] <- list(as.numeric(info)) - } - }) - - hm_parcoord.ranges <- shiny::reactiveValues() - - hm_parcoord.matrix <- shiny::reactive({ - - browser() - - filt <- getTopMatrix() - shiny::req(filt) - zx <- filt$mat[,] - if(input$hm_pcscale) { - zx <- t(scale(t(zx))) - } - rr <- shiny::isolate(shiny::reactiveValuesToList(hm_parcoord.ranges)) - nrange <- length(rr) - for(i in names(rr)) hm_parcoord.ranges[[i]] <- NULL - zx <- round(zx, digits=3) - list(mat=zx, clust=filt$idx) - }) - # shiny::observe({ # # ##pgx <- inputData() @@ -558,22 +514,6 @@ The Clustering Analysis module performs unsupervised clustering list(mat=mat[keep,,drop=FALSE], clust=clust[keep]) }) - hm_parcoord.ranges <- shiny::reactiveValues() - - hm_parcoord.matrix <- shiny::reactive({ - - filt <- getTopMatrix() - shiny::req(filt) - zx <- filt$mat[,] - if(input$hm_pcscale) { - zx <- t(scale(t(zx))) - } - rr <- shiny::isolate(shiny::reactiveValuesToList(hm_parcoord.ranges)) - nrange <- length(rr) - for(i in names(rr)) hm_parcoord.ranges[[i]] <- NULL - zx <- round(zx, digits=3) - list(mat=zx, clust=filt$idx) - }) getClustAnnotCorrelation <- shiny::reactive({ @@ -773,7 +713,8 @@ The Clustering Analysis module performs unsupervised clustering parent = ns) clustering_plot_hm_parcoord_server(id = "hm_parcoord", - hm_parcoord.matrix = hm_parcoord.matrix(), + hm_parcoord.matrix = hm_parcoord.matrix, + getTopMatrix = getTopMatrix, watermark=FALSE ) diff --git a/components/board.clustering/R/clustering_ui.R b/components/board.clustering/R/clustering_ui.R index 8a45c37ea..6ac036487 100644 --- a/components/board.clustering/R/clustering_ui.R +++ b/components/board.clustering/R/clustering_ui.R @@ -100,7 +100,7 @@ ClusteringUI <- function(id) { shiny::tabPanel("Parallel", clustering_plot_hm_parcoord_ui( - id ="hm_parcoord", + id =ns("hm_parcoord"), label= 'a', width = c("100%",1000), height=c(0.45*fullH,600)), From 99f9c154b733ec1d0ef2e7f44279acc7e8bab28d Mon Sep 17 00:00:00 2001 From: mauromiguelm Date: Thu, 23 Feb 2023 14:33:51 +0100 Subject: [PATCH 32/44] code cleaning --- .../board.clustering/R/clustering_server.R | 1267 ----------------- 1 file changed, 1267 deletions(-) diff --git a/components/board.clustering/R/clustering_server.R b/components/board.clustering/R/clustering_server.R index cc57f7a6c..f0d5effc1 100644 --- a/components/board.clustering/R/clustering_server.R +++ b/components/board.clustering/R/clustering_server.R @@ -38,17 +38,8 @@ The Clustering Analysis module performs unsupervised clustering if("group" %in% var.types) grp = "group" shiny::updateSelectInput(session, "hmpca.colvar", choices=var.types0, selected=grp) shiny::updateSelectInput(session, "hmpca.shapevar", choices=var.types1, selected="") - ##updateSelectInput(session, "hmpca.line", choices=var.types1, selected="") - ##updateSelectInput(session, "hmpca.text", choices=var.types0, selected="group") }) - # shiny::observeEvent( input$clust_info, { - # shiny::showModal(shiny::modalDialog( - # title = shiny::HTML("Clustering Board"), - # shiny::HTML(clust_infotext), - # easyClose = TRUE, size="l" )) - # }) - ## update filter choices upon change of data set shiny::observe({ @@ -56,18 +47,6 @@ The Clustering Analysis module performs unsupervised clustering shiny::updateSelectInput(session, "hm_samplefilter", choices=levels) - # if(DEV && !is.null(pgx$gset.meta$matrices) ) { - # jj = which(!sapply(pgx$gset.meta$matrices,is.null)) - # mat.names = names(pgx$gset.meta$matrices)[jj] - # shiny::updateRadioButtons(session, "hm_gsetmatrix", choices=mat.names, - # selected="meta", inline=TRUE) - # } - - # shiny::updateRadioButtons(session, "hm_splitby", selected='none') - - ## update defaults?? - ##if(ncol(pgx$X) > 80) shiny::updateNumericInput(session,"hm_cexCol", value=0) - ## update defaults?? n1 <- nrow(pgx$samples)-1 groupings <- colnames(pgx$samples) @@ -79,24 +58,6 @@ The Clustering Analysis module performs unsupervised clustering }) - # shiny::observeEvent( input$hm_splitby, { - # shiny::req(pgx$X, pgx$samples) - # - # if(input$hm_splitby=='none') return() - # if(input$hm_splitby=='gene') { - # xgenes <- sort(rownames(pgx$X)) - # shiny::updateSelectizeInput(session, "hm_splitvar", choices=xgenes, server=TRUE) - # } - # if(input$hm_splitby_clust_featureRank=='phenotype') { - # cvar <- sort(pgx.getCategoricalPhenotypes(pgx$samples, min.ncat=2, max.ncat=999)) - # sel <- cvar[1] - # cvar0 <- grep("^[.]",cvar,value=TRUE,invert=TRUE) ## no estimated vars - # sel <- head(c(grep("type|family|class|stat",cvar0,ignore.case=TRUE,value=TRUE), - # cvar0,cvar),1) - # shiny::updateSelectInput(session, "hm_splitvar", choices=cvar, selected=sel) - # } - # }) - ## update choices upon change of level shiny::observe({ @@ -113,38 +74,6 @@ The Clustering Analysis module performs unsupervised clustering shiny::updateSelectInput(session, "hm_features", choices=choices) }) - # shiny::observe({ - # - # ##pgx <- inputData() - # shiny::req(pgx$X,pgx$gsetX,pgx$families) - # - # if(is.null(input$xann_level)) return(NULL) - # ann.types=sel=NULL - # if(input$xann_level!="phenotype") { - # if(input$xann_level=="geneset") { - # ann.types <- names(COLLECTIONS) - # cc = sapply(COLLECTIONS,function(s) length(intersect(s,rownames(pgx$gsetX)))) - # ann.types <- ann.types[cc>=3] - # } - # if(input$xann_level=="gene") { - # ann.types <- names(pgx$families) - # cc = sapply(pgx$families,function(g) length(intersect(g,rownames(pgx$X)))) - # ann.types <- ann.types[cc>=3] - # } - # ann.types <- setdiff(ann.types,"") ## avoid slow... - # ann.types <- grep("^<",ann.types,invert=TRUE,value=TRUE) ## remove special groups - # sel = ann.types[1] - # if("H" %in% ann.types) sel = "H" - # j <- grep("^transcription",ann.types,ignore.case=TRUE) - # if(input$xann_level=="geneset") j <- grep("hallmark",ann.types,ignore.case=TRUE) - # if(length(j)>0) sel = ann.types[j[1]] - # ann.types <- sort(ann.types) - # } else { - # ann.types = sel = "" - # } - # shiny::updateSelectInput(session, "xann_refset", choices=ann.types, selected=sel) - # }) - # reactive functions ############## getFilteredMatrix <- shiny::reactive({ @@ -748,733 +677,6 @@ The Clustering Analysis module performs unsupervised clustering hm_parcoord.selected = hm_parcoord.selected, watermark = FALSE) - # start hm_splitmap refactoring ######## - - # hm_splitmap_text = tagsub("Under the Heatmap panel, hierarchical clustering can be performed on gene level or gene set level expression in which users have to specify it under the {Level} dropdown list.

Under the plot configuration {{Settings}}, users can split the samples by a phenotype class (e.g., tissue, cell type, or gender) using the {split by} setting. In addition, users can specify the top N = (50, 150, 500) features to be used in the heatmap. The ordering of top features is selected under {top mode}. The criteria to select the top features are:

  1. SD - features with the highest standard deviation across all the samples,
  2. specific - features that are overexpressed in each phenotype class compared to the rest, or by
  3. PCA - by principal components.

Users can also choose between 'relative' or 'absolute' expression scale. Under the {cexCol} and {cexRow} settings, it is also possible to adjust the cex for the column and row labels.") - - # hm1_splitmap.RENDER <- shiny::reactive({ - # - - # - # filt <- getTopMatrix() - # shiny::req(filt) - # ##if(is.null(filt)) return(NULL) - # - # ##if(input$hm_group) { - # zx <- filt$mat - # annot = filt$annot - # zx.idx <- filt$idx - # - # if(nrow(zx) <= 1) return(NULL) - # - # show_rownames = TRUE - # if(nrow(zx) > 100) show_rownames = FALSE - # - # cex1 = ifelse(ncol(zx)>50,0.75,1) - # cex1 = ifelse(ncol(zx)>100,0.5,cex1) - # cex1 = ifelse(ncol(zx)>200,0,cex1) - # - # scale.mode = "none" - # if(input$hm_scale=="relative") scale.mode <- "row.center" - # if(input$hm_scale=="BMC") scale.mode <- "row.bmc" - # scale.mode - # - # ## split genes dimension in 5 groups - # splity = 5 - # splity = 6 - # if(!is.null(zx.idx)) splity = zx.idx - # - # ## split samples - # splitx = NULL - # splitx = filt$grp - # - # show_legend=show_colnames=TRUE - # show_legend <- input$hm_legend - # if(input$hm_level=="geneset" || !is.null(splitx)) show_legend = FALSE - # - # annot$group = NULL ## no group in annotation?? - # show_colnames <- (input$hm_cexCol != 0) - # ##if(ncol(zx) > 200) show_colnames <- FALSE ## never... - # - # if(input$hm_level=="gene") { - # ## strip any prefix - # rownames(zx) = sub(".*:","",rownames(zx)) - # } - # rownames(zx) <- sub("HALLMARK:HALLMARK_","HALLMARK:",rownames(zx)) - # rownames(zx) = gsub(GSET.PREFIX.REGEX,"",rownames(zx)) - # rownames(zx) = substring(rownames(zx),1,50) ## cut long names... - # if(input$hm_level=="geneset") rownames(zx) <- tolower(rownames(zx)) - # - # cex2 <- ifelse( nrow(zx) > 60, 0.8, 0.9) - # cex1 <- as.numeric(input$hm_cexCol)*0.85 - # cex2 <- as.numeric(input$hm_cexRow)*0.75 - # cex0 <- ifelse(!is.null(splitx) && length(splitx)<=10, 1.05, 0.85) ## title - # - # crot <- 0 - # totnchar <- nchar(paste0(unique(splitx),collapse="")) - # totnchar - # nx <- length(unique(splitx)) - # if(!is.null(splitx) & (totnchar > 44 || nx>=6) ) crot=90 - # - # nrownames = 60 - # nrownames = 9999 - # if(input$hm_cexRow==0) nrownames <- 0 - # - # if(0) { - # split=splity;splitx=splitx;mar=c(5,25); scale=scale.mode; show_legend=show_legend; - # show_colnames = show_colnames; column_title_rot=crot; - # show_rownames = nrownames; softmax=0; - # ## side.height.fraction=0.03+0.055*NCOL(annot); - # cexCol=cex1; cexRow=cex2;title_cex=1.0 - # col.annot=annot; row.annot=NULL; annot.ht=2.2; - # nmax=-1 - # } - # - # if(0) { - # dbg("[hm1_splitmap.RENDER] rendering heatmap...") - # dbg("[hm1_splitmap.RENDER] dim(annot) = ", paste(dim(annot),collapse="x")) - # dbg("[hm1_splitmap.RENDER] rownames(annot) = ", rownames(annot)) - # dbg("[hm1_splitmap.RENDER] colnames(annot) = ", colnames(annot)) - # dbg("[hm1_splitmap.RENDER] splitx = ", paste(splitx,collapse=" ")) - # dbg("[hm1_splitmap.RENDER] splity = ", paste(splity,collapse=" ")) - # } - # shiny::showNotification('rendering heatmap...') - # plt <- grid::grid.grabExpr( - # gx.splitmap( - # zx, - # split = splity, splitx = splitx, - # scale = scale.mode, show_legend = show_legend, - # show_colnames = show_colnames, column_title_rot = crot, - # column_names_rot = 45, - # show_rownames = nrownames, rownames_width = 40, - # softmax = 0, - # ## side.height.fraction=0.03+0.055*NCOL(annot), - # title_cex = cex0, cexCol = cex1, cexRow = cex2, - # col.annot = annot, row.annot = NULL, annot.ht = 2.3, - # key.offset = c(0.89,1.01), - # main=" ", nmax = -1, mar = c(8,16) - # ) - # ) - # plt - # }) - - # hm2_splitmap.RENDER <- shiny::reactive({ - # - # - # - # shiny::req(pgx$genes) - # - # ## -------------- variable to split samples - # ##scale = ifelse(input$hm_scale=="relative","row.center","none") - # scale = "none" - # if(input$hm_scale=="relative") scale <- "row.center" - # if(input$hm_scale=="BMC") scale <- "row.bmc" - # scale - # - # plt <- NULL - # - # filt <- getTopMatrix() - # ##if(is.null(filt)) return(NULL) - # shiny::req(filt) - # - # ##if(input$hm_group) { - # X <- filt$mat - # annot = filt$annot - # idx <- filt$idx - # - # ## sample clustering index - # splitx <- NULL - # splitx <- filt$grp - # - # ## iheatmapr needs factors for sharing between groups - # annotF <- data.frame(as.list(annot),stringsAsFactors=TRUE) - # rownames(annotF) = rownames(annot) - # - # colcex <- as.numeric(input$hm_cexCol) - # rowcex = as.numeric(input$hm_cexRow) - # - # tooltips = NULL - # if(input$hm_level=="gene") { - # getInfo <- function(g) { - # aa = paste0("",pgx$genes[g,"gene_name"],". ", - # ## pgx$genes[g,"map"],". ", - # pgx$genes[g,"gene_title"],".") - # breakstring2(aa, 50, brk="
") - # } - # tooltips = sapply(rownames(X), getInfo) - # } else { - # aa = gsub("_"," ",rownames(X)) ## just geneset names - # tooltips = breakstring2(aa, 50, brk="
") - # } - # ##genetips = rownames(X) - # - # shiny::showNotification('rendering iHeatmap...') - # - # plt <- pgx.splitHeatmapFromMatrix( - # X=X, annot=annotF, ytips=tooltips, - # idx=idx, splitx=splitx, scale=scale, - # row_annot_width=0.03, rowcex=rowcex, - # colcex=colcex ) - # - # ## DOES NOT WORK... - # ##plt <- plt %>% - # ## plotly::config(toImageButtonOptions = list(format='svg', height=800, width=800)) - # - # return(plt) - # }) - - # topmodes <- c("sd","pca","specific") - ##if(DEV) topmodes <- c("sd","specific","pca") - - # hm_splitmap_opts = shiny::tagList( - # withTooltip( shiny::radioButtons(ns("hm_plottype"), "Plot type:", - # choices=c("ComplexHeatmap","iHeatmap"), - # selected="ComplexHeatmap", inline=TRUE, width='100%'), - # "Choose plot type: ComplexHeatmap (static) or iHeatmap (interactive)", - # placement="right",options = list(container = "body")), - # withTooltip( shiny::radioButtons( - # ns("hm_splitby"), "Split samples by:", inline=TRUE, - # ## selected="phenotype", - # choices=c("none","phenotype","gene")), - # "Split the samples by phenotype or expression level of a gene.", - # placement="right",options = list(container = "body")), - # shiny::conditionalPanel( - # "input.hm_splitby != 'none'", ns=ns, - # withTooltip( shiny::selectInput(ns("hm_splitvar"), NULL, choices=""), - # "Specify phenotype or gene for splitting the columns of the heatmap.", - # placement="right",options = list(container = "body")), - # ), - # shiny::fillRow( - # height = 50, - # withTooltip( shiny::selectInput(ns('hm_topmode'),'Top mode:',topmodes, width='100%'), - # "Specify the criteria for selecting top features to be shown in the heatmap.", - # placement = "right", options = list(container = "body")), - # withTooltip( shiny::selectInput(ns('hm_ntop'),'Top N:',c(50,150,500),selected=50), - # "Select the number of top features in the heatmap.", - # placement="right", options = list(container = "body")), - # withTooltip( shiny::selectInput(ns('hm_clustk'),'K:',1:6,selected=4), - # "Select the number of gene clusters.", - # placement="right", options = list(container = "body")) - # ), - # ##br(), - # withTooltip( shiny::radioButtons( - # ns('hm_scale'), 'Scale:', choices=c('relative','absolute','BMC'), inline=TRUE), - # ## ns('hm_scale'), 'Scale:', choices=c('relative','absolute'), inline=TRUE), - # "Show relative (i.e. mean-centered), absolute expression values or batch-mean-centered.", - # placement="right", options = list(container = "body")), - # withTooltip( shiny::checkboxInput( - # ns('hm_legend'), 'show legend', value=TRUE), "Show or hide the legend.", - # placement="right", options = list(container = "body")), - # shiny::fillRow( - # height = 50, - # ## shiny::checkboxInput(ns("hm_labRow"),NULL), - # withTooltip( shiny::numericInput(ns("hm_cexRow"), "cexRow:", 1, 0, 1.4, 0.1, width='100%'), - # "Specify the row label size. Set to 0 to suppress row labels.", - # placement="right",options = list(container = "body")), - # withTooltip( shiny::numericInput(ns("hm_cexCol"), "cexCol:", 1, 0, 1.4, 0.1, width='100%'), - # "Specify the column label size. Set to 0 to suppress column labels.", - # placement="right", options = list(container = "body")) - # ), - # shiny::br() - # ) - - # hm_splitmap_caption = "Clustered heatmap. Heatmap showing gene expression sorted by 2-way hierarchical clustering. Red corresponds to overexpression, blue to underexpression of the gene. At the same time, gene clusters are functionally annotated in the 'Annotate clusters' panel on the right." - - # output$hm1_splitmap <- shiny::renderPlot({ - # plt <- hm1_splitmap.RENDER() - # grid::grid.draw(plt, recording=FALSE) - # }, res=90) - # - # output$hm2_splitmap <- renderIheatmap({ - # hm2_splitmap.RENDER() - # }) - # - # hm_splitmap.switchRENDER <- shiny::reactive({ - # ##req(input$hm_plottype) - # p = NULL - # if(input$hm_plottype %in% c("ComplexHeatmap","static") ) { - # p = shiny::plotOutput(ns("hm1_splitmap"), height=fullH-80) ## height defined here!! - # } else { - # p = iheatmaprOutput(ns("hm2_splitmap"), height=fullH-80) ## height defined here!! - # } - # return(p) - # }) - # - # ##output$hm_splitmap_pdf <- shiny::downloadHandler( - # hm_splitmap_downloadPDF <- shiny::downloadHandler( - # filename = "plot.pdf", - # content = function(file) { - # ##PDFFILE = hm_splitmap_module$.tmpfile["pdf"] ## from above! - # PDFFILE = paste0(gsub("file","plot",tempfile()),".pdf") - # dbg("[ClusteringBoard] hm_splitmap_downloadPDF: exporting SWITCH to PDF...") - # ##showNotification("exporting to PDF") - # ##wd <- input$hm_pdfwidth - # ##ht <- input$hm_pdfheight - # ##wd <- input$pdf_width - # ##ht <- input$pdf_height - # wd <- input[["hm_splitmap-pdf_width"]] ## ugly!! - # ht <- input[["hm_splitmap-pdf_height"]] ## ugly!! - # - # if(1 && input$hm_plottype %in% c("ComplexHeatmap","static")) { - # pdf(PDFFILE, width=wd, height=ht) - # grid::grid.draw(hm1_splitmap.RENDER()) - # ##print(hm1_splitmap.RENDER()) - # ##hm1_splitmap.RENDER() - # dev.off() - # } else { - # save_iheatmap(hm2_splitmap.RENDER(), filename=PDFFILE, - # vwidth=wd*100, vheight=ht*100) - # } - # if(WATERMARK) { - # dbg("[ClusteringBoard] adding watermark to PDF...\n") - # addWatermark.PDF(PDFFILE) ## from pgx-modules.R - # } - # dbg("[ClusteringBoard] hm_splitmap_downloadPDF: exporting done...") - # file.copy(PDFFILE,file) - # } - # ) - # - # hm_splitmap_downloadPNG <- shiny::downloadHandler( - # filename = "plot.png", - # content = function(file) { - # PNGFILE = paste0(gsub("file","plot",tempfile()),".png") - # dbg("[ClusteringBoard] hm_splitmap_downloadPDF:: exporting SWITCH to PNG...") - # ##showNotification("exporting to PNG") - # wd <- 100*as.integer(input[["hm_splitmap-pdf_width"]]) - # ht <- 100*as.integer(input[["hm_splitmap-pdf_height"]]) - # if(1 && input$hm_plottype %in% c("ComplexHeatmap","static")) { - # png(PNGFILE, width=wd, height=ht, pointsize=24) - # grid::grid.draw(hm1_splitmap.RENDER()) - # ##print(hm1_splitmap.RENDER()) ## should be done inside render for base plot... - # ##hm1_splitmap.RENDER() ## should be done inside render for base plot... - # ##plot(sin) - # dev.off() - # } else { - # save_iheatmap(hm2_splitmap.RENDER(), filename=PNGFILE, vwidth=wd, vheight=ht) - # } - # dbg("[ClusteringBoard] hm_splitmap_downloadPNG: exporting done...") - # file.copy(PNGFILE,file) - # } - # ) - # - # hm_splitmap_downloadHTML <- shiny::downloadHandler( - # filename = "plot.html", - # content = function(file) { - # ##HTMLFILE = hm_splitmap_module$.tmpfile["html"] ## from above! - # HTMLFILE = paste0(gsub("file","plot",tempfile()),".html") - # dbg("renderIheatmap:: exporting SWITCH to HTML...") - # shiny::withProgress({ - # ##write("HTML export error", file=HTMLFILE) - # p <- hm2_splitmap.RENDER() - # shiny::incProgress(0.5) - # save_iheatmap(p, filename=HTMLFILE) - # }, message="exporting to HTML", value=0 ) - # dbg("renderIheatmap:: ... exporting done") - # file.copy(HTMLFILE,file) - # } - # ) - # - # - # ## call plotModule - # hm_splitmap_module <- shiny::callModule( - # plotModule, - # id = "hm_splitmap", - # func = hm_splitmap.switchRENDER, ## ns=ns, - # ## func2 = hm_splitmap.switchRENDER, ## ns=ns, - # show.maximize = FALSE, - # plotlib = "generic", - # renderFunc = "renderUI", - # outputFunc = "uiOutput", - # download.fmt = c("pdf","png"), - # options = hm_splitmap_opts, - # height = fullH-80, ##??? - # width = '100%', - # pdf.width = 10, pdf.height = 8, - # title ="Clustered Heatmap", - # info.text = hm_splitmap_text, - # info.width = "350px", - # ## caption = hm_splitmap_caption, - # download.pdf = hm_splitmap_downloadPDF, - # download.png = hm_splitmap_downloadPNG, - # download.html = hm_splitmap_downloadHTML, - # add.watermark = WATERMARK - # ) - - # end hm_splitmap refactoring ######## - - # start PCA/tSNR refactoring ######## - -# ## PCA/tSNE ############ -# -# hm_PCAplot_text = tagsub(paste0(' The PCA/tSNE panel visualizes unsupervised clustering obtained by the principal components analysis (',a_PCA,') or t-distributed stochastic embedding (',a_tSNE,') algorithms. This plot shows the relationship (or similarity) between the samples for visual analytics, where similarity is visualized as proximity of the points. Samples that are ‘similar’ will be placed close to each other. -#

Users can customise the PCA/tSNE plot in the plot settings, including the {color} and {shape} of points using a phenotype class, choose t-SNE or PCA layout, label the points, or display 2D and 3D visualisation of the PCA/tSNE plot.')) -# -# -# -# hm_getClusterPositions <- shiny::reactive({ -# -# dbg("[hm_getClusterPositions] reacted") -# -# ##pgx <- inputData() -# shiny::req(pgx$tsne2d,pgx$tsne3d,pgx$cluster) -# -# ## take full matrix -# flt <- getFilteredMatrix() -# zx <- flt$zx -# -# clustmethod="tsne";pdim=2 -# do3d <- ("3D" %in% input$hmpca_options) -# pdim = c(2,3)[ 1 + 1*do3d] -# -# pos = NULL -# force.compute = FALSE -# clustmethod = input$hm_clustmethod -# clustmethod0 <- paste0(clustmethod,pdim,"d") -# -# if(clustmethod=="default" && !force.compute) { -# if(pdim==2 && !is.null(pgx$tsne2d) ) { -# pos <- pgx$tsne2d[colnames(zx),] -# } else if(pdim==3 && !is.null(pgx$tsne3d) ) { -# pos <- pgx$tsne3d[colnames(zx),] -# } -# } else if( clustmethod0 %in% names(pgx$cluster$pos)) { -# shiny::showNotification(paste("switching to ",clustmethod0," layout...\n")) -# pos <- pgx$cluster$pos[[clustmethod0]] -# if(pdim==2) pos <- pos[colnames(zx),1:2] -# if(pdim==3) pos <- pos[colnames(zx),1:3] -# } else { -# ##!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -# ## This should not be necessary anymore as we prefer to -# ## precompute all clusterings. -# shiny::showNotification(paste("computing ",clustmethod,"...\n")) -# -# ntop = 1000 -# ## ntop = as.integer(input$hm_ntop2) -# zx = zx[order(-apply(zx,1,sd)),,drop=FALSE] ## OK? -# if(nrow(zx) > ntop) { -# ##zx = head(zx,ntop) ## OK? -# zx = zx[1:ntop,,drop=FALSE] ## OK? -# } -# if("normalize" %in% input$hmpca_options) { -# zx <- scale(t(scale(t(zx)))) -# } -# perplexity = max(1,min((ncol(zx)-1)/3, 30)) -# perplexity -# res <- pgx.clusterMatrix( -# zx, dims = pdim, perplexity = perplexity, -# ntop = 999999, prefix = "C", -# find.clusters = FALSE, kclust = 1, -# row.center = TRUE, row.scale = FALSE, -# method = clustmethod) -# if(pdim==2) pos <- res$pos2d -# if(pdim==3) pos <- res$pos3d -# } -# -# pos <- pos[colnames(zx),] -# pos = scale(pos) ## scale -# ##colnames(pos) = paste0("dim",1:ncol(pos)) -# ##rownames(pos) = colnames(zx) -# -# idx <- NULL -# dbg("[hm_getClusterPositions] done") -# -# clust = list(pos=pos, clust=idx) -# return(clust) -# }) -# -# hm_PCAplot.RENDER <- shiny::reactive({ -# -# ##pgx <- inputData() -# shiny::req(pgx$Y) -# -# do3d = ("3D" %in% input$hmpca_options) -# clust <- hm_getClusterPositions() -# pos <- clust$pos -# sel <- rownames(pos) -# df <- cbind(pos, pgx$Y[sel,]) -# if(!is.null(clust$clust)) df[[""]] <- clust$clust -# -# colvar = shapevar = linevar = textvar = NULL -# if(input$hmpca.colvar %in% colnames(df)) colvar <- factor(df[,input$hmpca.colvar]) -# if(input$hmpca.shapevar %in% colnames(df)) shapevar <- factor(df[,input$hmpca.shapevar]) -# ##if(input$hmpca.line %in% colnames(df)) linevar = factor(df[,input$hmpca.line]) -# ##if(input$hmpca.text %in% colnames(df)) textvar = factor(df[,input$hmpca.text]) -# mode = "markers" -# ann.text = rep(" ",nrow(df)) -# if(!do3d && "sample label" %in% input$hmpca_options) ann.text = rownames(df) -# if(!is.null(colvar)) { -# colvar = factor(colvar) -# textvar <- factor(df[,input$hmpca.colvar]) -# } -# symbols = c('circle','square','star','triangle-up','triangle-down','pentagon', -# 'bowtie','hexagon', 'asterisk','hash','cross','triangle-left', -# 'triangle-right','+',c(15:0)) -# -# -# Y <- cbind("sample"=rownames(pos), pgx$Y[sel,]) -# ##tt.info <- paste('Sample:', rownames(df),'
Group:', df$group) -# tt.info <- apply(Y, 1, function(y) paste0(colnames(Y),": ",y,"
",collapse="")) -# tt.info <- as.character(tt.info) -# cex1 = c(1.0,0.8,0.6)[1 + 1*(nrow(pos)>30) + 1*(nrow(pos)>200)] -# -# if(do3d ) { -# ## 3D plot -# j0 = 1:nrow(df) -# j1 = NULL -# if(!is.null(linevar)) { -# linevar = factor(linevar) -# j0 = which(linevar==levels(linevar)[1]) -# j1 = which(linevar!=levels(linevar)[1]) -# } -# plt <- plotly::plot_ly(df, mode=mode) %>% -# plotly::add_markers(x = df[j0,1], y = df[j0,2], z = df[j0,3], type="scatter3d", -# color = colvar[j0], ## size = sizevar, sizes=c(80,140), -# ##marker = list(size = 5*cex1), -# marker = list(size=5*cex1, line=list(color="grey10", width=0.1)), -# symbol = shapevar[j0], symbols=symbols, -# text = tt.info[j0] ) %>% -# plotly::add_annotations(x = pos[,1], y = pos[,2], z = pos[,3], -# text = ann.text, -# ##xref = "x", yref = "y", -# showarrow = FALSE) -# if(!is.null(j1) & length(j1)>0) { -# plt <- plt %>% plotly::add_markers( -# x = df[j1,1], y = df[j1,2], z = df[j1,3], type="scatter3d", -# color = colvar[j1], ## size = sizevar, sizes=c(80,140), -# ##marker = list(size=5*cex1, line=list(color="grey10", width=2)), -# symbol = shapevar[j1], symbols=symbols, -# text=tt.info[j1]) -# } -# ## add cluster annotation labels -# if(0 && length(unique(colvar))>1) { -# ## add cluster annotation labels -# grp.pos <- apply(pos,2,function(x) tapply(x,colvar,median)) -# ##grp.pos <- matrix(grp.pos, ncol=3) -# cex2 <- ifelse(length(grp.pos)>20,0.8,1) -# plt <- plt %>% plotly::add_annotations( -# x = grp.pos[,1], y = grp.pos[,2], z = grp.pos[,3], -# text = rownames(grp.pos), -# font=list(size=24*cex2, color='#555'), -# showarrow = FALSE) -# } -# -# } else { -# -# ## 2D plot -# j0 = 1:nrow(df) -# j1 = NULL -# if(!is.null(linevar)) { -# linevar = factor(linevar) -# j0 = which(linevar==levels(linevar)[1]) -# j1 = which(linevar!=levels(linevar)[1]) -# } -# plt <- plotly::plot_ly(df, mode=mode) %>% -# plotly::add_markers(x = df[j0,1], y = df[j0,2], type="scatter", -# color = colvar[j0], ## size = sizevar, sizes=c(80,140), -# marker = list(size=16*cex1, line=list(color="grey20", width=0.6)), -# symbol = shapevar[j0], symbols=symbols, -# text = tt.info[j0] ) %>% -# plotly::add_annotations(x = pos[,1], y = pos[,2], -# text = ann.text, -# ##xref = "x", yref = "y", -# showarrow = FALSE) -# -# ## add node labels -# if(!is.null(j1) & length(j1)>0 ) { -# plt <- plt %>% plotly::add_markers( -# x = df[j1,1], y = df[j1,2], type="scatter", -# color = colvar[j1], ## size = sizevar, sizes=c(80,140), -# marker = list(size=16*cex1, line=list(color="grey20", width=1.8)), -# symbol = shapevar[j1], symbols=symbols, -# text=tt.info[j1]) -# } -# -# ## add group/cluster annotation labels -# req(input$hmpca_legend) -# if(input$hmpca_legend == 'inside') { -# plt <- plt %>% -# plotly::layout(legend = list(x=0.05, y=0.95)) -# } else if(input$hmpca_legend == 'bottom') { -# plt <- plt %>% -# plotly::layout(legend = list(orientation='h')) -# } else { -# if(!is.null(textvar) && length(unique(textvar))>1) { -# grp.pos <- apply(pos,2,function(x) tapply(x,as.character(textvar),median)) -# cex2 <- 1 -# if(length(grp.pos)>20) cex2 <- 0.8 -# if(length(grp.pos)>50) cex2 <- 0.6 -# plt <- plt %>% plotly::add_annotations( -# x = grp.pos[,1], y = grp.pos[,2], -# text = paste0("",rownames(grp.pos),""), -# font = list(size=24*cex2, color='#555'), -# showarrow = FALSE) -# } -# plt <- plt %>% -# plotly::layout(showlegend = FALSE) -# } -# -# -# } -# title = paste0("PCA (",nrow(pos)," samples)") -# if(input$hm_clustmethod=="tsne") title = paste0("tSNE (",nrow(pos)," samples)") -# plt <- plt %>% -# plotly::config(displayModeBar = TRUE) %>% -# ##config(modeBarButtonsToRemove = all.plotly.buttons ) %>% -# plotly::config(displaylogo = FALSE) %>% -# plotly::config(toImageButtonOptions = list(format='svg', height=800, width=800)) -# ##print(plt) -# return(plt) -# }) - - # hm_PCAplot_opts = shiny::tagList( - # tipifyR( shiny::selectInput( ns("hmpca.colvar"), "Color/label:", choices=NULL, width='100%'), - # "Set colors/labels according to a given phenotype."), - # tipifyR( shiny::selectInput( ns("hmpca.shapevar"), "Shape:", choices=NULL, width='100%'), - # "Set shapes according to a given phenotype."), - # tipifyR( shiny::radioButtons( - # ns('hmpca_legend'), label = "Legend:", - # choices = c('group label','bottom'), inline=TRUE), - # "Normalize matrix before calculating distances."), - # tipifyR( shiny::checkboxGroupInput( ns('hmpca_options'),"Other:", - # choices=c('sample label','3D','normalize'), inline=TRUE), - # "Normalize matrix before calculating distances."), - # tipifyR( shiny::radioButtons( ns('hm_clustmethod'),"Layout:", - # c("default","tsne","pca","umap"),inline=TRUE), - # "Choose the layout method for clustering to visualise.") - # ) - - # hm_PCAplot_caption <- shiny::reactive({ - # text1 = "The plot visualizes the similarity of samples as a scatterplot in reduced dimension (2D or 3D). Samples that are similar (in expression) are clustered near to each other, while samples with different expression are positioned farther away. Groups of samples with similar profiles will appear as clusters in the plot." - # if(input$hmpca.colvar!="") { - # text1 <- paste(text1, "Colors correspond to the ",input$hmpca.colvar,"phenotype.") - # } - # if(input$hmpca.shapevar!="") { - # text1 <- paste(text1, "Shapes correspond to the ",input$hmpca.shapevar,"phenotype.") - # } - # return(shiny::HTML(text1)) - # }) - - # pca_caption_static = "PCA/tSNE plot. The plot visualizes the similarity in expression of samples as a scatterplot in reduced dimension (2D or 3D). Samples that are similar are clustered near to each other, while samples with different expression are positioned farther away. Groups of samples with similar profiles will appear as clusters in the plot." - - # shiny::callModule( #not used - # plotModule, - # id = "hm_PCAplot", - # func = hm_PCAplot.RENDER, ## ns=ns, - # plotlib = "plotly", - # options = hm_PCAplot_opts, - # height = c(fullH-80,700), width=c("auto",800), - # pdf.width=8, pdf.height=8, - # title="PCA/tSNE plot", - # info.text = hm_PCAplot_text, - # add.watermark = WATERMARK - # ) - - # end PCA refactoring ############ - - # start Parallel coordinates refactoring ########## - - # hm_parcoord.ranges <- shiny::reactiveValues() - # - # hm_parcoord.matrix <- shiny::reactive({ - # - # filt <- getTopMatrix() - # shiny::req(filt) - # zx <- filt$mat[,] - # if(input$hm_pcscale) { - # zx <- t(scale(t(zx))) - # } - # rr <- shiny::isolate(shiny::reactiveValuesToList(hm_parcoord.ranges)) - # nrange <- length(rr) - # for(i in names(rr)) hm_parcoord.ranges[[i]] <- NULL - # zx <- round(zx, digits=3) - # list(mat=zx, clust=filt$idx) - # }) - # - # hm_parcoord.RENDER <- shiny::reactive({ - # - # pc <- hm_parcoord.matrix() - # shiny::req(pc) - # zx <- pc$mat - # ## build dimensions - # dimensions <- list() - # for(i in 1:ncol(zx)) { - # dimensions[[i]] <- list( - # range = c(min(zx[,i]),max(zx[,i])), - # ## constraintrange = c(100000,150000), - # ## tickvals = c(0,0.5,1,2,3), - # ## ticktext = c('A','AB','B','Y','Z'), - # visible = TRUE, - # label = colnames(zx)[i], - # values = zx[,i] - # ) - # } - # - # clust.id <- as.integer(factor(pc$clust)) - # table(clust.id) - # - # df <- data.frame(clust.id=clust.id, zx) - # klrpal = rep(RColorBrewer::brewer.pal(8,"Set2"),99) - # ##klrpal = rep(c("red","blue","green","yellow","magenta","cyan","black","grey"),99) - # klrpal = klrpal[1:max(clust.id)] - # ##klrpal <- setNames(klrpal, sort(unique(clust.id))) - # klrpal2 <- lapply(1:length(klrpal),function(i) c((i-1)/(length(klrpal)-1),klrpal[i])) - # - # plt <- plotly::plot_ly(df, source = "pcoords") %>% - # plotly::add_trace(type = 'parcoords', - # line = list(color = ~clust.id, - # ## colorscale = list(c(0,'red'),c(0.5,'green'),c(1,'blue')) - # ##colorscale = 'Jet', - # colorscale = klrpal2, - # cmin = min(clust.id), cmax = max(clust.id), - # showscale = FALSE - # ##reversescale = TRUE - # ), - # dimensions = dimensions) - # plt <- plt %>% - # plotly::layout(margin = list(l=60, r=60, t=0, b=30)) %>% - # ##config(displayModeBar = FALSE) %>% - # ##config(modeBarButtonsToRemove = setdiff(all.plotly.buttons,"toImage") ) %>% - # plotly::config(toImageButtonOptions = list(format='svg', width=900, height=350, scale=1.2)) %>% - # plotly::config(displaylogo = FALSE) %>% - # plotly::event_register("plotly_restyle") - # - # plt - # - # }) - - -# hm_parcoord_opts = shiny::tagList( -# withTooltip( shiny::checkboxInput(ns('hm_pcscale'),'Scale values',TRUE), -# "Scale expression values to mean=0 and SD=1.", -# placement="right",options = list(container = "body")) -# ) -# -# -# hm_parcoord_text = tagsub("The Parallel Coordinates panel -# displays the expression levels of selected genes across all conditions in the analysis. On the x-axis the experimental conditions are plotted. The y-axis shows the expression level of the genes grouped by condition. The colors correspond to the gene groups as defined by the hierarchical clustered heatmap.") - - # shiny::callModule( - # plotModule, - # ## hm_parcoord_module <- plotModule( - # "hm_parcoord", - # func = hm_parcoord.RENDER, ## ns = ns, - # plotlib = "plotly", ## renderFunc="renderPlotly", - # ## download.fmt = c("png","pdf","html"), ## PNG & PDF do not work!!! - # ## download.fmt = c("html"), - # options = hm_parcoord_opts, - # height = c(0.45*fullH,600), width = c("100%",1000), - # pdf.width=10, pdf.height=6, info.width="350px", - # title = "Parallel coordinates", label = "a", - # info.text = hm_parcoord_text, - # add.watermark = WATERMARK - # ## caption = hm_parcoord_text, - # ) - - # end Parallel coordinates refactoring ########## - - - # hm_parcoord_table refactored into plot module ############# - hm_parcoord_table.RENDER <- shiny::reactive({ mat = hm_parcoord.selected()$mat @@ -1511,216 +713,6 @@ The Clustering Analysis module performs unsupervised clustering height = c(270,700) ) - # end hm_parcoord_table ############# - - - # clustannot_plots clustannot_table refactoring into plot module ######### - - - # clustannot_plots_text = paste0('The top features of the heatmap in the Heatmap panel are divided into gene (or gene set) clusters based on their expression profile patterns. For each cluster, the platform provides a functional annotation in the Annotate cluster panel by correlating annotation features from more than 42 published reference databases, including well-known databases such as ',a_MSigDB,', ',a_KEGG,' and ',a_GO,'. In the plot settings, users can specify the level and reference set to be used under the Reference level and Reference set settings, respectively.') - - - # clustannot_plots.PLOTLY <- shiny::reactive({ - # - # rho = getClustAnnotCorrelation() - # ##if(is.null(rho)) return(NULL) - # shiny::req(rho) - # - # ##par(mfrow=c(2,3), mar=c(3.5,2,2,1), mgp=c(2,0.8,0)) - # NTERMS = 6 - # NTERMS = 12 - # slen=40 - # if(ncol(rho)>=5) { - # slen=20 - # } - # if(ncol(rho)>6) { - # NTERMS=6 - # } - # if(ncol(rho)<=2) { - # NTERMS=22 - # } - # - # klrpal <- omics_pal_d("muted_light")(ncol(rho)) - # #klrpal <- paste0(klrpal, "B3") - # - # plot_list <- list() - # i = 1 - # for(i in 1:min(9, ncol(rho))) { - # - # x <- rev(head(sort(rho[,i], decreasing = TRUE), NTERMS)) - # names(x) <- sub(".*:", "", names(x)) - # names(x) <- gsub(GSET.PREFIX.REGEX, "", names(x)) - # - # y <- names(x) - # y <- factor(y, levels = y) - # anntitle <- function(tt) { - # list( - # x = 0.5, y = 1.02, - # xref = "paper", yref = "paper", - # xanchor = "center", yanchor = "bottom", - # text = tt, font = list(size = 13), - # align = "center", showarrow = FALSE - # ) - # } - # ## NOTE: The same plotly code (originally) as in `plot_clustannot.R` - # ## -> Seems it uses the function from this file, not the other one - # ## TODO: clean-up; we should stick to the general setup of individual - # ## scripts for the plotting functions, not inside the server scripts as agreed - # plot_list[[i]] <- - # plotly::plot_ly( - # x = x, - # y = y, - # type = 'bar', - # orientation = 'h', - # hoverinfo = 'text', - # hovertemplate = ~paste0( - # ## TODO: the cluster ID in the tooltip is assigned wrongly (it's always S4), - # ## needs to be fixed (or that information to be removed) - # "Annotation: %{y}
", - # "Cluster: ", colnames(rho)[i], "
", - # "Correlation (R): ", sprintf("%1.2f", x), "", - # "" - # ), - # ## NOTE: I suggest to not use a categorical palette for the different clusters; - # ## the panels alone highlight the different groups and a single color would - # ## allow for a fair comparison (in terms of visual weight), solve all - # ## readability problems and would make the page much more calm - # ## TODO: if you agree, set to single color instead - # marker = list(color = klrpal[i]) - # ) %>% - # ## labeling the y-axis inside bars - # plotly::add_annotations( - # x = .01, - # y = y, - # xref = 'paper', - # yref = 'y', - # xanchor = 'left', - # text = shortstring(y, slen), - # font = list(size = 10), - # showarrow = FALSE, - # align = 'right' - # ) %>% - # plotly::layout( - # ## TODO: check x axis ranges! while in the lower row x is scaled from 0 to .9, - # ## in the upper it's ranging free (kinda; when you plot the axis, - # ## the axis range is the same but the tooltip and axis are out of sync) - # xaxis = list( - # range = c(0, .9), - # font = list(family = "Lato"), - # titlefont = list(size = 11), - # tickfont = list(size = 10), - # showgrid = FALSE, - # title = "\ncorrelation (R)" - # ), - # yaxis = list( - # title = FALSE, - # showgrid = FALSE, - # showline = FALSE, - # showticklabels = FALSE, - # showgrid = FALSE, - # zeroline = FALSE - # ), - # showlegend = FALSE, - # annotations = anntitle(colnames(rho)[i]), - # bargap = .2, - # margin = list(l = 5, r = 0, b = 25, t = 20) - # ) %>% - # plotly_default1() - # } - # - # if(length(plot_list) <= 4) { - # nrows = ceiling(length(plot_list) / 2 ) - # } else { - # nrows = ceiling(length(plot_list) / 3 ) - # } - # - # plotly::subplot( - # plot_list, - # nrows = nrows, - # shareX = TRUE, - # margin = c(0, 0, .05, .05) - # ) %>% - # plotly::config(displayModeBar = FALSE) - # }) - - # clustannot_plots_opts = shiny::tagList( - # withTooltip( shiny::selectInput(ns("xann_level"), "Reference level:", - # choices=c("gene","geneset","phenotype"), - # selected="geneset", width='80%'), - # "Select the level of an anotation analysis.", - # placement="left", options = list(container = "body")), - # shiny::conditionalPanel( - # "input.xann_level == 'geneset'", ns=ns, - # withTooltip( shiny::checkboxInput(ns("xann_odds_weighting"), "Fisher test weighting"), - # "Enable weighting with Fisher test probability for gene sets. This will effectively penalize small clusters and increase robustness.", - # placement="left", options = list(container = "body")) - # ), - # withTooltip( shiny::selectInput( ns("xann_refset"), "Reference set:", choices="", width='80%'), - # "Specify a reference set to be used in the annotation.", - # placement="left",options = list(container = "body")) - # ) - - ##clustannot_plots_module <- plotModule( - # shiny::callModule( - # plotModule, - # id="clustannot_plots", ##ns=ns, - # ##func=clustannot_plots.RENDER, plotlib = "base", - # func = clustannot_plots.PLOTLY, plotlib="plotly", - # download.fmt = c("png","pdf"), - # options = clustannot_plots_opts, - # height = c(360,600), width = c("100%",1000), - # pdf.width=8, pdf.height=5, res=80, - # title="Functional annotation of clusters", label="a", - # info.text = clustannot_plots_text, - # add.watermark = WATERMARK - # ) - - # clustannot_table.RENDER <- shiny::reactive({ - # - # rho = getClustAnnotCorrelation() - # if(is.null(rho)) return(NULL) - # - # ##rownames(rho) = shortstring(rownames(rho),50) - # rho.name = shortstring(sub(".*:","",rownames(rho)),60) - # ##rho = data.frame(cbind( name=rho.name, rho)) - # df = data.frame( feature=rho.name, round(as.matrix(rho),digits=3)) - # rownames(df) = rownames(rho) - # if(input$xann_level=="geneset") { - # df$feature <- wrapHyperLink(df$feature, rownames(df)) - # } - # - # DT::datatable( - # df, rownames=FALSE, escape = c(-1,-2), - # extensions = c('Buttons','Scroller'), - # selection=list(mode='single', target='row', selected=c(1)), - # class = 'compact hover', - # fillContainer = TRUE, - # options=list( - # dom = 'lfrtip', buttons = c('copy','csv','pdf'), - # ##pageLength = 20,## lengthMenu = c(20, 30, 40, 60, 100, 250), - # scrollX = TRUE, ##scrollY = TRUE, - # ##scrollY = 170, - # scrollY = '70vh', - # scroller=TRUE, - # deferRender=TRUE - # ) ## end of options.list - # ) %>% - # DT::formatStyle(0, target='row', fontSize='11px', lineHeight='70%') - # }) - # - # clustannot_table_info_text = "In this table, users can check mean correlation values of features in the clusters with respect to the annotation references database selected in the settings." - # - # ##clustannot_table_module <- tableModule( - # clustannot_table_module <- shiny::callModule( - # tableModule, - # id = "clustannot_table", - # func = clustannot_table.RENDER, - # ##options = clustannot_table_opts, - # info.text = clustannot_table_info_text, - # title="Annotation scores", label="b", - # height = c(240,700), width=c('auto',1000), - # ##caption = clustannot_caption - # ) clustannot_caption = "Cluster annotation. (a) Top ranked annotation features (by correlation) for each gene cluster as defined in the heatmap. (b) Table of average correlation values of annotation features, for each gene cluster." @@ -1734,264 +726,5 @@ The Clustering Analysis module performs unsupervised clustering ) }) - # end clustannot_plots clustannot_table refactoring into plot module ######### - - # clust_phenoplot refactoring into plotmodule ########## - - # clust_phenoplot.RENDER <- shiny::reactive({ - # - # ##pgx <- inputData() - # shiny::req(pgx$Y) - # - # ## get t-SNE positions - # clust <- hm_getClusterPositions() - # ##pos = pgx$tsne2d - # pos = clust$pos - # - # Y <- pgx$Y[rownames(pos),,drop=FALSE] - # pheno = colnames(Y) - # - # ## don't show these... - # pheno <- grep("batch|sample|donor|repl|surv",pheno, - # invert=TRUE, ignore.case=TRUE,value=TRUE) - # - # ## layout - # par(mfrow = c(3,2), mar=c(0.3,0.7,2.8,0.7)) - # if(length(pheno)>=6) par(mfrow = c(4,3), mar=c(0.3,0.4,2.8,0.4)*0.8) - # if(length(pheno)>=12) par(mfrow = c(5,4), mar=c(0.2,0.2,2.5,0.2)*0.8) - # i=1 - # - # cex1 <- 1.1*c(1.8,1.3,0.8,0.5)[cut(nrow(pos),breaks=c(-1,40,200,1000,1e10))] - # cex1 = cex1 * ifelse(length(pheno)>6, 0.8, 1) - # cex1 = cex1 * ifelse(length(pheno)>12, 0.8, 1) - # - # for(i in 1:min(20,length(pheno))) { - # - # ## ------- set colors - # colvar = factor(Y[,1]) - # colvar = factor(Y[,pheno[i]]) - # colvar[which(colvar %in% c(NA,""," ","NA","na"))] <- NA - # colvar = factor(as.character(colvar)) - # klrpal = COLORS - # klr1 = klrpal[colvar] - # klr1 = paste0(gplots::col2hex(klr1),"99") - # jj = which(is.na(klr1)) - # if(length(jj)) klr1[jj] <- "#AAAAAA22" - # tt = tolower(pheno[i]) - # - # ## ------- start plot - # base::plot( pos[,], pch=19, cex=cex1, col=klr1, - # fg = gray(0.5), bty = "o", xaxt='n', yaxt='n', - # xlab="tSNE1", ylab="tSNE2") - # title( tt, cex.main=1.3, line=0.5, col="grey40") - # if(input$clust_phenoplot_labelmode=="legend") { - # legend("bottomright", legend=levels(colvar), fill=klrpal, - # cex=0.95, y.intersp=0.85, bg="white") - # } else { - # grp.pos <- apply(pos,2,function(x) tapply(x,colvar,mean,na.rm=TRUE)) - # grp.pos <- apply(pos,2,function(x) tapply(x,colvar,median,na.rm=TRUE)) - # nvar <- length(setdiff(colvar,NA)) - # if(nvar==1) { - # grp.pos <- matrix(grp.pos,nrow=1) - # rownames(grp.pos) <- setdiff(colvar,NA)[1] - # } - # labels = rownames(grp.pos) - # boxes = sapply(nchar(labels),function(n) paste(rep("\u2588",n),collapse="")) - # cex2 = 0.9*cex1**0.33 - # text( grp.pos, labels=boxes, cex=cex2*0.95, col="#CCCCCC99") - # text( grp.pos, labels=labels, font=2, cex=cex2) - # } - # } - # }) - - # clust_phenoplot.opts = shiny::tagList( - # shiny::radioButtons(ns('clust_phenoplot_labelmode'),"Label",c("groups","legend"),inline=TRUE) - # ) - - # clust_phenoplot_info = tagsub("Phenotype distribution. This figure visualizes the distribution of the available phenotype data. You can choose to put the group labels in the figure or as separate legend in the {Label} setting, in the plot {{settings}}") - - ## clust_phenoplot.module <- plotModule( - - # shiny::callModule( - # plotModule, - # "clust_phenoplot", ## ns=ns, - # func = clust_phenoplot.RENDER, ## plotlib="base", - # func2 = clust_phenoplot.RENDER, ## plotlib="base", - # options = clust_phenoplot.opts, - # height = c(fullH-80,700), res = 85, - # pdf.width = 6, pdf.height = 9, - # info.text = clust_phenoplot_info, - # add.watermark = WATERMARK - # ) - - # end clust_phenoplot refactoring into plotmodule ########## - - ## Feature ranking ########### - - - # end clust_featureRank conversion to plotmodule ########### -# -# calcFeatureRanking <- shiny::reactive({ -# -# shiny::req(pgx$X, pgx$Y, pgx$gsetX, pgx$genes) -# -# features=X=NULL -# if(input$hm_level=="geneset") { -# features = COLLECTIONS -# X = pgx$gsetX -# } else { -# features = pgx$families -# X = pgx$X -# } -# -# ## ------------ intersect features, set minimum set size -# rownames(X) <- toupper(rownames(X)) -# genes <- toupper(rownames(X)) -# features <- lapply(features, toupper) -# features <- lapply(features, function(f) intersect(toupper(f), genes)) -# features <- features[sapply(features,length) >=10 ] -# -# dbg("[calcFeatureRanking] length(features)=",length(features)) -# -# ## ------------ Just to get current samples -# ##samples = colnames(X) -# samples <- selectSamplesFromSelectedLevels(pgx$Y, input_hm_samplefilter() ) -# X = X[,samples] -# cvar <- pgx.getCategoricalPhenotypes(pgx$Y, max.ncat=999) -# cvar <- grep("sample|patient|years|days|months|gender", -# cvar,invert=TRUE,value=TRUE) ## no sample IDs -# cvar -# Y = pgx$Y[colnames(X),cvar,drop=FALSE] -# kk = which(apply(Y,2,function(y) length(unique(y))>1)) -# Y = Y[,kk,drop=FALSE] -# dim(Y) -# -# dbg("[calcFeatureRanking] dim(X)=",dim(X)) -# dbg("[calcFeatureRanking] dim(Y)=",dim(Y)) -# -# ## ------------ Note: this takes a while. Maybe better precompute off-line... -# sdx = apply(X,1,sd) -# names(sdx) = rownames(X) -# S = matrix(NA, nrow=length(features), ncol=ncol(Y)) -# rownames(S) = names(features) -# colnames(S) = colnames(Y) -# -# ## ------------ Create a Progress object -# if(!interactive()) { -# progress <- shiny::Progress$new() -# on.exit(progress$close()) -# progress$set(message = "Calculating feature-set scores", value = 0) -# } -# -# gene.level = TRUE -# gene.level = (input$hm_level=="gene") -# i=1 -# for(i in 1:ncol(Y)) { -# -# if(!interactive()) progress$inc(1/ncol(Y)) -# -# grp = Y[,i] -# grp = as.character(grp) -# -# cat("[calcFeatureRanking] head(grp)=",head(grp),"\n") -# -# score = rep(NA, length(features)) -# names(score) = names(features) -# j=1 -# for(j in 1:length(features)) { -# -# pp = features[[j]] -# if(gene.level) { -# pp = filterProbes(pgx$genes, features[[j]]) -# } -# pp = head(pp[order(-sdx[pp])],1000) ## how many top SD?? -# pp = intersect(pp, rownames(X)) -# X1 = X[pp,,drop=FALSE] -# dim(X1) -# ##cat(" dim(X1)=",dim(X1),"\n") -# ##if( nrow(X1) -# -# s1 = s2 = 1 -# method = input$clust_featureRank_method -# if(method %in% c("correlation","meta")) { -# mx = t(apply(X1, 1, function(x) tapply(x,grp,mean))) -# if(nrow(mx)==0 || ncol(mx)==0) next -# D = 1 - cor(mx, use="pairwise") -# diag(D) = NA -# s1 = mean(D,na.rm=TRUE) -# } -# -# if(method %in% c("p-value","meta")) { -# jj <- which(!is.na(grp)) -# design = model.matrix( ~ grp[jj]) -# suppressWarnings( fit <- limma::eBayes( limma::lmFit( X1[,jj], design)) ) -# suppressWarnings( suppressMessages( top <- limma::topTable(fit) )) -# ##s2 = mean(-log10(top$P.Value)) ## as score -# s2 = mean(-log10(1e-99 + top$adj.P.Val),na.rm=TRUE) ## as score -# } -# -# f = 1 -# f <- (1 - exp(-(length(pp)/20)**2)) ## penalize smaller sets -# score[j] = f * (s1 * s2) ** ifelse(method=="meta",0.5,1) -# -# } -# S[,i] = score -# } -# S[is.na(S)] <- 0 ## missing values -# return(S) -# }) -# -# clust_featureRank.RENDER <- shiny::reactive({ -# -# S <- calcFeatureRanking() -# -# if(is.null(S) || nrow(S)==0 || ncol(S)==0 ) return(NULL) -# -# ## top scoring -# S = tail( S[order(rowSums(S)),,drop=FALSE], 35) -# -# par(mfrow=c(2,1), mar=c(1,5,3,3) ) -# par(mfrow=c(1,2), mar=c(5,5,3,2), oma=c(6,0,3,0)); frame() -# ## par(mfrow=c(1,1), mar=c(10,5,3,3) ) -# rownames(S) = substring(rownames(S),1,80) -# bpos = barplot( t(S), beside=FALSE, las=1, -# cex.names=0.9, horiz=TRUE, -# xlab="discriminant score" ) -# ##title("feature-set score", cex=1.3) -# cc1 = grey.colors(ncol(S)) -# legend("bottomright",legend=colnames(S), fill=cc1, -# cex=0.8, y.intersp=0.8, inset=c(0,0.035), bg="white") -# -# }) - - - # clust_featureRank_info = "Ranked discriminant score for top feature sets. The plot ranks the discriminitive power of the feature set (genes) as a cumulative discriminant score for all phenotype variables. In this way, we can find which feature set (or gene family/set) can explain the variance in the data the best.

Correlation-based discriminative power is calculated as the average '(1-cor)' between the groups. Thus, a feature set is highly discriminative if the between-group correlation is low. P-value based scoring is computed as the average negative log p-value from the ANOVA. The 'meta' method combines the score of the former methods in a multiplicative manner." - # - # - # clust_featureRank.opts = shiny::tagList( - # withTooltip( shiny::radioButtons( ns('clust_featureRank_method'),'Method:', - # choices=c("p-value","correlation","meta"), - # inline=TRUE), - # "Choose ranking method: p-value based or correlation-based.", - # placement="right", options = list(container = "body") ) - # ) - - # shiny::callModule( - # plotModule, - # id="clust_featureRank", - # title="Feature-set ranking", - # func = clust_featureRank.RENDER, - # func2 = clust_featureRank.RENDER, - # options = clust_featureRank.opts, - # pdf.width=8, pdf.height=10, - # height = c(fullH-80,700), - # width=c("auto",800), - # res = c(72,90), - # info.text = clust_featureRank_info, - # add.watermark = WATERMARK - # ) - - # end clust_featureRank conversion to plotmodule ########### - }) ## end of moduleServer } ## end of Board From 535a323d2e4b5e2bbc14ef14c133ae95acac2f29 Mon Sep 17 00:00:00 2001 From: mauromiguelm Date: Thu, 23 Feb 2023 16:24:53 +0100 Subject: [PATCH 33/44] feat: `featurerank` converted to plotly --- .../R/clustering_plot_featurerank.R | 34 ++++++++++++------- 1 file changed, 22 insertions(+), 12 deletions(-) diff --git a/components/board.clustering/R/clustering_plot_featurerank.R b/components/board.clustering/R/clustering_plot_featurerank.R index f0c896808..8bfde2e6b 100644 --- a/components/board.clustering/R/clustering_plot_featurerank.R +++ b/components/board.clustering/R/clustering_plot_featurerank.R @@ -28,7 +28,7 @@ clustering_plot_featurerank_ui <- function(id, PlotModuleUI( ns("pltmod"), label = label, - plotlib = "base", + plotlib = "plotly", title = "Feature-set ranking", info.text = clust_featureRank_info, options = clust_featureRank.opts, @@ -169,26 +169,36 @@ clustering_plot_featurerank_server <- function(id, ## top scoring S = tail( S[order(rowSums(S)),,drop=FALSE], 35) + rownames(S) = substring(rownames(S),1,80) - par(mfrow=c(1,2), mar=c(5,5,3,2), oma=c(6,0,3,0)); frame() + cc1 = grey.colors(ncol(S)) - rownames(S) = substring(rownames(S),1,80) + browser() - bpos = barplot( t(S), beside=FALSE, las=1, - cex.names=0.9, horiz=TRUE, - xlab="discriminant score" ) + pgx.stackedBarplot(x = S, + showlegend = T, + xlab = "Discriminant score", + ylab = "Groups", + horiz = TRUE) + + + # par(mfrow=c(1,2), mar=c(5,5,3,2), oma=c(6,0,3,0)); frame() + # + # + # bpos = barplot( t(S), beside=FALSE, las=1, + # cex.names=0.9, horiz=TRUE, + # xlab="discriminant score" ) ##title("feature-set score", cex=1.3) - cc1 = grey.colors(ncol(S)) - legend("bottomright",legend=colnames(S), fill=cc1, - cex=0.8, y.intersp=0.8, inset=c(0,0.035), bg="white") - p <- grDevices::recordPlot() - p + # legend("bottomright",legend=colnames(S), fill=cc1, + # cex=0.8, y.intersp=0.8, inset=c(0,0.035), bg="white") + # p <- grDevices::recordPlot() + # p }) PlotModuleServer( "pltmod", - plotlib = "base", + plotlib = "plotly", ##plotlib2 = "plotly", func = clust_featureRank.RENDER, # csvFunc = plot_data, ## *** downloadable data as CSV From 3953eee66207fadac4c748966928678d3f6219cf Mon Sep 17 00:00:00 2001 From: mauromiguelm Date: Thu, 23 Feb 2023 16:25:19 +0100 Subject: [PATCH 34/44] feat: now `pgx.stackedBatplot` plot can rotate --- components/base/R/pgx-plotting.R | 24 +++++++++++++++++++----- 1 file changed, 19 insertions(+), 5 deletions(-) diff --git a/components/base/R/pgx-plotting.R b/components/base/R/pgx-plotting.R index 3b2556a2b..a5fdfc467 100644 --- a/components/base/R/pgx-plotting.R +++ b/components/base/R/pgx-plotting.R @@ -3373,23 +3373,37 @@ pgx.plotSampleClustering <- function(x, dim=2, } pgx.stackedBarplot <- function(x, + showlegend, ylab = NULL, - showlegend - ) - { + xlab = NULL, + horiz = FALSE + ) { + x_plot <- cbind(data.frame(groups = rownames(x)), x) x_plot <- data.table::melt(x_plot, id.vars='groups',value.name = "Effect") - x_plot$groups <- factor(x_plot$groups, levels = rownames(x)) + if(horiz == FALSE){ + x_plot$groups <- factor(x_plot$groups, levels = rownames(x)) + }else{ + c1 <- which(colnames(x_plot)=='variable') + c2 <- which(colnames(x_plot)=='Effect') + c3 <- which(colnames(x_plot)=='groups') + colnames(x_plot)[c1] <- "Effect" + colnames(x_plot)[c2] <- "groups" + colnames(x_plot)[c3] <- "variable" + } plotly::plot_ly(x_plot, x = ~groups, y = ~Effect, type = 'bar', name = ~variable, color = ~variable) %>% - plotly::layout(showlegend = showlegend, barmode = 'stack', yaxis = list(title = ylab)) %>% + plotly::layout(showlegend = showlegend, barmode = 'stack', + yaxis = list(title = ylab), + xaxis = list(title = xlab)) %>% plotly_default1() + } From c23e7cd9c1e708459bda166e0d1e89d7e01205cc Mon Sep 17 00:00:00 2001 From: mauromiguelm Date: Thu, 23 Feb 2023 16:31:36 +0100 Subject: [PATCH 35/44] remove 'browser()' --- components/board.clustering/R/clustering_plot_featurerank.R | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/components/board.clustering/R/clustering_plot_featurerank.R b/components/board.clustering/R/clustering_plot_featurerank.R index 8bfde2e6b..7c0c0e695 100644 --- a/components/board.clustering/R/clustering_plot_featurerank.R +++ b/components/board.clustering/R/clustering_plot_featurerank.R @@ -173,9 +173,7 @@ clustering_plot_featurerank_server <- function(id, cc1 = grey.colors(ncol(S)) - browser() - - pgx.stackedBarplot(x = S, + pgx.stackedBarplot(x = t(S), showlegend = T, xlab = "Discriminant score", ylab = "Groups", From 2704690ac85601d915969c5083c61d3276a5f1f5 Mon Sep 17 00:00:00 2001 From: mauromiguelm Date: Thu, 23 Feb 2023 16:32:04 +0100 Subject: [PATCH 36/44] clean code --- .../R/clustering_plot_featurerank.R | 13 ------------- 1 file changed, 13 deletions(-) diff --git a/components/board.clustering/R/clustering_plot_featurerank.R b/components/board.clustering/R/clustering_plot_featurerank.R index 7c0c0e695..830a67890 100644 --- a/components/board.clustering/R/clustering_plot_featurerank.R +++ b/components/board.clustering/R/clustering_plot_featurerank.R @@ -178,19 +178,6 @@ clustering_plot_featurerank_server <- function(id, xlab = "Discriminant score", ylab = "Groups", horiz = TRUE) - - - # par(mfrow=c(1,2), mar=c(5,5,3,2), oma=c(6,0,3,0)); frame() - # - # - # bpos = barplot( t(S), beside=FALSE, las=1, - # cex.names=0.9, horiz=TRUE, - # xlab="discriminant score" ) - ##title("feature-set score", cex=1.3) - # legend("bottomright",legend=colnames(S), fill=cc1, - # cex=0.8, y.intersp=0.8, inset=c(0,0.035), bg="white") - # p <- grDevices::recordPlot() - # p }) From 0978a6f6ef077de7a5a1335bd661c384773097e0 Mon Sep 17 00:00:00 2001 From: mauromiguelm Date: Fri, 24 Feb 2023 09:46:29 +0100 Subject: [PATCH 37/44] feat: `correlation_plot_corr` now can be ordered by magnitude of effect --- .../R/correlation_plot_table_corr.R | 30 +++++++++++++++++-- 1 file changed, 28 insertions(+), 2 deletions(-) diff --git a/components/board.correlation/R/correlation_plot_table_corr.R b/components/board.correlation/R/correlation_plot_table_corr.R index 1111cd306..e8f854cc5 100644 --- a/components/board.correlation/R/correlation_plot_table_corr.R +++ b/components/board.correlation/R/correlation_plot_table_corr.R @@ -19,11 +19,21 @@ correlation_plot_table_corr_ui <- function(id, ns <- shiny::NS(id) info_text <- "Top correlated genes. Highest correlated genes in respect to the selected gene. The height of the bars correspond to the Pearson correlation value. The dark grey bars correspond to the 'partial correlation' which essentially corrects the correlation value for indirect effects and tries to estimate the amount of direct interaction." + plot_opts <- shiny::tagList( + withTooltip(shiny::selectInput(ns("order_opt"), "Order by:", choices = c("Correlation", + "Partial Correlation", + "Both"), multiple = FALSE), + "Sort order of groups based on correlation.", + placement = "top" + ) + ) + div( PlotModuleUI(ns("plot"), title = "Top correlated genes", label = label, plotlib = "plotly", + options = plot_opts, info.text = info_text, download.fmt = c("png", "pdf", "csv"), width = width, @@ -63,8 +73,10 @@ correlation_plot_table_corr_server <- function(id, names(prho) <- rownames(df) prho <- prho[match(names(rho), names(prho))] names(prho) <- names(rho) + return(list( - rho, prho + rho, prho, + order_opt = input$order_opt )) }) @@ -85,7 +97,21 @@ correlation_plot_table_corr_server <- function(id, colnames(pd_plot) <- c("Correlation", "Partial correlation") - pd_plot <- pd_plot[order(pd_plot$Correlation,decreasing = TRUE),] + if(input$order_opt == "Correlation"){ + + pd_plot <- pd_plot[order(pd_plot$Correlation,decreasing = TRUE),] + + }else if(input$order_opt == "Partial Correlation"){ + + pd_plot <- pd_plot[order(pd_plot$`Partial correlation`,decreasing = TRUE),] + + }else if(input$order_opt == "Both"){ + + total_sum_cor <- rowSums(pd_plot) + + pd_plot <- pd_plot[order(total_sum_cor,decreasing = TRUE),] + + } pgx.stackedBarplot(x = pd_plot, ylab = "Correlation", From 8015790d5d244b4e69fe4cdb030099e159c570b1 Mon Sep 17 00:00:00 2001 From: mauromiguelm Date: Fri, 24 Feb 2023 09:48:53 +0100 Subject: [PATCH 38/44] fix: set `correlation_plot_corr` default to both --- .../board.correlation/R/correlation_plot_table_corr.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/components/board.correlation/R/correlation_plot_table_corr.R b/components/board.correlation/R/correlation_plot_table_corr.R index e8f854cc5..04e5c0e39 100644 --- a/components/board.correlation/R/correlation_plot_table_corr.R +++ b/components/board.correlation/R/correlation_plot_table_corr.R @@ -20,9 +20,9 @@ correlation_plot_table_corr_ui <- function(id, info_text <- "Top correlated genes. Highest correlated genes in respect to the selected gene. The height of the bars correspond to the Pearson correlation value. The dark grey bars correspond to the 'partial correlation' which essentially corrects the correlation value for indirect effects and tries to estimate the amount of direct interaction." plot_opts <- shiny::tagList( - withTooltip(shiny::selectInput(ns("order_opt"), "Order by:", choices = c("Correlation", - "Partial Correlation", - "Both"), multiple = FALSE), + withTooltip(shiny::selectInput(ns("order_opt"), "Order by:", choices = c("Both", + "Correlation", + "Partial Correlation"), multiple = FALSE), "Sort order of groups based on correlation.", placement = "top" ) From 750ba114e4432fe0893ec1d8f78d051e33469ae8 Mon Sep 17 00:00:00 2001 From: mauromiguelm Date: Fri, 24 Feb 2023 09:49:19 +0100 Subject: [PATCH 39/44] code cleaning --- .../R/correlation_plot_table_corr.R | 20 ------------------- 1 file changed, 20 deletions(-) diff --git a/components/board.correlation/R/correlation_plot_table_corr.R b/components/board.correlation/R/correlation_plot_table_corr.R index 04e5c0e39..9bcd63d93 100644 --- a/components/board.correlation/R/correlation_plot_table_corr.R +++ b/components/board.correlation/R/correlation_plot_table_corr.R @@ -116,28 +116,8 @@ correlation_plot_table_corr_server <- function(id, pgx.stackedBarplot(x = pd_plot, ylab = "Correlation", showlegend = FALSE) - - - # par(mfrow = c(1, 1), mar = c(10, 4, 1, 0.5)) - # barplot(rho, - # beside = FALSE, las = 3, - # ylim = ylim0, - # ylab = "correlation", - # cex.names = 0.85 - # ) - # barplot(prho, - # beside = FALSE, add = TRUE, - # col = "grey40", names.arg = "" - # ) - # legend("topright", - # cex = 0.85, y.intersp = 0.85, - # inset = c(0.035, 0), - # c("correlation", "partial correlation"), - # fill = c("grey70", "grey40") - # ) } - ### TABLE cor_table.RENDER <- shiny::reactive({ From da5c4551b23413b6c9138c826d0046d3eec17c3c Mon Sep 17 00:00:00 2001 From: mauromiguelm Date: Fri, 24 Feb 2023 10:13:59 +0100 Subject: [PATCH 40/44] fix: now default is set correctly --- .../board.correlation/R/correlation_plot_table_corr.R | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/components/board.correlation/R/correlation_plot_table_corr.R b/components/board.correlation/R/correlation_plot_table_corr.R index 9bcd63d93..f815d3ca7 100644 --- a/components/board.correlation/R/correlation_plot_table_corr.R +++ b/components/board.correlation/R/correlation_plot_table_corr.R @@ -20,9 +20,12 @@ correlation_plot_table_corr_ui <- function(id, info_text <- "Top correlated genes. Highest correlated genes in respect to the selected gene. The height of the bars correspond to the Pearson correlation value. The dark grey bars correspond to the 'partial correlation' which essentially corrects the correlation value for indirect effects and tries to estimate the amount of direct interaction." plot_opts <- shiny::tagList( - withTooltip(shiny::selectInput(ns("order_opt"), "Order by:", choices = c("Both", - "Correlation", - "Partial Correlation"), multiple = FALSE), + withTooltip(shiny::selectInput(ns("order_opt"), "Order by:", + choices = c("Both", + "Correlation", + "Partial Correlation"), + multiple = FALSE, + selected = "Both"), "Sort order of groups based on correlation.", placement = "top" ) From 71362752a37bae91e70cf3f0a3eeab1372aec61b Mon Sep 17 00:00:00 2001 From: mauromiguelm Date: Fri, 24 Feb 2023 10:48:02 +0100 Subject: [PATCH 41/44] `hm_splitmap` moved to `iheatmapr` --- components/board.clustering/R/clustering_plot_hm_splitmap.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/components/board.clustering/R/clustering_plot_hm_splitmap.R b/components/board.clustering/R/clustering_plot_hm_splitmap.R index d2fd275df..c6d3e0a9c 100644 --- a/components/board.clustering/R/clustering_plot_hm_splitmap.R +++ b/components/board.clustering/R/clustering_plot_hm_splitmap.R @@ -79,7 +79,7 @@ clustering_plot_hm_splitmap_ui <- function(id, ns("pltmod"), title = "Clustered Heatmap", label = label, - # plotlib = "iheatmapr", + plotlib = "iheatmapr", info.text = info_text, options = hm_splitmap_opts, download.fmt = c("png", "pdf", "csv"), @@ -305,8 +305,8 @@ clustering_plot_hm_splitmap_server <- function(id, PlotModuleServer( "pltmod", - # plotlib = "iheatmapr", - func = hm1_splitmap.RENDER, + plotlib = "iheatmapr", + func = hm2_splitmap.RENDER, res = c(80, 95), ## resolution of plots pdf.width = 10, pdf.height = 8, add.watermark = watermark From 8f0a581e2888051cc33533c1019a08fe0382ae21 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Fri, 24 Feb 2023 11:52:06 +0100 Subject: [PATCH 42/44] fix: iheatmapr rendered through plotly --- .../board.clustering/R/clustering_plot_hm_splitmap.R | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/components/board.clustering/R/clustering_plot_hm_splitmap.R b/components/board.clustering/R/clustering_plot_hm_splitmap.R index c6d3e0a9c..aa34ddd22 100644 --- a/components/board.clustering/R/clustering_plot_hm_splitmap.R +++ b/components/board.clustering/R/clustering_plot_hm_splitmap.R @@ -79,7 +79,7 @@ clustering_plot_hm_splitmap_ui <- function(id, ns("pltmod"), title = "Clustered Heatmap", label = label, - plotlib = "iheatmapr", + plotlib = "plotly", info.text = info_text, options = hm_splitmap_opts, download.fmt = c("png", "pdf", "csv"), @@ -297,7 +297,8 @@ clustering_plot_hm_splitmap_server <- function(id, idx=idx, splitx=splitx, scale=scale, row_annot_width=0.03, rowcex=rowcex, colcex=colcex ) - + obj2 <- plt %>% iheatmapr::to_plotly_list() + plt <- plotly::as_widget(obj2) return(plt) } @@ -305,7 +306,7 @@ clustering_plot_hm_splitmap_server <- function(id, PlotModuleServer( "pltmod", - plotlib = "iheatmapr", + plotlib = "plotly", func = hm2_splitmap.RENDER, res = c(80, 95), ## resolution of plots pdf.width = 10, pdf.height = 8, From 83ebbc9345a84e590bea7148f2af447b386857ab Mon Sep 17 00:00:00 2001 From: mauromiguelm Date: Fri, 24 Feb 2023 13:42:11 +0100 Subject: [PATCH 43/44] remove old plot module --- .../R/clustering_plot_hm_parcoord.R | 16 ---------------- 1 file changed, 16 deletions(-) diff --git a/components/board.clustering/R/clustering_plot_hm_parcoord.R b/components/board.clustering/R/clustering_plot_hm_parcoord.R index 16beb06b4..3d00d7fd1 100644 --- a/components/board.clustering/R/clustering_plot_hm_parcoord.R +++ b/components/board.clustering/R/clustering_plot_hm_parcoord.R @@ -156,22 +156,6 @@ clustering_plot_hm_parcoord_server <- function(id, add.watermark = watermark ) - # shiny::callModule( - # plotModule, - # ## hm_parcoord_module <- plotModule( - # "hm_parcoord", - # func = hm_parcoord.RENDER, ## ns = ns, - # plotlib = "plotly", ## renderFunc="renderPlotly", - # ## download.fmt = c("png","pdf","html"), ## PNG & PDF do not work!!! - # ## download.fmt = c("html"), - # options = hm_parcoord_opts, - # height = c(0.45*fullH,600), width = c("100%",1000), - # pdf.width=10, pdf.height=6, info.width="350px", - # title = "Parallel coordinates", label = "a", - # info.text = hm_parcoord_text, - # add.watermark = WATERMARK - # ## caption = hm_parcoord_text, - # ) }) From 6baf303fd711ca0725b457bda8259da5e16496cc Mon Sep 17 00:00:00 2001 From: mauromiguelm Date: Fri, 24 Feb 2023 13:51:38 +0100 Subject: [PATCH 44/44] fix: corrected download data input arg --- components/board.clustering/R/clustering_plot_clustannot.R | 2 +- components/board.clustering/R/clustering_plot_featurerank.R | 2 +- components/board.clustering/R/clustering_plot_hm_parcoord.R | 6 +++--- components/board.clustering/R/clustering_plot_hm_splitmap.R | 5 ++--- 4 files changed, 7 insertions(+), 8 deletions(-) diff --git a/components/board.clustering/R/clustering_plot_clustannot.R b/components/board.clustering/R/clustering_plot_clustannot.R index e65186383..7485893e1 100644 --- a/components/board.clustering/R/clustering_plot_clustannot.R +++ b/components/board.clustering/R/clustering_plot_clustannot.R @@ -40,7 +40,7 @@ clustering_plot_clusterannot_ui <- function(id, title = "Functional annotation of clusters", info.text = clustannot_plots_text, options = clustannot_plots.opts, - download.fmt=c("png","pdf","csv"), + download.fmt=c("png","pdf"), width = width, height = height ) diff --git a/components/board.clustering/R/clustering_plot_featurerank.R b/components/board.clustering/R/clustering_plot_featurerank.R index 830a67890..d143a4546 100644 --- a/components/board.clustering/R/clustering_plot_featurerank.R +++ b/components/board.clustering/R/clustering_plot_featurerank.R @@ -186,7 +186,7 @@ clustering_plot_featurerank_server <- function(id, plotlib = "plotly", ##plotlib2 = "plotly", func = clust_featureRank.RENDER, - # csvFunc = plot_data, ## *** downloadable data as CSV + csvFunc = calcFeatureRanking, ## *** downloadable data as CSV ##renderFunc = plotly::renderPlotly, ##renderFunc2 = plotly::renderPlotly, res = c(72,90), ## resolution of plots diff --git a/components/board.clustering/R/clustering_plot_hm_parcoord.R b/components/board.clustering/R/clustering_plot_hm_parcoord.R index 3d00d7fd1..60094eed5 100644 --- a/components/board.clustering/R/clustering_plot_hm_parcoord.R +++ b/components/board.clustering/R/clustering_plot_hm_parcoord.R @@ -149,10 +149,10 @@ clustering_plot_hm_parcoord_server <- function(id, plotlib = "plotly", ##plotlib2 = "plotly", func = hm_parcoord.RENDER, - ##renderFunc = plotly::renderPlotly, - ##renderFunc2 = plotly::renderPlotly, res = c(90,170), ## resolution of plots - pdf.width = 8, pdf.height = 8, + pdf.width = 8, + pdf.height = 8, + hm_parcoord.matrix, add.watermark = watermark ) diff --git a/components/board.clustering/R/clustering_plot_hm_splitmap.R b/components/board.clustering/R/clustering_plot_hm_splitmap.R index aa34ddd22..77d5318f2 100644 --- a/components/board.clustering/R/clustering_plot_hm_splitmap.R +++ b/components/board.clustering/R/clustering_plot_hm_splitmap.R @@ -82,7 +82,7 @@ clustering_plot_hm_splitmap_ui <- function(id, plotlib = "plotly", info.text = info_text, options = hm_splitmap_opts, - download.fmt = c("png", "pdf", "csv"), + download.fmt = c("png", "pdf"), width = width, height = height ) @@ -161,8 +161,6 @@ clustering_plot_hm_splitmap_server <- function(id, zx.idx = pd[["zx.idx"]] filt = pd[["filt"]] - - if(nrow(zx) <= 1) return(NULL) show_rownames = TRUE @@ -308,6 +306,7 @@ clustering_plot_hm_splitmap_server <- function(id, "pltmod", plotlib = "plotly", func = hm2_splitmap.RENDER, + # csvFunc = res = c(80, 95), ## resolution of plots pdf.width = 10, pdf.height = 8, add.watermark = watermark