Merge branch 'devel' of github.com:LieberInstitute/spatialLIBD into devel

Author: lcolladotor

R/app_server.R

@@ -224,64 +224,80 @@ app_server <- function(input, output, session) {
     })
 
     static_gene <- reactive({
-        p <- vis_gene(
-            spe,
-            sampleid = input$sample,
-            geneid = input$geneid,
-            multi_gene_method = input$multi_gene_method,
-            assayname = input$assayname,
-            minCount = input$minCount,
-            cont_colors = cont_colors(),
-            image_id = input$imageid,
-            alpha = input$alphalevel,
-            point_size = input$pointsize,
-            auto_crop = input$auto_crop,
-            is_stitched = is_stitched
-        )
-        if (!input$side_by_side_gene) {
-            return(p)
-        } else {
-            p_no_spots <- p
-            p_no_spots$layers[[2]] <- NULL
-
-            p_no_spatial <- p
-            p_no_spatial$layers[[1]] <- NULL
-            cowplot::plot_grid(
-                plotlist = list(
-                    p_no_spots,
-                    p_no_spatial + ggplot2::theme(legend.position = "none")
-                ),
-                nrow = 1,
-                ncol = 2
+        gene_warning = NULL
+        withCallingHandlers({
+            p <- vis_gene(
+                spe,
+                sampleid = input$sample,
+                geneid = input$geneid,
+                multi_gene_method = input$multi_gene_method,
+                assayname = input$assayname,
+                minCount = input$minCount,
+                cont_colors = cont_colors(),
+                image_id = input$imageid,
+                alpha = input$alphalevel,
+                point_size = input$pointsize,
+                auto_crop = input$auto_crop,
+                is_stitched = is_stitched
             )
-        }
+            if (!input$side_by_side_gene) {
+                p_result = p
+            } else {
+                p_no_spots <- p
+                p_no_spots$layers[[2]] <- NULL
+
+                p_no_spatial <- p
+                p_no_spatial$layers[[1]] <- NULL
+                p_result = cowplot::plot_grid(
+                    plotlist = list(
+                        p_no_spots,
+                        p_no_spatial + ggplot2::theme(legend.position = "none")
+                    ),
+                    nrow = 1,
+                    ncol = 2
+                )
+            }
+        }, warning = function(w) {
+            gene_warning <<- conditionMessage(w)
+            invokeRestart("muffleWarning")
+        })
+        return(list(p = p_result, gene_warning = gene_warning))
     })
 
     static_gene_grid <- reactive({
         input$gene_grid_update
 
-        plots <-
-            vis_grid_gene(
-                spe,
-                geneid = isolate(input$geneid),
-                multi_gene_method = input$multi_gene_method,
-                assayname = isolate(input$assayname),
-                minCount = isolate(input$minCount),
-                return_plots = TRUE,
-                spatial = isolate(input$grid_spatial_gene),
-                cont_colors = isolate(cont_colors()),
-                image_id = isolate(input$imageid),
-                alpha = isolate(input$alphalevel),
-                point_size = isolate(input$pointsize),
-                sample_order = isolate(input$gene_grid_samples),
-                auto_crop = isolate(input$auto_crop),
-                is_stitched = is_stitched
-            )
-        cowplot::plot_grid(
+        gene_grid_warnings = NULL
+        withCallingHandlers({
+            plots <-
+                vis_grid_gene(
+                    spe,
+                    geneid = isolate(input$geneid),
+                    multi_gene_method = input$multi_gene_method,
+                    assayname = isolate(input$assayname),
+                    minCount = isolate(input$minCount),
+                    return_plots = TRUE,
+                    spatial = isolate(input$grid_spatial_gene),
+                    cont_colors = isolate(cont_colors()),
+                    image_id = isolate(input$imageid),
+                    alpha = isolate(input$alphalevel),
+                    point_size = isolate(input$pointsize),
+                    sample_order = isolate(input$gene_grid_samples),
+                    auto_crop = isolate(input$auto_crop),
+                    is_stitched = is_stitched
+                )
+        }, warning = function(w) {
+            gene_grid_warnings <<- c(gene_grid_warnings, conditionMessage(w))
+            invokeRestart("muffleWarning")
+        })
+
+        p_result = cowplot::plot_grid(
             plotlist = plots,
             nrow = isolate(input$gene_grid_nrow),
             ncol = isolate(input$gene_grid_ncol)
         )
+
+        return(list(p = p_result, gene_grid_warnings = gene_grid_warnings))
     })
 
     editImg_manipulations <- reactive({
@@ -439,7 +455,7 @@ app_server <- function(input, output, session) {
                 height = 8,
                 width = 8 * ifelse(input$side_by_side_gene, 2, 1)
             )
-            print(static_gene())
+            print(static_gene()[['p']])
             dev.off()
         }
     )
@@ -467,7 +483,7 @@ app_server <- function(input, output, session) {
                 height = 8 * isolate(input$gene_grid_nrow),
                 width = 8 * isolate(input$gene_grid_ncol)
             )
-            print(static_gene_grid())
+            print(static_gene_grid()[['p']])
             dev.off()
         }
     )
