Skip to content

Commit

Permalink
Merge branch 'devel' of github.com:LieberInstitute/spatialLIBD into d…
Browse files Browse the repository at this point in the history 
…evel
  • Loading branch information
@lcolladotor
lcolladotor committed Dec 10, 2024
2 parents 120803f + a87428b commit bf6c637
Show file tree
Hide file tree
Showing 4 changed files with 125 additions and 60 deletions.
154 changes: 101 additions & 53 deletions R/app_server.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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({
Expand Down Expand Up @@ -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()
}
)
Expand Down Expand Up @@ -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()
}
)
Expand Down Expand Up @@ -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
Expand All @@ -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())
Expand Down
4 changes: 3 additions & 1 deletion R/app_ui.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -352,7 +352,8 @@ app_ui <- function() {
tags$br(),
tags$br(),
tags$br(),
tags$br()
tags$br(),
textOutput("gene_warnings")
),
tabPanel(
"Gene (interactive)",
Expand Down Expand Up @@ -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(),
Expand Down
6 changes: 3 additions & 3 deletions R/multi_gene_z_score.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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(
Expand Down
21 changes: 18 additions & 3 deletions tests/testthat/test-multi_gene_z_score.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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"
)
}
)

0 comments on commit bf6c637

Please sign in to comment.