Shinytest

.Rbuildignore

@@ -9,3 +9,4 @@
 ^doc$
 ^Meta$
 ^\.lintr$
+_\.new\.png$

.gitignore

@@ -12,3 +12,5 @@ docs
 /Meta/
 TODO
 .vscode/settings.json
+# {shinytest2}: Ignore new debug snapshots for `$expect_values()`
+*_.new.png

DESCRIPTION

@@ -46,7 +46,8 @@ Depends:
 Suggests: 
     knitr,
     BiocStyle,
-    testthat (>= 3.0.0)
+    testthat (>= 3.0.0),
+    shinytest2
 Roxygen: list(markdown = TRUE)
 VignetteBuilder: knitr
 Config/testthat/edition: 3

R/build_process_server.R

@@ -152,84 +152,93 @@ build_process_server <- function(qfeatures, initial_sets, initial_steps, has_qfe
             ))
         }
 
-        shiny::observeEvent(input$startup_qfeatures_rds, {
-            uploaded_qfeatures(NULL)
-            upload_message(NULL)
-            startup_reading(TRUE)
-            datapath <- input$startup_qfeatures_rds$datapath
+        shiny::observeEvent(input$startup_qfeatures_rds,
+            {
+                uploaded_qfeatures(NULL)
+                upload_message(NULL)
+                startup_reading(TRUE)
+                datapath <- input$startup_qfeatures_rds$datapath
 
-            session$onFlushed(function() {
-                uploaded <- tryCatch(
-                    check_qfeatures(datapath),
-                    error = function(e) e
-                )
-                startup_reading(FALSE)
-                if (inherits(uploaded, "error")) {
-                    upload_message(paste(
-                        "Could not load QFeatures object:",
-                        conditionMessage(uploaded)
-                    ))
+                session$onFlushed(function() {
+                    uploaded <- tryCatch(
+                        check_qfeatures(datapath),
+                        error = function(e) e
+                    )
+                    startup_reading(FALSE)
+                    if (inherits(uploaded, "error")) {
+                        upload_message(paste(
+                            "Could not load QFeatures object:",
+                            conditionMessage(uploaded)
+                        ))
+                        return(invisible(NULL))
+                    }
+
+                    uploaded_qfeatures(uploaded)
+                }, once = TRUE)
+            },
+            ignoreInit = TRUE
+        )
+
+        shiny::observeEvent(input$startup_load_qfeatures,
+            {
+                uploaded <- uploaded_qfeatures()
+                if (is.null(uploaded)) {
+                    upload_message(
+                        "Upload a valid .rds file containing a QFeatures object."
+                    )
                     return(invisible(NULL))
                 }
 
-                uploaded_qfeatures(uploaded)
-            }, once = TRUE)
-        }, ignoreInit = TRUE)
-
-        shiny::observeEvent(input$startup_load_qfeatures, {
-            uploaded <- uploaded_qfeatures()
-            if (is.null(uploaded)) {
-                upload_message(
-                    "Upload a valid .rds file containing a QFeatures object."
+                selected_sets <- input$startup_initial_sets
+                initial_idx <- tryCatch(
+                    normalise_initial_sets(uploaded, selected_sets),
+                    error = function(e) e
                 )
-                return(invisible(NULL))
-            }
-
-            selected_sets <- input$startup_initial_sets
-            initial_idx <- tryCatch(
-                normalise_initial_sets(uploaded, selected_sets),
-                error = function(e) e
-            )
-            if (inherits(initial_idx, "error")) {
-                upload_message(conditionMessage(initial_idx))
-                return(invisible(NULL))
-            }
+                if (inherits(initial_idx, "error")) {
+                    upload_message(conditionMessage(initial_idx))
+                    return(invisible(NULL))
+                }
 
-            workflow_steps <- input[["workflow_config-workflow_list"]]
-            if (is.null(workflow_steps)) {
-                workflow_steps <- initial_steps
-            }
+                workflow_steps <- input[["workflow_config-workflow_list"]]
+                if (is.null(workflow_steps)) {
+                    workflow_steps <- initial_steps
+                }
 
-            .qf$qfeatures <- format_qfeatures(uploaded, initial_idx)
-            global_rv$workflow_config <- workflow_steps
-            global_rv$code_lines <- list()
-            shiny::removeModal()
+                .qf$qfeatures <- format_qfeatures(uploaded, initial_idx)
+                global_rv$workflow_config <- workflow_steps
+                global_rv$code_lines <- list()
+                shiny::removeModal()
 
-            n_sets <- length(initial_idx)
-            n_steps <- length(workflow_steps)
-            shinyalert(
-                title = "QFeatures loaded",
-                text = paste0(
-                    "Loaded QFeatures with ", n_sets,
-                    " initial set", if (n_sets != 1) "s" else "", ".",
-                    if (n_steps > 0) {
-                        paste0(
-                            "\nWorkflow pre-configured with ", n_steps,
-                            " step", if (n_steps != 1) "s" else "", "."
-                        )
-                    } else {
-                        ""
-                    }
-                ),
-                closeOnClickOutside = TRUE,
-                type = "success",
-                confirmButtonCol = "#3c8dbc"
-            )
-        }, ignoreInit = TRUE)
+                n_sets <- length(initial_idx)
+                n_steps <- length(workflow_steps)
+                shinyalert(
+                    title = "QFeatures loaded",
+                    text = paste0(
+                        "Loaded QFeatures with ", n_sets,
+                        " initial set", if (n_sets != 1) "s" else "", ".",
+                        if (n_steps > 0) {
+                            paste0(
+                                "\nWorkflow pre-configured with ", n_steps,
+                                " step", if (n_steps != 1) "s" else "", "."
+                            )
+                        } else {
+                            ""
+                        }
+                    ),
+                    closeOnClickOutside = TRUE,
+                    type = "success",
+                    confirmButtonCol = "#3c8dbc"
+                )
+            },
+            ignoreInit = TRUE
+        )
 
-        shiny::observeEvent(input$startup_show_upload, {
-            show_startup_upload_modal()
-        }, ignoreInit = TRUE)
+        shiny::observeEvent(input$startup_show_upload,
+            {
+                show_startup_upload_modal()
+            },
+            ignoreInit = TRUE
+        )
 
         if (!has_qfeatures) {
             session$onFlushed(function() {

R/code_generator_importQFeatures.R

@@ -56,6 +56,7 @@ code_generator_read_qfeatures <- function(input_table, sample_table, qfeatures,
     if (singlcelldata) {
         codeLines <- c(codeLines, "\nqfeatures <- setQFeaturesType(\n\tqfeatures,\n\ttype = 'scp'\n)")
     }
+    codeLines <- c(codeLines, "\nnames(qfeatures) <- paste0(\n\tnames(qfeatures),\n\t'_initial_import'\n)")
     codeLines
 }
 

R/processQFeatures.R

@@ -68,21 +68,19 @@
 #' if (interactive()) {
 #'     shiny::runApp(app)
 #' }
-processQFeatures <- function(
-      qfeatures = NULL,
-      initialSets = NULL,
-      prefilledSteps = c(
-          "sampleFiltering",
-          "featureFiltering",
-          "missingValuesFeatures",
-          "missingValuesSamples",
-          "normalisation",
-          "aggregation",
-          "join",
-          "aggregation"
-      ),
-      maxSize = 100
-) {
+processQFeatures <- function(qfeatures = NULL,
+    initialSets = NULL,
+    prefilledSteps = c(
+        "sampleFiltering",
+        "featureFiltering",
+        "missingValuesFeatures",
+        "missingValuesSamples",
+        "normalisation",
+        "aggregation",
+        "join",
+        "aggregation"
+    ),
+    maxSize = 100) {
     qfeatures_missing <- missing(qfeatures) || is.null(qfeatures)
     initial_steps <- check_prefilled_steps(prefilledSteps)
 

R/server_import_tab.R

@@ -13,13 +13,11 @@
 #' @rdname INTERNAL_server_import_tab
 #' @keywords internal
 #'
-server_import_tab <- function(
-      input,
-      output,
-      session,
-      sample_table,
-      input_table
-) {
+server_import_tab <- function(input,
+    output,
+    session,
+    sample_table,
+    input_table) {
     imported_input <- box_read_table_server(
         id = "input",
         given_table = input_table

R/server_module_filtering_box.R

@@ -369,14 +369,12 @@ server_module_filtering_box <- function(id, assays_to_process, type, state) {
 #' @importFrom shiny moduleServer observe req eventReactive reactive
 #' @importFrom plotly plot_ly renderPlotly
 #'
-server_module_annotation_plot <- function(
-      id,
-      assays_to_process,
-      type,
-      filter_value,
-      selected_annotation,
-      filter_operator
-) {
+server_module_annotation_plot <- function(id,
+    assays_to_process,
+    type,
+    filter_value,
+    selected_annotation,
+    filter_operator) {
     moduleServer(id, function(input, output, session) {
         rowname_selector_key <- ".qfeaturesgui_rowname"
 
@@ -512,12 +510,10 @@ missingness_filter_plot_values <- function(values, operator) {
     )
 }
 
-missingness_annotation_plot_wrapper <- function(
-      annotation,
-      filtered_annotation,
-      assay_name,
-      annotation_name
-) {
+missingness_annotation_plot_wrapper <- function(annotation,
+    filtered_annotation,
+    assay_name,
+    annotation_name) {
     categories <- levels(annotation)
     annotation <- factor(annotation, levels = categories)
     before_counts <- as.integer(table(annotation))
@@ -569,12 +565,10 @@ missingness_annotation_plot_wrapper <- function(
 #'
 #' @importFrom plotly plot_ly config %>% add_histogram layout add_annotations
 #'
-annotation_plot_wrapper <- function(
-      annotation,
-      filtered_annotation,
-      assay_name,
-      annotation_name
-) {
+annotation_plot_wrapper <- function(annotation,
+    filtered_annotation,
+    assay_name,
+    annotation_name) {
     if (all(is.na(annotation))) {
         plot <- plot_ly(
             x = numeric(0),

R/server_module_filtering_tab.R

@@ -12,13 +12,11 @@
 #' @importFrom shiny moduleServer eventReactive observeEvent renderUI reactiveValues observe NS reactive req reactiveVal icon
 #' @importFrom htmltools tags
 #' @importFrom shinydashboard renderInfoBox infoBox
-server_module_filtering_tab <- function(
-      id,
-      step_number,
-      step_rv,
-      parent_rv,
-      type = c("samples", "features")
-) {
+server_module_filtering_tab <- function(id,
+    step_number,
+    step_rv,
+    parent_rv,
+    type = c("samples", "features")) {
     type <- match.arg(type)
 
     moduleServer(id, function(input, output, session) {

R/utils_global.R

@@ -78,10 +78,12 @@ error_handler <- function(func, component_name, ...) {
 #' @importFrom htmltools HTML div
 #'
 #' @rdname INTERNAL_show_exception_notification
-show_exception_notification <- function(component_name,
-    type = c("error", "warning"),
-    time,
-    duration = 30) {
+show_exception_notification <- function(
+      component_name,
+      type = c("error", "warning"),
+      time,
+      duration = 30
+) {
     type <- match.arg(type)
 
     title <- paste0(
@@ -203,10 +205,12 @@ loading <- function(msg) {
 #' @return A UI element wrapped with waiter behavior.
 #' @rdname INTERNAL_with_output_waiter
 #' @keywords internal
-with_output_waiter <- function(element,
-    html = waiter::spin_fading_circles(),
-    color = "rgba(0, 0, 0, 0.25)",
-    image = "") {
+with_output_waiter <- function(
+      element,
+      html = waiter::spin_fading_circles(),
+      color = "rgba(0, 0, 0, 0.25)",
+      image = ""
+) {
     output_id <- element$attribs$id
     if (is.null(output_id) && is.list(element) && length(element) > 0L) {
         first_child <- element[[1]]
@@ -485,10 +489,12 @@ page_assays_subset <- function(qfeatures, pattern) {
 #' @rdname INTERNAL_bs3Tooltip
 #' @keywords internal
 #'
-bs3Tooltip <- function(trigger,
-    tooltipText,
-    placement = c("right", "left", "top", "bottom"),
-    icon = "fa-info-circle") {
+bs3Tooltip <- function(
+      trigger,
+      tooltipText,
+      placement = c("right", "left", "top", "bottom"),
+      icon = "fa-info-circle"
+) {
     stopifnot(
         is.character(tooltipText), length(tooltipText) == 1L,
         is.character(icon), length(icon) == 1L

R/utils_processQFeatures.R

@@ -1316,8 +1316,10 @@ annotation_cols <- function(x, what) {
 #' @importFrom MsCoreUtils robustSummary medianPolish
 #' @importFrom waiter Waiter spin_fading_circles
 #'
-aggregation_qfeatures <- function(qfeatures, method,
-    fcol) {
+aggregation_qfeatures <- function(
+      qfeatures, method,
+      fcol
+) {
     n <- length(qfeatures)
     caption <- if (n > 0L) {
         paste0("Aggregation of 1/", n, " sets")