diff --git a/R/app_server.R b/R/app_server.R index c40c1506..ff5f7f64 100644 --- a/R/app_server.R +++ b/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,10 +546,9 @@ 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) @@ -541,6 +556,22 @@ app_server <- function(input, output, session) { 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()) diff --git a/R/app_ui.R b/R/app_ui.R index d042db15..208a2352 100644 --- a/R/app_ui.R +++ b/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(), diff --git a/R/multi_gene_z_score.R b/R/multi_gene_z_score.R index 3c6f3c1a..abfdfff2 100644 --- a/R/multi_gene_z_score.R +++ b/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( diff --git a/tests/testthat/test-multi_gene_z_score.R b/tests/testthat/test-multi_gene_z_score.R index cd701abb..f78af3f1 100644 --- a/tests/testthat/test-multi_gene_z_score.R +++ b/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" ) } )