diff --git a/DESCRIPTION b/DESCRIPTION index bd02981..1a86b62 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -7,7 +7,7 @@ Authors@R: person(given = "Laurent", family = "Gatto", email = "laurent.gatto@uclouvain.be", comment = c(ORCID = "0000-0002-1520-2268"), role = c("ctb")), person("e-OMIX", role = c("fnd"))) Description: "QFeaturesGUI is a suite of shiny apps that serve as graphical interfaces for the QFeatures package. Currently, the package contains the following shiny apps: 'importQFeatures'." -biocViews: Software, ShinyApps, GUI, Proteomics, SingleCell, DataImport, PreProcessing +biocViews: Software, ShinyApps, GUI, Proteomics, SingleCell, DataImport, Preprocessing URL: https://rformassspectrometry.github.io/QFeaturesGUI/, https://github.com/rformassspectrometry/QFeaturesGUI BugReports: https://github.com/rformassspectrometry/QFeaturesGUI/issues License: MIT + file LICENSE @@ -24,7 +24,6 @@ Imports: utils, htmltools, impute, - pcaMethods, plotly, MultiAssayExperiment, RColorBrewer, @@ -41,9 +40,10 @@ Imports: dplyr, matrixStats, MsCoreUtils, - waiter + waiter, + nipals Depends: - R (>= 4.3.0) + R (>= 4.5.0) Suggests: knitr, BiocStyle, diff --git a/NAMESPACE b/NAMESPACE index 038e420..6682e36 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -55,8 +55,7 @@ importFrom(htmltools,tags) importFrom(matrixStats,colMedians) importFrom(methods,as) importFrom(methods,is) -importFrom(pcaMethods,pca) -importFrom(pcaMethods,scores) +importFrom(nipals,nipals) importFrom(plotly,"%>%") importFrom(plotly,add_annotations) importFrom(plotly,add_histogram) diff --git a/R/interface_module_qc_metrics.R b/R/interface_module_qc_metrics.R index c49e510..c38acea 100644 --- a/R/interface_module_qc_metrics.R +++ b/R/interface_module_qc_metrics.R @@ -30,14 +30,23 @@ interface_module_qc_metrics <- function(id, type) { choices = NULL, label = "Select the set for dimension reduction" ), - selectInput( - inputId = NS(id, "selected_method"), - choices = c("nipals", "ppca", "svdImpute"), - label = bs3Tooltip( - trigger = "Select Dimension Reduction Method", - tooltipText = "For more information on the methods, see online documentation." - ) + column(width = 6, + selectInput( + inputId = NS(id,"x_axis"), + label = "Component on X axis", + choices = c("PC1", "PC2", "PC3", "PC4", "PC5", "PC6"), + selected = "PC1" + ), + ), + column(width = 6, + selectInput( + inputId = NS(id,"y_axis"), + label = "Component on Y axis", + choices = c("PC1", "PC2", "PC3", "PC4", "PC5", "PC6"), + selected = "PC2" + ), ), + selectInput( inputId = NS(id, "pca_color"), label = "Color by", @@ -67,7 +76,7 @@ interface_module_qc_metrics <- function(id, type) { ) ), box( - title = "Dimension Reduction", + title = "Dimension Reduction (Nipals)", status = "primary", width = 8, solidHeader = FALSE, diff --git a/R/server_module_qc_metrics.R b/R/server_module_qc_metrics.R index 8d38a17..5748246 100644 --- a/R/server_module_qc_metrics.R +++ b/R/server_module_qc_metrics.R @@ -61,13 +61,14 @@ server_module_qc_metrics <- function(id, assays_to_process) { server_module_pca_box( id = "features", single_assay = single_assay, - method = reactive(input$selected_method), pca_type = reactive(input$assay_type), scale = reactive(input$scale), center = reactive(input$center), color = reactive(input$pca_color), show_legend = reactive(input$show_legend), - color_width = reactive(input$color_width) + color_width = reactive(input$color_width), + x_component = reactive(input$x_axis), + y_component = reactive(input$y_axis) ) server_module_viz_box("viz_box", assays_to_process) @@ -78,14 +79,14 @@ server_module_qc_metrics <- function(id, assays_to_process) { #' #' @param id module id #' @param single_assay a reactiveVal that contains the selected assay -#' @param method a character string specifying the PCA method to use -#' valid values are c("nipals", "ppca", "svdImpute") #' @param pca_type sample or features #' @param scale a boolean that specifies if the data should be scaled #' @param center a boolen that specifies if the data should be centered #' @param show_legend a boolean that specifies if the legend should be shown #' @param color which metadata use for color #' @param color_width how many letter display in the legend +#' @param x_component the principal component to display on x axis +#' @param y_component the principal component to display on y axis #' #' @return A shiny module server function that contains the PCA logic #' @rdname INTERNAL_server_module_pca_box @@ -94,19 +95,18 @@ server_module_qc_metrics <- function(id, assays_to_process) { #' @importFrom shiny moduleServer observe req reactive updateSelectInput #' @importFrom plotly plot_ly renderPlotly layout %>% #' @importFrom SummarizedExperiment colData rowData -#' @importFrom pcaMethods pca scores #' @importFrom methods is #' -server_module_pca_box <- function(id, single_assay, method, pca_type, scale, center, show_legend, color, color_width) { +server_module_pca_box <- function(id, single_assay, pca_type, scale, center, show_legend, color, color_width, x_component, y_component) { moduleServer(id, function(input, output, session) { - stopifnot(is.reactive(method)) stopifnot(is.reactive(pca_type)) stopifnot(is.reactive(scale)) stopifnot(is.reactive(center)) stopifnot(is.reactive(show_legend)) stopifnot(is.reactive(color)) stopifnot(is.reactive(color_width)) - + stopifnot(is.reactive(x_component)) + stopifnot(is.reactive(y_component)) color_data <- reactive({ req(single_assay()) @@ -135,12 +135,13 @@ server_module_pca_box <- function(id, single_assay, method, pca_type, scale, cen req(single_assay()) req(!is_empty_set(single_assay())) req(ncol(single_assay()) > 0L) - pcaMethods_wrapper( - single_assay(), - method = method(), - transpose = pca_type() == "samples", - scale = scale(), - center = center() + error_handler( + nipalsWrapper, + "QC Nipals", + sce = single_assay(), + transpose = pca_type() == "samples", + scale = scale(), + center = center() ) }) dataframe <- reactive({ @@ -150,11 +151,11 @@ server_module_pca_box <- function(id, single_assay, method, pca_type, scale, cen req(pca_result()) if (color() == "NULL") { as.data.frame( - data.frame(scores(pca_result())) + data.frame(pca_result()$scores) ) } else { req(color_data()) - scores_df <- as.data.frame(data.frame(scores(pca_result()))) + scores_df <- as.data.frame(data.frame(pca_result()$scores)) scores_df$.qfeaturesgui_row_id <- rownames(scores_df) color_df <- as.data.frame(color_data()) color_df$.qfeaturesgui_row_id <- rownames(color_df) @@ -209,7 +210,9 @@ server_module_pca_box <- function(id, single_assay, method, pca_type, scale, cen df = dataframe(), pca_result = pca_result(), color_name = color(), - show_legend = show_legend() + show_legend = show_legend(), + x_component = x_component(), + y_component = y_component() ) }) }) diff --git a/R/utils_processQFeatures.R b/R/utils_processQFeatures.R index 02b6477..1831a23 100644 --- a/R/utils_processQFeatures.R +++ b/R/utils_processQFeatures.R @@ -394,37 +394,37 @@ invalidate_steps_from <- function(step_number) { # QC metrics and PCA helpers ---- -#' PCA Methods Wrapper +#' Nipals Wrapper #' -#' This function performs Principal Component Analysis (PCA) on a SingleCellExperiment object using the specified method. +#' This function performs Principal Component Analysis (PCA) on a SingleCellExperiment object using nipals. #' #' @param sce A SingleCellExperiment object. The PCA is performed on the assay of this object. -#' @param method A character string specifying the PCA method to use. This should be one of the methods supported by the pcaMethods package. #' @param center A logical indicating whether the variables should be centered before PCA. #' @param scale A logical indicating whether the variables should be scaled before PCA. #' @param transpose A logical indicating whether the assay matrix should be transposed before PCA. #' -#' @return A pcaRes object resulting from the PCA. -#' @rdname INTERNAL_pcaMethods_wrapper +#' @return A list with components eig, scores, loadings, fitted, ncomp, R2, iter, center, scale +#' @rdname INTERNAL_nipalsWrapper #' @keywords internal #' -#' @importFrom pcaMethods pca +#' @importFrom nipals nipals #' @importFrom SummarizedExperiment assay #' -pcaMethods_wrapper <- function(sce, method, center, scale, transpose = FALSE) { +nipalsWrapper <- function(sce, center, scale, transpose = FALSE) { mat <- assay(sce) - mat <- mat[rowSums(is.na(mat)) != ncol(mat), ] - mat <- mat[, colSums(is.na(mat)) < nrow(mat)] - if (scale) { - mat <- base::scale(mat, center = center, scale = TRUE) - center <- FALSE + dimMat <- dim(mat) + mat <- mat[rowSums(is.finite(mat)) > 2, colSums(is.finite(mat)) > 2] + if (!identical(dim(mat), dimMat)){ + warning("Some variable(s) with less than 3 observations were removed") } + if (transpose) { mat <- t(mat) } - pca <- pcaMethods::pca(mat, - method = method, - center = center + pca <- nipals::nipals(mat, + center = center, + ncomp = 6, + scale = scale ) pca } @@ -434,6 +434,8 @@ pcaMethods_wrapper <- function(sce, method, center, scale, transpose = FALSE) { #' @param df a data.frame that contains the PCA results and the color column #' @param color_name a character string that contains the name of the color column #' @param pca_result a pcaRes object that contains the PCA results +#' @param x_component a principal component to show on x axis +#' @param y_component a principal component to show on y axis #' #' @return a plotly object #' @rdname INTERNAL_pca_plotly @@ -444,7 +446,7 @@ pcaMethods_wrapper <- function(sce, method, center, scale, transpose = FALSE) { #' @importFrom stats as.formula #' @importFrom viridisLite viridis #' -pca_plotly <- function(df, pca_result, color_name, show_legend) { +pca_plotly <- function(df, pca_result, color_name, show_legend, x_component, y_component) { stopifnot(is.data.frame(df)) if (color_name == "NULL") { colorFormula <- NULL @@ -477,8 +479,8 @@ pca_plotly <- function(df, pca_result, color_name, show_legend) { } plotly_args <- list( data = df, - x = ~PC1, - y = ~PC2, + x = df[[x_component]], + y = df[[y_component]], text = text, type = "scatter", mode = "markers", @@ -495,13 +497,13 @@ pca_plotly <- function(df, pca_result, color_name, show_legend) { plotly <- do.call(plot_ly, plotly_args) %>% layout( xaxis = list(title = paste( - "PC1", - round(pca_result@R2[1] * 100, 2), + x_component, + round(pca_result$R2[as.integer(strsplit(x_component,"PC")[[1]][2])] * 100, 2), "% of the variance" )), yaxis = list(title = paste( - "PC2", - round(pca_result@R2[2] * 100, 2), + y_component, + round(pca_result$R2[as.integer(strsplit(y_component,"PC")[[1]][2])] * 100, 2), "% of the variance" )), showlegend = show_legend, diff --git a/man/inputTable.Rd b/man/inputTable.Rd index 41945c5..736fb51 100644 --- a/man/inputTable.Rd +++ b/man/inputTable.Rd @@ -169,6 +169,6 @@ with a blank run. The data is stored as a \code{data.frame}. } \seealso{ \code{readSCP()} from the \code{scp} package for an example on how \code{mqScpData} is -parsed into a \link[QFeatures:QFeatures]{QFeatures} object. +parsed into a \link[QFeatures:QFeatures-class]{QFeatures::QFeatures} object. } \keyword{datasets} diff --git a/tests/testthat/test-utils-processQFeatures.R b/tests/testthat/test-utils-processQFeatures.R index f5bf2b6..2f97dca 100644 --- a/tests/testthat/test-utils-processQFeatures.R +++ b/tests/testthat/test-utils-processQFeatures.R @@ -209,9 +209,8 @@ test_that("imputation method metadata is internally consistent", { }) test_that("pca_plotly handles no color and many categorical levels", { - pca_result <- pcaMethods::pca( + pca_result <- nipals::nipals( matrix(seq_len(48), nrow = 12), - method = "svd", center = TRUE ) pca_df <- data.frame( @@ -224,7 +223,9 @@ test_that("pca_plotly handles no color and many categorical levels", { pca_df, pca_result = pca_result, color_name = "NULL", - show_legend = TRUE + show_legend = TRUE, + x_component = "PC1", + y_component = "PC2" ) expect_s3_class(no_color_plot, "plotly") expect_null(no_color_plot$x$attrs[[1]]$customdata) @@ -237,7 +238,9 @@ test_that("pca_plotly handles no color and many categorical levels", { pca_df, pca_result = pca_result, color_name = "group", - show_legend = TRUE + show_legend = TRUE, + x_component = "PC1", + y_component = "PC2" ) expect_s3_class(many_groups_plot, "plotly") expect_error(plotly::plotly_build(many_groups_plot), NA)