@@ -530,17 +546,32 @@ app_server <- function(input, output, session) {
         height = "auto"
     )
 
-
     output$gene <- renderPlot(
         {
-            static_gene()
+            static_gene()[['p']]
         },
         width = function() {
             600 * ifelse(input$side_by_side_gene, 2, 1)
         },
         height = 600
     )
 
+    output$gene_warnings <- renderText({
+        #   Since 'static_gene()' is invoked twice (once also in the assignment
+        #   of 'output$gene'), we silence any errors that occur in this second
+        #   invocation to not duplicate error messages
+        this_warning = NULL
+        temp = try(
+            { this_warning = static_gene()[['gene_warning']] }, silent = TRUE
+        )
+
+        if (!is.null(this_warning)) {
+            paste("Warning:", this_warning)
+        } else {
+            ""
+        }
+    })
+
 
     output$gene_grid_static <- renderUI({
         input$gene_grid_update
@@ -554,12 +585,29 @@ app_server <- function(input, output, session) {
 
     output$gene_grid <- renderPlot(
         {
-            print(static_gene_grid())
+            print(static_gene_grid()[['p']])
         },
         width = "auto",
         height = "auto"
     )
 
+    output$gene_grid_warnings <- renderText({
+        #   Since 'static_gene_grid()' is invoked twice (once also in the
+        #   assignment of 'output$gene_grid'), we silence any errors that occur
+        #   in this second invocation to not duplicate error messages
+        these_warnings = NULL
+        temp = try(
+            { these_warnings = static_gene_grid()[['gene_grid_warnings']] },
+            silent = TRUE
+        )
+
+        if (!is.null(these_warnings)) {
+            paste("Warnings:", paste(these_warnings, collapse = "; "))
+        } else {
+            ""
+        }
+    })
+
     output$editImg_plot <- renderPlot(
         {
             plot(editImg_manipulations())

R/app_ui.R

@@ -352,7 +352,8 @@ app_ui <- function() {
                                 tags$br(),
                                 tags$br(),
                                 tags$br(),
-                                tags$br()
+                                tags$br(),
+                                textOutput("gene_warnings")
                             ),
                             tabPanel(
                                 "Gene (interactive)",
@@ -422,6 +423,7 @@ app_ui <- function() {
                                 actionButton("gene_grid_update", label = "Update grid plot"),
                                 downloadButton("downloadPlotGeneGrid", "Download PDF"),
                                 uiOutput("gene_grid_static"),
+                                textOutput("gene_grid_warnings"),
                                 helpText("Click the 'upgrade grid plot' button above to re-make this plot."),
                                 tags$br(),
                                 tags$br(),

R/multi_gene_z_score.R

@@ -14,11 +14,11 @@
 #' @family functions for summarizing expression of multiple continuous variables simultaneously
 #' @keywords internal
 multi_gene_z_score <- function(cont_mat) {
-    #   Z-score calculation requires at least 2 features with nonzero variance.
+    #   Z-score calculation requires at least 1 feature with nonzero variance.
     #   Verify this and drop any zero-variance features
     good_indices <- which(colSds(cont_mat, na.rm = TRUE) != 0)
-    if (length(good_indices) < 2) {
-        stop("After dropping features with no expression variation, less than 2 features were left. This error can occur when using data from only 1 spot.", call. = FALSE)
+    if (length(good_indices) < 1) {
+        stop("After dropping features with no expression variation, no features were left. This error can occur when using data from only 1 spot.", call. = FALSE)
     }
     if (ncol(cont_mat) - length(good_indices) > 0) {
         warning(

tests/testthat/test-multi_gene_z_score.R

@@ -11,17 +11,32 @@ test_that(
         )
 
         #   NAs should be correctly removed from columns (as long as 2 non-NAs remain
-        #   in at least 2 columns), and the result should have no NAs
+        #   in at least 1 column), and the result should have no NAs
         cont_mat <- matrix(c(1, NA, 3, NA, 2, 0), ncol = 2)
         colnames(cont_mat) <- c("good1", "good2")
         expect_equal(any(is.na(multi_gene_z_score(cont_mat))), FALSE)
 
-        #   With only one good column, an error should be thrown
+        #   With only one good column, the result should simply be the
+        #   Z-score-normalized good column. A warning should indicate which
+        #   columns were dropped
         cont_mat <- matrix(c(1, NA, 3, 4, 2, 2), ncol = 3)
         colnames(cont_mat) <- c("bad1", "good", "bad2")
+        
+        temp = c(3, 4)
+        expected_result = (temp - mean(temp)) / sd(temp)
+
+        expect_warning(
+            { actual_result = multi_gene_z_score(cont_mat) },
+            "Dropping features\\(s\\) 'bad1', 'bad2' which have no expression variation"
+        )
+        expect_equal(actual_result, expected_result)
+
+        #   An error should be thrown if no columns have variation
+        cont_mat <- matrix(c(1, 1, 0, 0, 2, 2), ncol = 3)
+        colnames(cont_mat) <- c("bad1", "bad2", "bad3")
         expect_error(
             multi_gene_z_score(cont_mat),
-            "After dropping features with no expression variation, less than 2 features were left"
+            "^After dropping features with no expression variation"
         )
     }
 )