Skip to content

Commit

Permalink
Added "Order cell types by" option to the 'Markers' tab.
Browse files Browse the repository at this point in the history
  • Loading branch information
@aviezerl
aviezerl committed Mar 13, 2024
1 parent cc72088 commit 85a61fe
Show file tree
Hide file tree
Showing 3 changed files with 37 additions and 4 deletions.
1 change: 1 addition & 0 deletions NEWS.md
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,6 +2,7 @@

* Added an option to show only fitted genes in the projected fold tab.
* Moved "Order by" and "Force cell type" to left sidebar in the 'Markers' tab.
* Added "Order cell types by" option to the 'Markers' tab.
* Fix: legend did not appear in the 'Markers' tab when using `ggplot 3.5.0`.

# MCView 0.2.27
Expand Down
12 changes: 9 additions & 3 deletions R/utils_heatmap.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -115,6 +115,7 @@ heatmap_sidebar <- function(id, ..., show_fitted_filter = FALSE) {
uiOutput(ns("cell_type_list")),
uiOutput(ns("metadata_list")),
checkboxInput(ns("force_cell_type"), "Force cell type", value = TRUE),
shinyWidgets::virtualSelectInput(ns("metadata_order_cell_type_var"), "Order cell types by", choices = NULL, selected = NULL, multiple = FALSE, search = TRUE),
shinyWidgets::virtualSelectInput(ns("metadata_order_var"), "Order by", choices = NULL, selected = NULL, multiple = FALSE, search = TRUE),
tags$hr(),
...,
Expand Down Expand Up @@ -150,6 +151,9 @@ heatmap_matrix_reactives <- function(ns, input, output, session, dataset, metace
updateSelectInput(session, "selected_marker_genes", choices = choices)
}
shinyWidgets::updateVirtualSelect(session = session, inputId = "metadata_order_var", choices = c("Hierarchical-Clustering", dataset_metadata_fields_numeric(dataset())), selected = "Hierarchical-Clustering")
shinyWidgets::updateVirtualSelect(session = session, inputId = "metadata_order_cell_type_var", choices = c("Hierarchical-Clustering", "Colors table", dataset_metadata_fields_numeric(dataset())), selected = "Hierarchical-Clustering")

shinyjs::toggle(id = "metadata_order_cell_type_var", condition = input$force_cell_type)
})

observe({
Expand Down Expand Up @@ -313,11 +317,13 @@ heatmap_reactives <- function(id, dataset, metacell_types, gene_modules, cell_ty
markers(),
input$selected_cell_types,
metacell_types(),
cell_type_colors(),
gene_modules(),
force_cell_type = input$force_cell_type,
mode = mode,
notify_var_genes = TRUE,
metadata_order = input$metadata_order_var
metadata_order = input$metadata_order_var,
cell_type_metadata_order = input$metadata_order_cell_type_var
)


Expand All @@ -333,7 +339,7 @@ heatmap_reactives <- function(id, dataset, metacell_types, gene_modules, cell_ty
}

return(m)
}) %>% bindCache(id, dataset(), metacell_types(), cell_type_colors(), markers(), gene_modules(), input$selected_cell_types, input$force_cell_type, genes(), input$show_genes, clipboard_changed(), mode, input$metadata_order_var)
}) %>% bindCache(id, dataset(), metacell_types(), cell_type_colors(), markers(), gene_modules(), input$selected_cell_types, input$force_cell_type, genes(), input$show_genes, clipboard_changed(), mode, input$metadata_order_var, input$metadata_order_cell_type_var)

