Use nipals instead of pcaMethods

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,

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)

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,

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()
             )
         })
     })

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,

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)