Merge pull request #1578 from bigomics/devel

Devel

Author: ESCRI11

components/app/R/global.R

@@ -184,7 +184,8 @@ opt.default <- list(
   APACHE_COOKIE_PATH = OPG,
   ALLOW_CUSTOM_FC = FALSE,
   DEVMODE = FALSE,
-  ENABLE_MULTIOMICS = TRUE
+  ENABLE_MULTIOMICS = TRUE,
+  ENABLE_COOKIE_LOGIN = TRUE
 )
 
 opt.file <- file.path(ETC, "OPTIONS")

components/board.clustering/R/clustering_plot_clusterpca.R

@@ -3,10 +3,6 @@
 ## Copyright (c) 2018-2023 BigOmics Analytics SA. All rights reserved.
 ##
 
-
-
-## Annotate clusters ############
-
 clustering_plot_clustpca_ui <- function(
     id,
     label = "",
@@ -78,7 +74,6 @@ clustering_plot_clustpca_server <- function(id,
   moduleServer(id, function(input, output, session) {
     ns <- session$ns
 
-    ## Plot ############
     plot_data <- shiny::reactive({
       samples <- selected_samples()
       cluster.pos <- pgx$cluster$pos
@@ -87,15 +82,12 @@ clustering_plot_clustpca_server <- function(id,
       }
       all.pos <- do.call(cbind, cluster.pos)
       all.pos <- all.pos[samples, ]
-      pd <- list(
-        pos = all.pos
-      )
-
+      pd <- list(pos = all.pos)
       return(pd)
     })
 
 
-    create_plot <- function(pgx, pos, method, colvar, shapevar, label, cex) {
+    create_plot <- function(pgx, pos, pca2d.varexp, method, colvar, shapevar, label, cex) {
       do3d <- (ncol(pos) == 3)
       sel <- rownames(pos)
       df <- cbind(pos, pgx$samples[sel, , drop = FALSE])
@@ -114,9 +106,7 @@ clustering_plot_clustpca_server <- function(id,
       label.samples <- (label == "sample")
 
       if (!do3d && label.samples) ann.text <- rownames(df)
-      if (!is.null(colvar)) {
-        textvar <- factor(colvar)
-      }
+      if (!is.null(colvar)) textvar <- factor(colvar)
 
       symbols <- c(
         "circle", "square", "star", "triangle-up", "triangle-down", "pentagon",
@@ -130,10 +120,8 @@ clustering_plot_clustpca_server <- function(id,
       cex1 <- c(1.0, 0.8, 0.6)[1 + 1 * (nrow(pos) > 30) + 1 * (nrow(pos) > 200)]
       clrs.length <- length(unique(colvar))
       clrs <- rep(omics_pal_d(palette = "muted_light")(8), ceiling(clrs.length / 8))[1:clrs.length]
-      ## clrs <- clrs[colvar]
-
+      
       if (do3d) {
-        ## 3D plot
         plt <- plotly::plot_ly(df, mode = "markers") %>%
           plotly::add_markers(
             x = df[, 1],
@@ -174,7 +162,7 @@ clustering_plot_clustpca_server <- function(id,
             plotly::layout(showlegend = FALSE)
         }
       } else {
-        ## 2D plot
+
         plt <- plotly::plot_ly(
           df,
           mode = "markers",
@@ -184,7 +172,7 @@ clustering_plot_clustpca_server <- function(id,
             x = df[, 1],
             y = df[, 2],
             type = "scattergl",
-            color = colvar, ## size = sizevar, sizes=c(80,140),
+            color = colvar,
             colors = clrs,
             marker = list(
               size = 16 * cex1 * cex,
@@ -198,13 +186,20 @@ clustering_plot_clustpca_server <- function(id,
             x = pos[, 1],
             y = pos[, 2],
             text = ann.text,
-            ## xref = "x", yref = "y",
             showarrow = FALSE
-          ) %>% # add x axis title
-          plotly::layout(
+          )
+
+        if (method == "pca") {
+          plt <- plt %>% plotly::layout(
+            xaxis = list(title = paste0(toupper(method), "1 (", pca2d.varexp[1], "%)")),
+            yaxis = list(title = paste0(toupper(method), "2 (", pca2d.varexp[2], "%)"))
+          )
+        } else {
+          plt <- plt %>% plotly::layout(
             xaxis = list(title = paste0(toupper(method), "1")),
             yaxis = list(title = paste0(toupper(method), "2"))
           )
+        }
 
         ## add group/cluster annotation labels
         if (label == "inside") {
@@ -269,10 +264,11 @@ clustering_plot_clustpca_server <- function(id,
         if (do3d) m1 <- paste0(m, "3d")
         pos <- pgx$cluster$pos[[m1]]
         pos <- pos[samples, ]
-
+        pca2d.varexp <- pgx$cluster$pos$pca2d.varexp
         plist[[i]] <- create_plot(
           pgx = pgx,
           pos = pos,
+          pca2d.varexp = pca2d.varexp,
           method = m,
           colvar = colvar,
           shapevar = shapevar,
@@ -290,11 +286,7 @@ clustering_plot_clustpca_server <- function(id,
       } else {
         plist <- create_plotlist()
         nc <- ceiling(sqrt(length(plist)))
-        plotly::subplot(
-          plist,
-          nrows = nc,
-          margin = 0.04
-        )
+        plotly::subplot(plist, nrows = nc, margin = 0.04)
       }
     })
 

components/board.clustering/R/clustering_ui.R

@@ -239,7 +239,7 @@ ClusteringUI <- function(id) {
             clustering_plot_clustpca_ui(
               ns("PCAplot"),
               title = "Dimensionality reduction",
-              info.text = "Using the {Color/label}, {Shape} and {Label} options it is possible to control how the points are colored and shaped (acording to which available phenotypes) and it is possible to control where are the labels located respectively. There is also the option to visualize the three dimensionality reduction techniques at the same time, and the option to visualize the plot in three dimensions.",
+              info.text = "Using the {Color/label}, {Shape} and {Label} options it is possible to control how the points are colored and shaped (acording to which available phenotypes) and it is possible to control where are the labels located respectively. There is also the option to visualize the three dimensionality reduction techniques at the same time, and the option to visualize the plot in three dimensions. For 2-dimensional principal component analysis, the percentage of variance explained by the first two principal components is reported in the x- and y-axis.",
               info.methods = "Relationship (or similarity) between the samples for visual analytics, where similarity is visualized as proximity of the points. Three clustering methods are available, t-SNE (using the Rtsne R package [1]), UMAP (using the uwot R package [2]) and PCA (using the irlba R package [3]). Samples that are ‘similar’ will be placed close to each other.",
               info.references = list(
                 list(

components/board.signature/R/signature_server.R

@@ -267,6 +267,7 @@ SignatureBoard <- function(id, pgx,
         shiny::withProgress(message = "Computing GSEA ...", value = 0.8, {
           res <- lapply(1:ncol(F), function(i) {
             set.seed(123)
+            shiny::validate(shiny::need(any(gmt$gset %in% names(F[, i])), "Signature features not found in the dataset."))
             suppressWarnings(suppressMessages(
               res <- fgsea::fgsea(gmt, stats = F[, i], nperm = 1000, nproc = 1)
             ))
@@ -278,6 +279,7 @@ SignatureBoard <- function(id, pgx,
         res1 <- data.frame(do.call(rbind, res))
         res1$ES <- NULL
       } else {
+        shiny::validate(shiny::need(any(gmt$gset %in% rownames(F)), "Signature features not found in the dataset."))
         i <- 1
         fx <- 1 * (rownames(F) %in% gmt[[1]])
         rho <- cor(apply(F, 2, rank, na.last = "keep"), fx, use = "pairwise")[, 1]

components/board.upload/R/upload_module_computepgx.R

@@ -466,14 +466,10 @@ upload_module_computepgx_server <- function(
             }
 
             if (length(ia.ctx) | length(ia.spline.ctx)) {
-              shinyalert::shinyalert(
-                title = "Interaction analysis",
-                text = paste0(
-                  "'", colnames(Y)[sel.time[1]], "' found in samples.csv.\n",
-                  "Interaction with time will be tested for valid contrasts."
-                ),
-                type = "info"
-              )
+              # shinyalert::shinyalert(title = "Interaction analysis",
+              #   text = paste0("'", colnames(Y)[sel.time[1]], "' found in samples.csv.\n",
+              #     "Interaction with time will be tested for valid contrasts."),
+              #   type = "info")
 
               if (length(ia.ctx)) {
                 ia.ctx <- gsub(":.*", "", ia.ctx)

components/board.upload/R/upload_module_normalization.R

@@ -221,7 +221,8 @@ upload_module_normalization_server <- function(
           value = 0.3,
           {
             res <- playbase::compare_batchcorrection_methods(
-              X1, samples,
+              X1,
+              samples,
               pheno = NULL,
               contrasts = contrasts,
               batch.pars = batch.pars,
@@ -256,12 +257,13 @@ upload_module_normalization_server <- function(
           ## standard dim reduction methods
           pos <- list()
           set.seed(1234)
-          pos[["pca"]] <- irlba::irlba(scaledX, nu = 2, nv = 0)$u
+          pca <- irlba::irlba(scaledX, nu = 2, nv = 0)
+          pos[["pca"]] <- pca$u
           for (i in 1:length(pos)) {
             rownames(pos[[i]]) <- rownames(scaledX)
             colnames(pos[[i]]) <- paste0(names(pos)[i], "_", 1:2)
           }
-
+          pos[["pca.varexp"]] <- (pca$d^2 / sum(pca$d^2)) * 100
           out$pos <- pos
           out$corX <- corX
           out
@@ -460,6 +462,67 @@ upload_module_normalization_server <- function(
               text(0.5, 0.5, "no missing values")
             }
           }
+
+          if (input$missing_plottype == "missingness across features") {
+            if (any(X2 > 0)) {
+              par(mfrow = c(1,1), mar = c(2, 3.5, 2, 2), mgp = c(2.5, 0.75, 0))
+              X3 <- imputedX()$X
+              pct.na <- round(rowMeans(is.na(X3))*100)
+              hh <- hist(pct.na, xlim = c(0, 100), col = "grey", main = "",
+                las = 1, tcl = -0.1, mgp = c(2.5, 0.5, 0), yaxs="i",
+                xlab = "Missingness across features (%)", ylab = "Number of features")
+              abline(v = mean(pct.na), col = "red")
+              abline(v = median(pct.na), col = "blue")
+              xpos <- 90
+              ypos <- max(hh$counts) * 0.95
+              lab1 <- paste0("Mean: ", round(mean(pct.na)), "%")
+              lab2 <- paste0("Median: ", round(median(pct.na)), "%")
+              text(xpos, ypos, labels = lab1, col = "red")
+              text(xpos, ypos-(ypos*8/100), labels = lab2, col = "blue")
+              title("Distribution of missing values across features"); grid()
+              rm(X3)
+            }
+            else {
+              plot.new()
+              text(0.5, 0.5, "no missing values")
+            }
+          }
+          
+          if (input$missing_plottype == "PCA of imputed data") {
+            if (any(X2 > 0)) {
+              X3 <- imputedX()$X
+              if (input$impute) X3 <- log2(imputedX()$counts + imputedX()$prior)
+              mm <- c("SVD2", "QRILC", "MinProb", "Perseus")
+              imp <- list()
+              for(i in 1:length(mm)) imp[[mm[i]]] <- playbase::imputeMissing(X3, mm[i])
+              scaled.imp <- lapply(imp, function(x) playbase::double_center_scale_fast(x))
+              par(mfrow = c(2, 2), mar = c(4, 3, 2, 0.5), las = 1, mgp = c(2, 0.4, 0), tcl = -0.1)
+              cex1 <- cut(ncol(X3),
+                breaks = c(0, 40, 100, 250, 1000, 999999),
+                c(1, 0.85, 0.7, 0.55, 0.4))
+              cex1 <- 2.7 * as.numeric(as.character(cex1))
+              for(i in 1:length(scaled.imp)) {
+                set.seed(1234);
+                pca <- irlba::irlba(scaled.imp[[i]], nu = 2, nv = 0)
+                pca.pos <- pca$u
+                pca.var <- (pca$d^2 / sum(pca$d^2)) * 100
+                plot(pca.pos[,1], pca.pos[,2], col = "black", pch = 20,
+                  cex = cex1, cex.lab = 1, main = names(scaled.imp)[i],
+                  xlab = paste0("PC1 (", round(pca.var[1],2), "%)"),
+                  ylab = paste0("PC2 (", round(pca.var[2],2), "%)"),
+                  asp = 1
+                )
+                grid()
+                rm(pca, pca.pos, pca.var); gc()
+              }
+              rm(X3, imp, scaled.imp)
+            }
+            else {
+              plot.new()
+              text(0.5, 0.5, "no missing values")
+            }
+          }
+          
         }
       }
 
@@ -537,34 +600,34 @@ upload_module_normalization_server <- function(
       }
 
       plot_all_methods <- function() {
-        res <- results_correction_methods()
         out.res <- results_outlier_methods()
+        res <- results_correction_methods()
         shiny::req(res)
         shiny::req(out.res)
         samples <- r_samples()
 
         methods <- c("uncorrected", sort(c("ComBat", "limma", "RUV", "SVA", "NPM")))
+
         pos.list <- res$pos
-        ## get same positions as after outlier detection
         pos0 <- out.res$pos[["pca"]]
+        
         pos.list <- c(list("uncorrected" = pos0), pos.list)
 
         colorby_var <- input$colorby_var
         colorby_var <- intersect(colorby_var, colnames(samples))
-        col1 <- factor(samples[, colorby_var]) ## as.numeric(col1)
+        col1 <- factor(samples[, colorby_var])
 
         pheno <- res$pheno
         xdim <- length(pheno)
-        ## col1 <- factor(pheno)
         cex1 <- cut(xdim,
           breaks = c(0, 40, 100, 250, 1000, 999999),
           c(1, 0.85, 0.7, 0.55, 0.4)
         )
         cex1 <- 2.5 * as.numeric(as.character(cex1))
-        par(mfrow = c(2, 3), mar = c(2, 2, 2, 1))
+        par(mfrow = c(2, 3), mar = c(3, 3, 2, 1), mgp = c(1.7, 0.4, 0), tcl = -0.1)
         for (m in methods) {
           if (m %in% names(pos.list)) {
-            plot(pos.list[[m]], col = col1, cex = cex1, pch = 20)
+            plot(pos.list[[m]], col = col1, cex = cex1, pch = 20, las = 1) 
           } else {
             plot.new()
             text(0.45, 0.5, "method failed")
@@ -578,9 +641,9 @@ upload_module_normalization_server <- function(
         res <- results_correction_methods()
         samples <- r_samples()
 
-        ## get same positions as after outlier detection
-        ## pos0 <- res$pos[["normalized"]]
         pos0 <- out.res$pos[["pca"]]
+        pos0.varexp <- out.res$pos[["pca.varexp"]]
+        pos1.varexp <- res[["pca.varexp"]]
         method <- input$bec_method
 
         if (!method %in% names(res$pos)) {
@@ -596,12 +659,11 @@ upload_module_normalization_server <- function(
         }
 
         kk <- intersect(rownames(pos0), rownames(pos1))
-        pos0 <- pos0[kk, ]
-        pos1 <- pos1[kk, ]
+        pos0 <- pos0[kk, , drop = FALSE]
+        pos1 <- pos1[kk, , drop = FALSE]
 
         pheno <- playbase::contrasts2pheno(r_contrasts(), r_samples())
         pheno <- pheno[rownames(pos0)]
-        # col1 <- factor(pheno)
         colorby_var <- input$colorby_var
         colorby_var <- intersect(colorby_var, colnames(samples))
         samples <- samples[rownames(pos0), , drop = FALSE]
@@ -611,14 +673,18 @@ upload_module_normalization_server <- function(
           c(1, 0.85, 0.7, 0.55, 0.4)
         )
         cex1 <- 2.7 * as.numeric(as.character(cex1))
-        par(mfrow = c(1, 2), mar = c(3.2, 3, 2, 0.5), mgp = c(2.1, 0.8, 0))
+        par(mfrow = c(1, 2), mar = c(3.2, 3, 2, 0.5), mgp = c(2.1, 0.4, 0), tcl = -0.1)
         plot(pos0,
-          col = col1, pch = 20, cex = 1.0 * cex1, las = 1,
-          main = "uncorrected", xlab = "PC1", ylab = "PC2"
+          col = col1, pch = 20, cex = cex1, las = 1,
+          main = "uncorrected",
+          xlab = paste0("PC1 (", round(pos0.varexp[1],2), "%)"),
+          ylab = paste0("PC2 (", round(pos0.varexp[2],2), "%)")
         )
         plot(pos1,
-          col = col1, pch = 20, cex = 1.0 * cex1, las = 1,
-          main = method, xlab = "PC1", ylab = "PC2"
+          col = col1, pch = 20, cex = cex1, las = 1,
+          main = method,
+          xlab = paste0("PC1 (", round(pos1.varexp[[method]][1],2), "%)"),
+          ylab = paste0("PC2 (", round(pos1.varexp[[method]][2],2), "%)")
         )
       }
 
@@ -669,7 +735,7 @@ upload_module_normalization_server <- function(
           "Outliers markedly deviate from the vast majority of samples. Outliers could be caused by technical factors and negatively affect data analysis. Here, outliers are identified and marked for removal should you wish so."
 
         missing.infotext <-
-          "Missing values (MVs) reduce the completeness of biological data and hinder preprocessing steps. MVs (i.e., NA), more often populate proteomics and metabolomics data. Here, MVs are identified and their patterns in your data is shown."
+          "Missing values (MVs) reduce the completeness of biological data and hinder preprocessing steps. MVs (i.e., NA), more often populate proteomics and metabolomics data. Here, MVs are identified and their patterns in your data is shown. PCA is also optionally performed on data imputed with all methods to aid comparison."
 
         normalization.infotext <-
           "Normalization enables to standardize the data and improve their consistency, comparability and reproducibility. Boxplots of raw (unnormalized) and normalized data are shown. Normalization method can be selected on the left, under “Normalization”."
@@ -678,12 +744,10 @@ upload_module_normalization_server <- function(
           "Batch effects (BEs) are due to technical, experimental factors that introduce unwanted variation into the measurements. Here, BEs are detected and BEs correction is shown. BE correction methods can be selected on the left, under “Batch-effects correction”."
 
         missing.options <- tagList(
-          shiny::radioButtons(ns("missing_plottype"),
-            "Plot type:",
-            c("heatmap", "ratio plot", "missingness per sample"),
-            selected = "heatmap",
-            inline = TRUE
-          ),
+          shiny::radioButtons(ns("missing_plottype"), "Plot type:",
+            c("heatmap", "ratio plot", "missingness per sample",
+              "missingness across features", "PCA of imputed data"),
+            selected = "heatmap", inline = TRUE),
         )
 
         norm.options <- tagList(