output$download_matrix <- downloadHandler(
filename = function() {
Expand Down Expand Up @@ -546,7 +552,7 @@ heatmap_reactives <- function(id, dataset, metacell_types, gene_modules, cell_ty
return(structure(list(p = res$p, gtable = res$gtable), class = "gt_custom"))
},
res = 96
) %>% bindCache(id, dataset(), metacell_types(), cell_type_colors(), gene_modules(), lfp_range(), metacell_filter(), input$plot_legend, input$plot_cell_type_legend, input$plot_genes_legend, input$selected_md, markers(), input$selected_cell_types, input$force_cell_type, clipboard_changed(), input$high_color, input$low_color, input$mid_color, input$midpoint, genes(), input$show_genes, highlighted_genes(), highlight_color, input$max_gene_num, input$metadata_order_var)
) %>% bindCache(id, dataset(), metacell_types(), cell_type_colors(), gene_modules(), lfp_range(), metacell_filter(), input$plot_legend, input$plot_cell_type_legend, input$plot_genes_legend, input$selected_md, markers(), input$selected_cell_types, input$force_cell_type, clipboard_changed(), input$high_color, input$low_color, input$mid_color, input$midpoint, genes(), input$show_genes, highlighted_genes(), highlight_color, input$max_gene_num, input$metadata_order_var, input$metadata_order_cell_type_var)

observeEvent(input$heatmap_brush, {
req(input$brush_action)
Expand Down
28 changes: 27 additions & 1 deletion R/utils_markers.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -268,7 +268,7 @@ get_markers <- function(dataset) {
return(marker_genes)
}

get_marker_matrix <- function(dataset, markers, cell_types = NULL, metacell_types = NULL, gene_modules = NULL, force_cell_type = TRUE, mode = "Markers", notify_var_genes = FALSE, metadata_order = NULL) {
get_marker_matrix <- function(dataset, markers, cell_types = NULL, metacell_types = NULL, cell_type_colors = NULL, gene_modules = NULL, force_cell_type = TRUE, mode = "Markers", notify_var_genes = FALSE, metadata_order = NULL, cell_type_metadata_order = NULL) {
cached_dist <- NULL
if (mode == "Inner") {
mc_fp <- get_mc_data(dataset, "inner_fold_mat")
Expand Down Expand Up @@ -324,6 +324,24 @@ get_marker_matrix <- function(dataset, markers, cell_types = NULL, metacell_type
}

if (ncol(mat) > 1) {
# order cell types
cell_type_order <- NULL
if (force_cell_type && !is.null(cell_type_metadata_order) && cell_type_metadata_order != "" && cell_type_metadata_order != "Hierarchical-Clustering" && cell_type_metadata_order %in% c(dataset_metadata_fields_numeric(dataset), "Colors table")) {
req(!is.null(metacell_types))
req(!is.null(cell_type_colors))
if (cell_type_metadata_order == "Colors table") {
cell_type_order <- cell_type_colors$cell_type
} else {
cell_type_order <- get_mc_data(dataset, "metadata") %>%
left_join(metacell_types, by = "metacell") %>%
group_by(cell_type) %>%
summarise(ord_mean = mean(!!sym(cell_type_metadata_order))) %>%
arrange(ord_mean) %>%
pull(cell_type)
}
}

# order within cell types (if force_cell_type) / global (if !force_cell_type)
secondary_order <- NULL
if (!is.null(metadata_order) && metadata_order != "" && metadata_order != "Hierarchical-Clustering" && metadata_order %in% dataset_metadata_fields_numeric(dataset)) {
secondary_order <- get_mc_data(dataset, "metadata") %>%
Expand All @@ -335,6 +353,14 @@ get_marker_matrix <- function(dataset, markers, cell_types = NULL, metacell_type
mc_order <- secondary_order
} else {
mc_order <- order_mc_by_most_var_genes(mat, force_cell_type = force_cell_type, metacell_types = metacell_types, epsilon = epsilon, notify_var_genes = notify_var_genes, log_transform = log_transform, cached_dist = cached_dist, secondary_order = secondary_order)
if (!is.null(cell_type_order)) {
mc_order_names <- tibble(metacell = colnames(mat)[mc_order]) %>%
left_join(metacell_types, by = "metacell") %>%
mutate(cell_type = factor(cell_type, levels = cell_type_order)) %>%
arrange(cell_type) %>%
pull(metacell)
mc_order <- match(mc_order_names, colnames(mat))
}
}

mat <- mat[, mc_order, drop = FALSE]
Expand Down

0 comments on commit 85a61fe

Please sign in to comment.