diff --git a/.gitignore b/.gitignore
index 7612fc4..9870a2e 100755
--- a/.gitignore
+++ b/.gitignore
@@ -5,3 +5,5 @@ cerebroApp_*.tar.gz
vignettes/*.crb
docs
tests
+.Rproj.user
+*.Rproj
diff --git a/DESCRIPTION b/DESCRIPTION
index 71a8884..66030f1 100755
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,6 +1,6 @@
Package: cerebroApp
Title: Interactive visualization of scRNA-seq data with Cerebro
-Version: 1.3.0
+Version: 1.3.1
Authors@R:
person("Roman", "Hillje", email = "roman.hillje@googlemail.com", role = c("aut", "cre"))
Description: Cerebro is a Shiny application that allows to interactively visualize scRNA-seq data. Data must be exported from a Seurat object using the helper functions which also allows to perform analysis such as pathway enrichment analysis based on marker genes of samples and/or clusters.
diff --git a/NEWS.md b/NEWS.md
index d687894..24c20af 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -1,3 +1,31 @@
+# cerebroApp 1.3.1
+
+Despite the minor version bump, this update contains substantial performance improvements in the Shiny app, specifically in the projections.
+
+## Major changes
+
+- Projections in the "Overview" and "Gene (set) expression" are now updated using the `Plotly.react()` Javascript function instead of redrawn from scratch inside R when changing the input variables. For the user, that means that (1) plots are drawn much quicker and (2) the current zoom/pan settings are maintained when switching plot parameters (coloring variable, point size/opacity, etc).
+
+## Minor changes
+
+- It is now possible to define several settings related to the projections shown in the "Overview" and "Gene (set) expression" tabs. For example, you can change the default point size and opacity, the default percentage of cells to show, and whether or not hover info should be activated in the projections. These settings are optional but useful when hosting a known data sets in `closed` mode, e.g. because you want to decrease the point size in a large data set. The respective parameters can be found in the description of the `launchCerebroV1.3()` function.
+- Hover/tooltip info for cells in projections can be deactivated through a checkbox on the "About" tab. Deactivating hover info increases performance of projections.
+- Hover/tooltip info for cells in the gene expression projection no longer contain the gene expression value. This is because preparing the hover info is an expensive computation with little return. As a result of removing the gene expression value, the hover info does not need to be recalculated every time a gene is added to or removed from the list of genes to show expression for. For the same reason, when plotting a trajectory, the state and pseudotime are not added to the hover info either.
+- Internally, data for plotting in projections is rearranged, stored in different variables, and the final output is debounced to avoid unnecessary redrawing of the projections on initialization.
+- The feature to show expression of multiple genes in separate panels has been matured. Up to 9 genes can be shown in a 3x3 panel matrix but all share the same color scale. While cells can be selected in any of the panels, the expression levels shown in the other UI element, e.g. table of selected cells or expression by group, refers to the mean expression of all selected genes (not just the one the cells were selected in).
+- When coloring cells in projections by a caterogical variable, e.g. cell type, the dots in the legend are now larger and independent from the selected point size.
+- Tables are now rendered server-side to improve performance for large tables.
+- Cellular barcodes in tables of selected cells are formatted in monospace font.
+- Columns in meta data tables, e.g. table of cells selected in projections, which are identified to contain percentage on a 0-100 scale are changed to a 0-1 scale to prevent non-sensical values such as 500%.
+- Add comma to Y axis and hover info in bar chart of selected cells in projection ("Overview" tab).
+- The `crb_file_to_load` parameter of the `launchCerebroV1.3()` function (or as part of `Cerebro.options`) can now be set to the name of a `Cerebro_v1.3` object. That means you can load the data set before launching Cerebro (with `readRDS()`) and make Cerebro initialize itself with it. This is particularly useful when hosting Cerebro in `closed` mode, preventing that each user session has to read the data set from disk.
+- Update author info in "About" tab.
+
+## Fixes
+
+- Colors assigned to groups in bar chart of selected cells in projection ("Overview" tab) sometimes did not match those shown in the projection. This only applied to categorical grouping variables that are not registered as grouping variables.
+- Update Enrichr API for `getEnrichedPathways()` function. Make it configurable in case of further changes to the API.
+
# cerebroApp 1.3.0
Because this is a relatively big release, I have prepared a dedicated article with release notes for cerebroApp v1.3 that you can find in the navigation bar.
diff --git a/R/getEnrichedPathways.R b/R/getEnrichedPathways.R
index a69ca26..7419ff9 100755
--- a/R/getEnrichedPathways.R
+++ b/R/getEnrichedPathways.R
@@ -19,7 +19,7 @@
#' @param URL_API URL to send requests to (Enrichr API). Allows to overwrite
#' default URL with an alternative taken from the Enrichr website in case the
#' original is out-of-service; defaults to
-#' 'http://amp.pharm.mssm.edu/Enrichr/enrich'.
+#' 'http://maayanlab.cloud/Enrichr'.
#'
#' @return
#' Seurat object with Enrichr results for all provided grouping variables,
@@ -34,7 +34,7 @@
#' databases = c('GO_Biological_Process_2018','GO_Cellular_Component_2018'),
#' adj_p_cutoff = 0.01,
#' max_terms = 100,
-#' URL_API = 'http://amp.pharm.mssm.edu/Enrichr/enrich'
+#' URL_API = 'http://maayanlab.cloud/Enrichr'
#' )
#'
#' @import dplyr
@@ -60,7 +60,7 @@ getEnrichedPathways <- function(
),
adj_p_cutoff = 0.05,
max_terms = 100,
- URL_API = 'http://amp.pharm.mssm.edu/Enrichr/enrich'
+ URL_API = 'http://maayanlab.cloud/Enrichr'
) {
##--------------------------------------------------------------------------##
diff --git a/R/launchCerebroV1.3.R b/R/launchCerebroV1.3.R
index 1899b9b..5945dc5 100644
--- a/R/launchCerebroV1.3.R
+++ b/R/launchCerebroV1.3.R
@@ -16,6 +16,15 @@
#' @param welcome_message \code{string} with custom welcome message to display
#' in the "Load data" tab. Can contain HTML formatting, e.g.
#' \code{'
Hi!
'}. Defaults to \code{NULL}.
+#' @param projections_default_point_size Default point size in projections. This
+#' value can be changed in the UI; defaults to 5.
+#' @param projections_default_point_opacity Default point opacity in
+#' projections. This value can be changed in the UI; defaults to 1.0.
+#' @param projections_default_percentage_cells_to_show Default percentage of
+#' cells to show in projections. This value can be changed in the UI; defaults
+#' to 100.
+#' @param projections_show_hover_info Show hover infos in projections. This
+#" setting can be changed in the UI; defaults to TRUE.
#' @param ... Further parameters that are used by \code{shiny::runApp}, e.g.
#' \code{host} or \code{port}.
#'
@@ -59,11 +68,15 @@ launchCerebroV1.3 <- function(
maxFileSize = 800,
crb_file_to_load = NULL,
welcome_message = NULL,
+ projections_default_point_size = 5,
+ projections_default_point_opacity = 1.0,
+ projections_default_percentage_cells_to_show = 100,
+ projections_show_hover_info = TRUE,
...
){
##--------------------------------------------------------------------------##
- ## Check validity of 'mode' parameter.
+ ## Check validity of input parameters.
##--------------------------------------------------------------------------##
if ( mode %in% c('open','closed') == FALSE ) {
stop(
@@ -71,6 +84,39 @@ launchCerebroV1.3 <- function(
call. = FALSE
)
}
+ if (
+ projections_default_point_size < 0 ||
+ projections_default_point_size > 20
+ ) {
+ stop(
+ "'projections_default_point_size' parameter must be between 1 and 20",
+ call. = FALSE
+ )
+ }
+ if (
+ projections_default_point_opacity < 0 ||
+ projections_default_point_opacity > 1
+ ) {
+ stop(
+ "'projections_default_point_opacity' parameter must be between 0 and 1",
+ call. = FALSE
+ )
+ }
+ if (
+ projections_default_percentage_cells_to_show < 0 ||
+ projections_default_percentage_cells_to_show > 100
+ ) {
+ stop(
+ "'projections_default_percentage_cells_to_show' parameter must be between 0 and 100",
+ call. = FALSE
+ )
+ }
+ if ( projections_show_hover_info %in% c(TRUE, FALSE) == FALSE ) {
+ stop(
+ "'projections_show_hover_info' parameter must be set to either TRUE or FALSE.",
+ call. = FALSE
+ )
+ }
##--------------------------------------------------------------------------##
## Create global variable with options that need to be available inside the
@@ -80,7 +126,11 @@ launchCerebroV1.3 <- function(
"mode" = mode,
"crb_file_to_load" = crb_file_to_load,
"welcome_message" = welcome_message,
- "cerebro_root" = system.file(package = "cerebroApp")
+ "cerebro_root" = system.file(package = "cerebroApp"),
+ "projections_default_point_size" = projections_default_point_size,
+ "projections_default_point_opacity" = projections_default_point_opacity,
+ "projections_default_percentage_cells_to_show" = projections_default_percentage_cells_to_show,
+ "projections_show_hover_info" = projections_show_hover_info
)
##--------------------------------------------------------------------------##
diff --git a/R/send_enrichr_query.r b/R/send_enrichr_query.r
index 865bf8d..84ced5b 100644
--- a/R/send_enrichr_query.r
+++ b/R/send_enrichr_query.r
@@ -8,7 +8,7 @@
#' score between 0 and 1 in the other.
#' @param databases Databases to search.
#' @param URL_API URL to send requests to (Enrichr API).
-#' See http://amp.pharm.mssm.edu/Enrichr/ for available databases.
+#' See https://maayanlab.cloud/Enrichr/#stats for available databases.
#'
#' @return
#' Returns a data frame of enrichment terms, p-values, ...
@@ -33,7 +33,7 @@
## send request with gene names
temp <- httr::POST(
- url = URL_API,
+ url = paste0(URL_API, "/enrich"),
body = list(
list = paste(genes, collapse = '\n')
)
@@ -44,7 +44,7 @@
## send request with gene names and scores
temp <- httr::POST(
- url = URL_API,
+ url = paste0(URL_API, "/enrich"),
body = list(
list = paste(paste(genes[,1], genes[,2], sep = ','), collapse = '\n')
)
@@ -61,7 +61,7 @@
}
##
- httr::GET(url = 'http://amp.pharm.mssm.edu/Enrichr/share')
+ httr::GET(url = paste0(URL_API, "/share"))
##
dfSAF <- options()$stringsAsFactors
@@ -79,7 +79,7 @@
##
r <- httr::GET(
- url = 'http://amp.pharm.mssm.edu/Enrichr/export',
+ url = paste0(URL_API, "/export"),
query = list(
file = 'API',
backgroundType = x
diff --git a/inst/shiny/v1.3/about/server.R b/inst/shiny/v1.3/about/server.R
index 3bef0aa..f06fe0a 100644
--- a/inst/shiny/v1.3/about/server.R
+++ b/inst/shiny/v1.3/about/server.R
@@ -2,6 +2,7 @@
## Tab: About.
##----------------------------------------------------------------------------##
+##
output[["about"]] <- renderText({
paste0(
'Version of cerebroApp
@@ -9,8 +10,6 @@ output[["about"]] <- renderText({
Author
Roman Hillje
- Department of Experimental Oncology
- IEO, European Institute of Oncology IRCCS, Milan
Links
@@ -25,9 +24,6 @@ output[["about"]] <- renderText({
Roman Hillje, Pier Giuseppe Pelicci, Lucilla Luzi, Cerebro: Interactive visualization of scRNA-seq data, Bioinformatics, btz877, https://doi.org/10.1093/bioinformatics/btz877
- Contact
- roman.hillje@ieo.it
-
License
Cerebro is distributed under the terms of the MIT license.
@@ -40,21 +36,48 @@ output[["about"]] <- renderText({
)
})
+##
output[["preferences"]] <- renderUI({
tagList(
- checkboxInput("webgl_checkbox", label = "Use WebGL", value = TRUE)
+ tags$div(
+ title = "Using WebGL is best for performance but might not be compatible with every browser.",
+ checkboxInput(
+ "webgl_checkbox",
+ label = "Use WebGL",
+ value = TRUE
+ )
+ ),
+ tags$div(
+ title = "Switching off hover info in projections improves performance.",
+ checkboxInput(
+ "hover_info_in_projections_checkbox",
+ label = "Show hover info in projections",
+ value = Cerebro.options[['projections_show_hover_info']]
+ )
+ )
)
})
+##
observeEvent(input[["webgl_checkbox"]], {
- preferences$use_webgl <- input[["webgl_checkbox"]]
- print(paste0("WebGL status is now: ", preferences$use_webgl))
+ preferences[["use_webgl"]] <- input[["webgl_checkbox"]]
+ print(glue::glue("[{Sys.time()}] WebGL status: {preferences[['use_webgl']]}"))
})
-observeEvent(input[["browser"]], {
- browser()
+##
+observeEvent(input[["hover_info_in_projections_checkbox"]], {
+ preferences[["show_hover_info_in_projections"]] <- input[["hover_info_in_projections_checkbox"]]
+ print(glue::glue("[{Sys.time()}] Show hover info status: {preferences[['show_hover_info_in_projections']]}"))
})
+##
+outputOptions(
+ output,
+ "preferences",
+ suspendWhenHidden = FALSE
+)
+
+##
output[["logo_Cerebro"]] <- renderImage({
list(
src = paste0(Cerebro.options$cerebro_root, '/extdata/logo_Cerebro.png'),
@@ -67,6 +90,7 @@ output[["logo_Cerebro"]] <- renderImage({
deleteFile = FALSE
)
+##
output[["about_footer"]] <- renderText({
paste0(
'
@@ -79,11 +103,3 @@ output[["about_footer"]] <- renderText({
'
)
})
-
-
-
-
-
-
-
-
diff --git a/inst/shiny/v1.3/color_setup.R b/inst/shiny/v1.3/color_setup.R
index e2691b3..47b4aa9 100644
--- a/inst/shiny/v1.3/color_setup.R
+++ b/inst/shiny/v1.3/color_setup.R
@@ -28,43 +28,28 @@ cell_cycle_colorset <- setNames(
## Assign colors to groups.
##----------------------------------------------------------------------------##
reactive_colors <- reactive({
-
- req(
- data_set()
- )
-
+ req(data_set())
## get cell meta data
meta_data <- getMetaData()
-
colors <- list()
-
## go through all groups
for ( group_name in getGroups() ) {
-
## if color selection from the "Color management" tab exist, assign those
## colors, otherwise assign colors from default colorset
if ( !is.null(input[[ paste0('color_', group_name, '_', getGroupLevels(group_name)[1]) ]]) ) {
-
for ( group_level in getGroupLevels(group_name) ) {
-
## it seems that special characters are not handled well in input/output
## so I replace them with underscores using gsub()
colors[[ group_name ]][ group_level ] <- input[[ paste0('color_', group_name, '_', gsub(group_level, pattern = '[^[:alnum:]]', replacement = '_')) ]]
}
-
} else {
-
colors[[ group_name ]] <- default_colorset[seq_along(getGroupLevels(group_name))]
names(colors[[ group_name ]]) <- getGroupLevels(group_name)
-
if ( 'N/A' %in% getGroupLevels(group_name) ) {
-
colors[[ group_name ]][ which(names(colors[[ group_name ]]) == 'N/A') ] <- '#898989'
}
-
}
}
-
## go through columns with cell cycle info
if ( length(getCellCycle()) > 0 ) {
for ( column in getCellCycle() ) {
@@ -82,6 +67,5 @@ reactive_colors <- reactive({
}
}
}
-
return(colors)
})
diff --git a/inst/shiny/v1.3/enriched_pathways/select_content.R b/inst/shiny/v1.3/enriched_pathways/select_content.R
index 9a7391a..7508970 100644
--- a/inst/shiny/v1.3/enriched_pathways/select_content.R
+++ b/inst/shiny/v1.3/enriched_pathways/select_content.R
@@ -8,10 +8,7 @@
## UI element to set layout for selection of method and group, which are split
## because the group depends on which method is selected.
##----------------------------------------------------------------------------##
-
output[["enriched_pathways_select_method_and_table_UI"]] <- renderUI({
-
- ## ...
if (
!is.null(getMethodsForEnrichedPathways()) &&
length(getMethodsForEnrichedPathways()) > 0
@@ -28,22 +25,12 @@ output[["enriched_pathways_select_method_and_table_UI"]] <- renderUI({
)
)
)
-
- ## ...
- } else {
- fluidRow(
- cerebroBox(
- title = boxTitle("Enriched pathways"),
- textOutput("enriched_pathways_message_no_method_found")
- )
- )
}
})
##----------------------------------------------------------------------------##
## UI element to select from which method the results should be shown.
##----------------------------------------------------------------------------##
-
output[["enriched_pathways_selected_method_UI"]] <- renderUI({
tagList(
div(
@@ -67,15 +54,8 @@ output[["enriched_pathways_selected_method_UI"]] <- renderUI({
##----------------------------------------------------------------------------##
## UI element to select which group should be shown.
##----------------------------------------------------------------------------##
-
output[["enriched_pathways_selected_table_UI"]] <- renderUI({
-
- ##
- req(
- input[["enriched_pathways_selected_method"]]
- )
-
- ##
+ req(input[["enriched_pathways_selected_method"]])
tagList(
div(
HTML('Choose a table:')
@@ -98,7 +78,6 @@ output[["enriched_pathways_selected_table_UI"]] <- renderUI({
##----------------------------------------------------------------------------##
## Alternative text message if data is missing.
##----------------------------------------------------------------------------##
-
output[["enriched_pathways_message_no_method_found"]] <- renderText({
"No data available."
})
diff --git a/inst/shiny/v1.3/enriched_pathways/table.R b/inst/shiny/v1.3/enriched_pathways/table.R
index 53e97e9..eaedff6 100644
--- a/inst/shiny/v1.3/enriched_pathways/table.R
+++ b/inst/shiny/v1.3/enriched_pathways/table.R
@@ -9,23 +9,33 @@
##----------------------------------------------------------------------------##
output[["enriched_pathways_table_UI"]] <- renderUI({
-
- ##
- req(
- input[["enriched_pathways_selected_method"]],
- input[["enriched_pathways_selected_table"]]
- )
-
- ##
- fluidRow(
- cerebroBox(
- title = tagList(
- boxTitle("Enriched pathways"),
- cerebroInfoButton("enriched_pathways_info")
- ),
- uiOutput("enriched_pathways_table_or_text_UI")
+ selected_method <- input[["enriched_pathways_selected_method"]]
+ selected_table <- input[["enriched_pathways_selected_table"]]
+ if (
+ is.null(selected_method) ||
+ selected_method %in% getMethodsForEnrichedPathways() == FALSE
+ ) {
+ fluidRow(
+ cerebroBox(
+ title = boxTitle("Enriched pathways"),
+ textOutput("enriched_pathways_message_no_method_found")
+ )
)
- )
+ } else {
+ req(
+ input[["enriched_pathways_selected_method"]],
+ input[["enriched_pathways_selected_table"]]
+ )
+ fluidRow(
+ cerebroBox(
+ title = tagList(
+ boxTitle("Enriched pathways"),
+ cerebroInfoButton("enriched_pathways_info")
+ ),
+ uiOutput("enriched_pathways_table_or_text_UI")
+ )
+ )
+ }
})
##----------------------------------------------------------------------------##
@@ -36,21 +46,15 @@ output[["enriched_pathways_table_UI"]] <- renderUI({
##----------------------------------------------------------------------------##
output[["enriched_pathways_table_or_text_UI"]] <- renderUI({
-
- ##
req(
input[["enriched_pathways_selected_method"]],
input[["enriched_pathways_selected_table"]],
input[["enriched_pathways_selected_table"]] %in% getGroupsWithEnrichedPathways(input[["enriched_pathways_selected_method"]])
-
)
-
- ## fetch results
results_type <- getEnrichedPathways(
input[["enriched_pathways_selected_method"]],
input[["enriched_pathways_selected_table"]]
)
-
## depending on the content of the results slot, show a text message or
## switches and table
if (
@@ -166,7 +170,7 @@ output[["enriched_pathways_filter_subgroups_UI"]] <- renderUI({
## Table with results.
##----------------------------------------------------------------------------##
-output[["enriched_pathways_table"]] <- DT::renderDataTable(server = FALSE, {
+output[["enriched_pathways_table"]] <- DT::renderDataTable({
##
req(
diff --git a/inst/shiny/v1.3/extra_material/UI.R b/inst/shiny/v1.3/extra_material/UI.R
index 7822fde..a55dc4d 100644
--- a/inst/shiny/v1.3/extra_material/UI.R
+++ b/inst/shiny/v1.3/extra_material/UI.R
@@ -1,7 +1,6 @@
##----------------------------------------------------------------------------##
## Tab: Extra material
##----------------------------------------------------------------------------##
-
tab_extra_material <- tabItem(
tabName = "extra_material",
shinyjs::inlineCSS("
diff --git a/inst/shiny/v1.3/extra_material/content.R b/inst/shiny/v1.3/extra_material/content.R
index e75f7ac..0e946e9 100644
--- a/inst/shiny/v1.3/extra_material/content.R
+++ b/inst/shiny/v1.3/extra_material/content.R
@@ -1,23 +1,14 @@
##----------------------------------------------------------------------------##
-## Tab: Extra material
-##
## Show content or info text when data is missing.
##----------------------------------------------------------------------------##
##----------------------------------------------------------------------------##
## UI element for output.
-##----------------------------------------------------------------------------##
-
+##----------------------------------------------------------------------------#
output[["extra_material_content_UI"]] <- renderUI({
-
- ##
- req(
- input[["extra_material_selected_category"]]
- )
-
+ req(input[["extra_material_selected_category"]])
## if selected category is `tables`
if ( input[["extra_material_selected_category"]] == 'tables' ) {
-
##
fluidRow(
cerebroBox(
@@ -48,10 +39,8 @@ output[["extra_material_content_UI"]] <- renderUI({
)
)
)
-
## if selected category is `plots`
} else if ( input[["extra_material_selected_category"]] == 'plots' ) {
-
##
fluidRow(
cerebroBox(
@@ -81,35 +70,24 @@ output[["extra_material_content_UI"]] <- renderUI({
##----------------------------------------------------------------------------##
## Table.
##----------------------------------------------------------------------------##
-
-output[["extra_material_table"]] <- DT::renderDataTable(server = FALSE, {
-
- ##
+output[["extra_material_table"]] <- DT::renderDataTable({
req(
input[["extra_material_selected_category"]],
input[["extra_material_selected_content"]]
)
-
## fetch results
results_df <- getExtraTable(input[["extra_material_selected_content"]])
-
## don't proceed if input is not a data frame
- req(
- is.data.frame(results_df)
- )
-
+ req(is.data.frame(results_df))
## if the table is empty, skip the processing and show and empty table
## (otherwise the procedure would result in an error)
if ( nrow(results_df) == 0 ) {
-
results_df %>%
as.data.frame() %>%
dplyr::slice(0) %>%
prepareEmptyTable()
-
## if there is at least 1 row, create proper table
} else {
-
prettifyTable(
results_df,
filter = list(position = "top", clear = TRUE),
@@ -137,14 +115,8 @@ output[["extra_material_table"]] <- DT::renderDataTable(server = FALSE, {
## UI element that contains interactive or plain version of plot, depending on
## switch status
##----------------------------------------------------------------------------##
-
output[["extra_material_plot_UI"]] <- renderUI({
-
- ##
- req(
- !is.null(input[["extra_material_plot_interactive_switch"]])
- )
-
+ req(!is.null(input[["extra_material_plot_interactive_switch"]]))
if ( input[["extra_material_plot_interactive_switch"]] == TRUE ) {
plotly::plotlyOutput(
"extra_material_plot_interactive",
@@ -163,26 +135,17 @@ output[["extra_material_plot_UI"]] <- renderUI({
##----------------------------------------------------------------------------##
## UI element that contains interactive version of plot
##----------------------------------------------------------------------------##
-
output[["extra_material_plot_interactive"]] <- plotly::renderPlotly({
-
- ##
req(
input[["extra_material_selected_category"]],
input[["extra_material_selected_content"]]
)
-
## fetch results
plot <- getExtraPlot(input[["extra_material_selected_content"]])
-
## don't proceed if input is not of class "ggplot"
- req(
- "ggplot" %in% class(plot)
- )
-
+ req("ggplot" %in% class(plot))
## convert to plotly
plot <- plotly::ggplotly(plot)
-
## return plot either with WebGL or without, depending on setting
if ( preferences$use_webgl == TRUE ) {
plot %>% plotly::toWebGL()
@@ -194,31 +157,21 @@ output[["extra_material_plot_interactive"]] <- plotly::renderPlotly({
##----------------------------------------------------------------------------##
## UI element that contains plain version of plot
##----------------------------------------------------------------------------##
-
output[["extra_material_plot_plain"]] <- renderPlot({
-
- ##
req(
input[["extra_material_selected_category"]],
input[["extra_material_selected_content"]]
)
-
## fetch results
plot <- getExtraPlot(input[["extra_material_selected_content"]])
-
## don't proceed if input is not of class "ggplot"
- req(
- "ggplot" %in% class(plot)
- )
-
- ##
+ req("ggplot" %in% class(plot))
return(plot)
})
##----------------------------------------------------------------------------##
## Info box that gets shown when pressing the "info" button.
##----------------------------------------------------------------------------##
-
observeEvent(input[["extra_material_info"]], {
showModal(
modalDialog(
@@ -234,7 +187,6 @@ observeEvent(input[["extra_material_info"]], {
##----------------------------------------------------------------------------##
## Text in info box.
##----------------------------------------------------------------------------##
-
extra_material_info <- list(
title = "Extra material",
text = HTML("
diff --git a/inst/shiny/v1.3/extra_material/select_content.R b/inst/shiny/v1.3/extra_material/select_content.R
index fd94c42..8cd6566 100644
--- a/inst/shiny/v1.3/extra_material/select_content.R
+++ b/inst/shiny/v1.3/extra_material/select_content.R
@@ -1,6 +1,4 @@
##----------------------------------------------------------------------------##
-## Tab: Extra material
-##
## Select category and content.
##----------------------------------------------------------------------------##
@@ -8,7 +6,6 @@
## UI element to set layout for selection of category and specific content,
## which are split because the content depends on which category is selected.
##----------------------------------------------------------------------------##
-
output[["extra_material_select_category_and_content_UI"]] <- renderUI({
tagList(
fluidRow(
@@ -27,7 +24,6 @@ output[["extra_material_select_category_and_content_UI"]] <- renderUI({
##----------------------------------------------------------------------------##
## UI element to select from which category the content should be shown.
##----------------------------------------------------------------------------##
-
output[["extra_material_selected_category_UI"]] <- renderUI({
tagList(
div(
@@ -51,20 +47,13 @@ output[["extra_material_selected_category_UI"]] <- renderUI({
##----------------------------------------------------------------------------##
## UI element to select which content should be shown.
##----------------------------------------------------------------------------##
-
output[["extra_material_selected_content_UI"]] <- renderUI({
-
- ##
- req(
- input[["extra_material_selected_category"]]
- )
-
+ req(input[["extra_material_selected_category"]])
## if selected category is `tables`
if (
input[["extra_material_selected_category"]] == 'tables' &&
checkForExtraTables() == TRUE
) {
-
##
tagList(
div(
@@ -83,13 +72,11 @@ output[["extra_material_selected_content_UI"]] <- renderUI({
column(2)
)
)
-
## if selected category is `plots`
} else if (
input[["extra_material_selected_category"]] == 'plots' &&
checkForExtraPlots() == TRUE
) {
-
##
tagList(
div(
diff --git a/inst/shiny/v1.3/extra_material/server.R b/inst/shiny/v1.3/extra_material/server.R
index 7db2123..26f49dd 100644
--- a/inst/shiny/v1.3/extra_material/server.R
+++ b/inst/shiny/v1.3/extra_material/server.R
@@ -1,7 +1,6 @@
##----------------------------------------------------------------------------##
## Tab: Extra material
##----------------------------------------------------------------------------##
-
source(paste0(Cerebro.options[["cerebro_root"]], "/shiny/v1.3/extra_material/select_content.R"), local = TRUE)
source(paste0(Cerebro.options[["cerebro_root"]], "/shiny/v1.3/extra_material/content.R"), local = TRUE)
diff --git a/inst/shiny/v1.3/gene_expression/UI.R b/inst/shiny/v1.3/gene_expression/UI.R
index 3fd5886..5084fcd 100644
--- a/inst/shiny/v1.3/gene_expression/UI.R
+++ b/inst/shiny/v1.3/gene_expression/UI.R
@@ -1,13 +1,34 @@
##----------------------------------------------------------------------------##
## Tab: Gene (set) expression
##----------------------------------------------------------------------------##
+js_code_gene_expression_projection <- readr::read_file(
+ paste0(Cerebro.options[["cerebro_root"]], "/shiny/v1.3/gene_expression/js_projection_update_plot.js")
+)
tab_gene_expression <- tabItem(
tabName = "geneExpression",
+ ## necessary to ensure alignment of table headers and content
+ shinyjs::inlineCSS("
+ #expression_details_selected_cells .table th {
+ text-align: center;
+ }
+ #expression_details_selected_cells .dt-middle {
+ vertical-align: middle;
+ }
+ "
+ ),
+ shinyjs::extendShinyjs(
+ text = js_code_gene_expression_projection,
+ functions = c(
+ "expressionProjectionUpdatePlot2D",
+ "expressionProjectionUpdatePlot2DMultiPanel",
+ "expressionProjectionUpdatePlot3D"
+ )
+ ),
uiOutput("expression_projection_UI"),
uiOutput("expression_details_selected_cells_UI"),
uiOutput("expression_in_selected_cells_UI"),
uiOutput("expression_by_group_UI"),
- uiOutput("expression_by_gene_UI"),
- uiOutput("expression_by_pseudotime_UI")
+ uiOutput("expression_by_gene_UI")#,
+ # uiOutput("expression_by_pseudotime_UI")
)
diff --git a/inst/shiny/v1.3/gene_expression/expression_by_gene.R b/inst/shiny/v1.3/gene_expression/UI_expression_by_gene.R
similarity index 89%
rename from inst/shiny/v1.3/gene_expression/expression_by_gene.R
rename to inst/shiny/v1.3/gene_expression/UI_expression_by_gene.R
index ecb6166..71cc097 100644
--- a/inst/shiny/v1.3/gene_expression/expression_by_gene.R
+++ b/inst/shiny/v1.3/gene_expression/UI_expression_by_gene.R
@@ -1,13 +1,10 @@
##----------------------------------------------------------------------------##
-## Tab: Gene (set) expression
-##
## Expression by gene.
##----------------------------------------------------------------------------##
##----------------------------------------------------------------------------##
## UI element for plot.
##----------------------------------------------------------------------------##
-
output[["expression_by_gene_UI"]] <- renderUI({
fluidRow(
cerebroBox(
@@ -23,44 +20,32 @@ output[["expression_by_gene_UI"]] <- renderUI({
##----------------------------------------------------------------------------##
## Bar plot.
##----------------------------------------------------------------------------##
-
output[["expression_by_gene"]] <- plotly::renderPlotly({
-
- ## don't proceed without these inputs
- req(
- input[["expression_projection_color_scale"]]
- )
-
+ req(input[["expression_projection_color_scale"]])
## prepare expression levels, depending on genes provided by user
## ... if no genes are available
- if ( length(genesToPlot()$genes_to_display_present) == 0 ) {
-
+ if ( length(expression_selected_genes()$genes_to_display_present) == 0 ) {
## manually prepare empty data frame
expression_levels <- data.frame(
"gene" = character(),
"expression" = integer()
)
-
## ... if at least 1 gene has been provided
- } else if ( length(genesToPlot()$genes_to_display_present) >= 1 ) {
-
+ } else if ( length(expression_selected_genes()$genes_to_display_present) >= 1 ) {
## - calculate mean expression for every gene across all cells
## - sort genes by mean expression from high to low
## - show only first 50 genes if more are available
- expression_levels <- getMeanExpressionForGenes(genesToPlot()$genes_to_display_present) %>%
+ expression_levels <- getMeanExpressionForGenes(expression_selected_genes()$genes_to_display_present) %>%
dplyr::slice_max(expression, n = 50)
}
-
## prepare color scale, either "viridis" or other
## ...
if ( input[["expression_projection_color_scale"]] == 'viridis' ) {
color_scale <- 'Viridis'
-
## ...
} else {
color_scale <- input[["expression_projection_color_scale"]]
}
-
## prepare plot
plotly::plot_ly(
expression_levels,
@@ -106,7 +91,6 @@ output[["expression_by_gene"]] <- plotly::renderPlotly({
##----------------------------------------------------------------------------##
## Info box that gets shown when pressing the "info" button.
##----------------------------------------------------------------------------##
-
observeEvent(input[["expression_by_gene_info"]], {
showModal(
modalDialog(
@@ -122,7 +106,6 @@ observeEvent(input[["expression_by_gene_info"]], {
##----------------------------------------------------------------------------##
## Text in info box.
##----------------------------------------------------------------------------##
-
expression_by_gene_info <- list(
title = "Expression levels by gene",
text = p("Log-normalised expression of 50 highest expressed genes inserted above. Shows mean across all cells.")
diff --git a/inst/shiny/v1.3/gene_expression/expression_by_group.R b/inst/shiny/v1.3/gene_expression/UI_expression_by_group.R
similarity index 62%
rename from inst/shiny/v1.3/gene_expression/expression_by_group.R
rename to inst/shiny/v1.3/gene_expression/UI_expression_by_group.R
index ac1ce5a..dd6d6f9 100644
--- a/inst/shiny/v1.3/gene_expression/expression_by_group.R
+++ b/inst/shiny/v1.3/gene_expression/UI_expression_by_group.R
@@ -7,7 +7,6 @@
##----------------------------------------------------------------------------##
## UI element with input selection (which group to show) and plot.
##----------------------------------------------------------------------------##
-
output[["expression_by_group_UI"]] <- renderUI({
fluidRow(
cerebroBox(
@@ -33,73 +32,67 @@ output[["expression_by_group_UI"]] <- renderUI({
##----------------------------------------------------------------------------##
output[["expression_by_group"]] <- plotly::renderPlotly({
-
- ## don't proceed without these inputs
req(
- input[["expression_projection_to_display"]],
+ expression_projection_data(),
+ expression_projection_expression_levels(),
input[["expression_by_group_selected_group"]]
)
-
## check if user requested to show expression in separate panels
## ... separate panels requested and "gene" column present (which means
## expression was actually split by gene)
- if (
- input[["expression_projection_show_genes_in_separate_panels"]] == TRUE &&
- "gene" %in% colnames(gene_expression_plot_data()) == TRUE
- ) {
-
- ## don't plot anything because data is not present
- ## even if I merged all meta data in the data frame, it wouldn't be correct
- ## because cells are plotted once per gene
-
- ## ...
+ ## don't plot anything because data is not present
+ ## even if I merged all meta data in the data frame, it wouldn't be correct
+ ## because cells are plotted once per gene
+ cells_df <- expression_projection_data()
+ if (is.list(expression_projection_expression_levels())) {
+ cells_df$level <- do.call(cbind, expression_projection_expression_levels()) %>%
+ Matrix::rowMeans()
} else {
-
- ## prepare plot
- gene_expression_plot_data() %>%
- plotly::plot_ly(
- x = ~.[[ input[["expression_by_group_selected_group"]] ]],
- y = ~level,
- type = "violin",
- box = list(
- visible = TRUE
- ),
- meanline = list(
- visible = TRUE
- ),
- color = ~.[[ input[["expression_by_group_selected_group"]] ]],
- colors = reactive_colors()[[ input[["expression_by_group_selected_group"]] ]],
- source = "subset",
- showlegend = FALSE,
- hoverinfo = "y",
- marker = list(
- size = 5
- )
- ) %>%
- plotly::layout(
- title = "",
- xaxis = list(
- title = "",
- mirror = TRUE,
- showline = TRUE
- ),
- yaxis = list(
- title = "Expression level",
- range = c(0, max(gene_expression_plot_data()$level, na.rm = TRUE) * 1.2),
- hoverformat = ".2f",
- mirror = TRUE,
- showline = TRUE
- ),
- dragmode = "select",
- hovermode = "compare"
- )
+ cells_df$level <- expression_projection_expression_levels()
}
+ ## prepare plot
+ cells_df %>%
+ plotly::plot_ly(
+ x = ~.[[ input[["expression_by_group_selected_group"]] ]],
+ y = ~level,
+ type = "violin",
+ box = list(
+ visible = TRUE
+ ),
+ meanline = list(
+ visible = TRUE
+ ),
+ color = ~.[[ input[["expression_by_group_selected_group"]] ]],
+ colors = reactive_colors()[[ input[["expression_by_group_selected_group"]] ]],
+ source = "subset",
+ showlegend = FALSE,
+ hoverinfo = "y",
+ marker = list(
+ size = 5
+ )
+ ) %>%
+ plotly::layout(
+ title = "",
+ xaxis = list(
+ title = "",
+ mirror = TRUE,
+ showline = TRUE
+ ),
+ yaxis = list(
+ title = "Expression level",
+ range = c(0, max(cells_df$level, na.rm = TRUE) * 1.2),
+ hoverformat = ".2f",
+ mirror = TRUE,
+ showline = TRUE
+ ),
+ dragmode = "select",
+ hovermode = "compare"
+ )
})
##----------------------------------------------------------------------------##
## Info box that gets shown when pressing the "info" button.
##----------------------------------------------------------------------------##
-
observeEvent(input[["expression_by_group_info"]], {
showModal(
modalDialog(
@@ -115,7 +108,6 @@ observeEvent(input[["expression_by_group_info"]], {
##----------------------------------------------------------------------------##
## Text in info box.
##----------------------------------------------------------------------------##
-
expression_by_group_info <- list(
title = "Expression levels by group",
text = p("Log-normalised expression of genes inserted above by group If more than 1 gene was provided, this reflects the average across all cells of each group")
diff --git a/inst/shiny/v1.3/gene_expression/expression_by_pseudotime.R b/inst/shiny/v1.3/gene_expression/UI_expression_by_pseudotime.R
similarity index 93%
rename from inst/shiny/v1.3/gene_expression/expression_by_pseudotime.R
rename to inst/shiny/v1.3/gene_expression/UI_expression_by_pseudotime.R
index 1cb1b45..36307f0 100644
--- a/inst/shiny/v1.3/gene_expression/expression_by_pseudotime.R
+++ b/inst/shiny/v1.3/gene_expression/UI_expression_by_pseudotime.R
@@ -1,29 +1,21 @@
##----------------------------------------------------------------------------##
-## Tab: Gene (set) expression
-##
## Expression by pseudotime.
##----------------------------------------------------------------------------##
##----------------------------------------------------------------------------##
## UI element for plot.
##----------------------------------------------------------------------------##
-
output[["expression_by_pseudotime_UI"]] <- renderUI({
-
- ## proceed only if selection is not a projection
req(
input[["expression_projection_to_display"]] %in% availableProjections() == FALSE
)
-
## split selection into method and name
selection <- strsplit(input[["expression_projection_to_display"]], split = ' // ')[[1]]
-
## check if method and name exist and don't proceed if not
req(
selection[1] %in% getMethodsForTrajectories(),
selection[2] %in% getNamesOfTrajectories(selection[1])
)
-
fluidRow(
cerebroBox(
title = tagList(
@@ -73,48 +65,36 @@ output[["expression_by_pseudotime_UI"]] <- renderUI({
##----------------------------------------------------------------------------##
## Plot.
##----------------------------------------------------------------------------##
-
output[["expression_by_pseudotime"]] <- plotly::renderPlotly({
-
- ## don't proceed without these inputs
req(
input[["expression_projection_to_display"]],
input[["expression_projection_point_size"]],
input[["expression_projection_point_opacity"]],
input[["expression_projection_color_scale"]],
- input[["expression_projection_color_scale_range"]],
+ input[["expression_projection_color_range"]],
!is.null(input[["expression_by_pseudotime_show_trend_line"]]),
input[["expression_by_pseudotime_trend_line_bandwidth"]],
input[["expression_by_pseudotime_trend_line_width"]],
- gene_expression_plot_data()
+ expression_projection_data(),
+ "pseudotime" %in% colnames(expression_projection_data())
)
-
- req(
- "pseudotime" %in% colnames(gene_expression_plot_data())
- )
-
- cells_df <- gene_expression_plot_data()
-
+ cells_df <- expression_projection_data()
## prepare hover info
hover_info <- buildHoverInfoForProjections(cells_df)
-
## add expression levels to hover info
hover_info <- glue::glue(
"{hover_info}
Pseudotime: {formatC(cells_df[[ 'pseudotime' ]], format = 'f', digits = 2)}
State: {cells_df[[ 'state' ]]}"
)
-
## check selected color scale
## ... selected color scale is "viridis"
if ( input[["expression_projection_color_scale"]] == 'viridis' ) {
color_scale <- 'Viridis'
-
## ... selected color scale is anything else than "viridis"
} else {
color_scale <- input[["expression_projection_color_scale"]]
}
-
## prepare plot
plot <- plotly::plot_ly() %>%
plotly::add_trace(
@@ -131,8 +111,8 @@ output[["expression_by_pseudotime"]] <- plotly::renderPlotly({
opacity = input[["expression_projection_point_opacity"]],
colorscale = color_scale,
cauto = FALSE,
- cmin = input[["expression_projection_color_scale_range"]][1],
- cmax = input[["expression_projection_color_scale_range"]][2],
+ cmin = input[["expression_projection_color_range"]][1],
+ cmax = input[["expression_projection_color_range"]][2],
reversescale = TRUE,
line = list(
color = "rgb(196,196,196)",
@@ -165,10 +145,8 @@ output[["expression_by_pseudotime"]] <- plotly::renderPlotly({
bgcolor = "lightgrey"
)
)
-
## add trend line if activated
if ( input[["expression_by_pseudotime_show_trend_line"]] == TRUE ) {
-
## calculate smoothened trend line
trend_line = stats::ksmooth(
cells_df$pseudotime,
@@ -177,7 +155,6 @@ output[["expression_by_pseudotime"]] <- plotly::renderPlotly({
input[["expression_by_pseudotime_trend_line_bandwidth"]],
x.points = cells_df$pseudotime
)
-
## add trend line to plot
plot <- plotly::add_trace(
plot,
@@ -200,7 +177,6 @@ output[["expression_by_pseudotime"]] <- plotly::renderPlotly({
showlegend = FALSE
)
}
-
## if set in options, return plot with WebGL
if ( preferences$use_webgl == TRUE ) {
plotly::toWebGL(plot)
@@ -212,7 +188,6 @@ output[["expression_by_pseudotime"]] <- plotly::renderPlotly({
##----------------------------------------------------------------------------##
## Info box that gets shown when pressing the "info" button.
##----------------------------------------------------------------------------##
-
observeEvent(input[["expression_by_pseudotime_info"]], {
showModal(
modalDialog(
@@ -228,7 +203,6 @@ observeEvent(input[["expression_by_pseudotime_info"]], {
##----------------------------------------------------------------------------##
## Text in info box.
##----------------------------------------------------------------------------##
-
expression_by_pseudotime_info <- list(
title = "Expression levels by pseudotime",
text = HTML("
diff --git a/inst/shiny/v1.3/gene_expression/UI_expression_in_selected_cells.R b/inst/shiny/v1.3/gene_expression/UI_expression_in_selected_cells.R
new file mode 100644
index 0000000..69afded
--- /dev/null
+++ b/inst/shiny/v1.3/gene_expression/UI_expression_in_selected_cells.R
@@ -0,0 +1,124 @@
+##----------------------------------------------------------------------------##
+## Expression in selected cells.
+##----------------------------------------------------------------------------##
+
+##----------------------------------------------------------------------------##
+## UI element for plot.
+##----------------------------------------------------------------------------##
+output[["expression_in_selected_cells_UI"]] <- renderUI({
+ fluidRow(
+ cerebroBox(
+ title = tagList(
+ boxTitle("Expression levels in selected cells"),
+ cerebroInfoButton("expression_in_selected_cells_info")
+ ),
+ plotly::plotlyOutput("expression_in_selected_cells")
+ )
+ )
+})
+
+##----------------------------------------------------------------------------##
+## Violin/box plot.
+##----------------------------------------------------------------------------##
+output[["expression_in_selected_cells"]] <- plotly::renderPlotly({
+ req(
+ expression_projection_data(),
+ expression_projection_coordinates(),
+ expression_projection_expression_levels()
+ )
+ selected_cells <- expression_projection_selected_cells()
+ cells_df <- bind_cols(
+ expression_projection_coordinates(),
+ expression_projection_data()
+ )
+ if (is.list(expression_projection_expression_levels())) {
+ cells_df$level <- do.call(cbind, expression_projection_expression_levels()) %>%
+ Matrix::rowMeans()
+ } else {
+ cells_df$level <- expression_projection_expression_levels()
+ }
+ ## prepare data to be plotted
+ ## ... if no selection was made or no cells are in selection
+ if ( is.null(selected_cells) ) {
+ ## assign all cells to "not selected" group
+ cells_df <- cells_df %>%
+ dplyr::mutate(group = 'not selected')
+ ## ... if at least 1 cell was selected
+ } else {
+ ## - get data to plot
+ ## - assign cells to either "selected" or "not selected" based on their name
+ ## - keep only relevant columns
+ cells_df <- cells_df %>%
+ dplyr::rename(X1 = 1, X2 = 2) %>%
+ dplyr::mutate(
+ identifier = paste0(X1, '-', X2),
+ group = ifelse(identifier %in% selected_cells$identifier, 'selected', 'not selected'),
+ group = factor(group, levels = c('selected', 'not selected'))
+ ) %>%
+ dplyr::select(group, level)
+ }
+ ## prepare plot
+ plotly::plot_ly(
+ cells_df,
+ x = ~group,
+ y = ~level,
+ type = "violin",
+ box = list(
+ visible = TRUE
+ ),
+ meanline = list(
+ visible = TRUE
+ ),
+ color = ~group,
+ colors = setNames(
+ c('#e74c3c','#7f8c8d'),
+ c('selected', 'not selected')
+ ),
+ source = "subset",
+ showlegend = FALSE,
+ hoverinfo = "y",
+ marker = list(
+ size = 5
+ )
+ ) %>%
+ plotly::layout(
+ title = "",
+ xaxis = list(
+ title = "",
+ mirror = TRUE,
+ showline = TRUE
+ ),
+ yaxis = list(
+ title = "Expression level",
+ range = c(0, max(cells_df$level, na.rm = TRUE) * 1.2),
+ hoverformat = ".2f",
+ mirror = TRUE,
+ showline = TRUE
+ ),
+ dragmode = "select",
+ hovermode = "compare"
+ )
+})
+
+##----------------------------------------------------------------------------##
+## Info box that gets shown when pressing the "info" button.
+##----------------------------------------------------------------------------##
+observeEvent(input[["expression_in_selected_cells_info"]], {
+ showModal(
+ modalDialog(
+ expression_in_selected_cells_info$text,
+ title = expression_in_selected_cells_info$title,
+ easyClose = TRUE,
+ footer = NULL,
+ size = "l"
+ )
+ )
+})
+
+##----------------------------------------------------------------------------##
+## Text in info box.
+##----------------------------------------------------------------------------##
+expression_in_selected_cells_info <- list(
+ title = "Expression levels in selected cells",
+ text = p("This plot shows the log-normalised expression of selected genes for cells grouped by whether they were selected using the box or lasso selection tool. If more than 1 gene was provided, this reflects the average across all cells of each sample.")
+)
diff --git a/inst/shiny/v1.3/gene_expression/UI_projection.R b/inst/shiny/v1.3/gene_expression/UI_projection.R
new file mode 100644
index 0000000..49a40aa
--- /dev/null
+++ b/inst/shiny/v1.3/gene_expression/UI_projection.R
@@ -0,0 +1,174 @@
+##----------------------------------------------------------------------------##
+## UI element with layout for user input and plot.
+##----------------------------------------------------------------------------##
+output[["expression_projection_UI"]] <- renderUI({
+ fluidRow(
+ column(
+ width = 3, offset = 0, style = "padding: 0px;",
+ tagList(
+ cerebroBox(
+ title = tagList(
+ "Main parameters",
+ actionButton(
+ inputId = "expression_projection_main_parameters_info",
+ label = "info",
+ icon = NULL,
+ class = "btn-xs",
+ title = "Show additional information for this panel.",
+ style = "margin-left: 5px"
+ )
+ ),
+ tagList(
+ shinyWidgets::radioGroupButtons(
+ inputId = "expression_analysis_mode",
+ label = NULL,
+ choices = c("Gene(s)", "Gene set"),
+ status = "primary",
+ justified = TRUE,
+ width = "100%"
+ ),
+ uiOutput("expression_projection_input_type_UI"),
+ uiOutput("expression_projection_select_projection_UI")
+ )
+ ),
+ cerebroBox(
+ title = tagList(
+ "Additional parameters",
+ actionButton(
+ inputId = "expression_projection_additional_parameters_info",
+ label = "info",
+ icon = NULL,
+ class = "btn-xs",
+ title = "Show additional information for this panel.",
+ style = "margin-left: 5px"
+ )
+ ),
+ uiOutput("expression_projection_additional_parameters_UI"),
+ collapsed = TRUE
+ ),
+ cerebroBox(
+ title = tagList(
+ "Group filters",
+ actionButton(
+ inputId = "expression_projection_group_filters_info",
+ label = "info",
+ icon = NULL,
+ class = "btn-xs",
+ title = "Show additional information for this panel.",
+ style = "margin-left: 5px"
+ )
+ ),
+ uiOutput("expression_projection_group_filters_UI"),
+ collapsed = TRUE
+ ),
+ cerebroBox(
+ title = tagList(
+ "Color scale",
+ actionButton(
+ inputId = "expression_projection_color_scale_info",
+ label = "info",
+ icon = NULL,
+ class = "btn-xs",
+ title = "Show additional information for this panel.",
+ style = "margin-left: 5px"
+ )
+ ),
+ tagList(
+ uiOutput("expression_projection_color_scale_UI"),
+ uiOutput("expression_projection_color_range_UI"),
+ ),
+ collapsed = TRUE
+ )
+ )
+ ),
+ column(
+ width = 9, offset = 0, style = "padding: 0px;",
+ cerebroBox(
+ title = tagList(
+ boxTitle("Dimensional reduction"),
+ tagList(
+ actionButton(
+ inputId = "expression_projection_info",
+ label = "info",
+ icon = NULL,
+ class = "btn-xs",
+ title = "Show additional information for this panel.",
+ style = "margin-right: 3px"
+ ),
+ shinyFiles::shinySaveButton(
+ "expression_projection_export",
+ label = "export to PDF",
+ title = "Export dimensional reduction to PDF file.",
+ filetype = "pdf",
+ viewtype = "icon",
+ class = "btn-xs",
+ style = "margin-right: 3px"
+ ),
+ shinyWidgets::dropdownButton(
+ tags$div(
+ tags$style(
+ HTML("div.awesome-checkbox {margin-top: 10px;}")
+ ),
+ style = "color: black !important;",
+ tagList(
+ uiOutput("expression_projection_point_border_UI"),
+ uiOutput("expression_projection_genes_in_separate_panels_UI"),
+ uiOutput("expression_projection_scales_UI")
+ )
+ ),
+ circle = FALSE,
+ icon = icon("cog"),
+ inline = TRUE,
+ size = "xs"
+ )
+ )
+ ),
+ tagList(
+ shinycssloaders::withSpinner(
+ plotly::plotlyOutput(
+ "expression_projection",
+ width = "auto",
+ height = "85vh"
+ ),
+ type = 8,
+ hide.ui = FALSE
+ ),
+ tags$br(),
+ htmlOutput("expression_number_of_selected_cells"),
+ tags$br(),
+ htmlOutput("expression_genes_displayed")
+ )
+ )
+ )
+ )
+})
+
+##----------------------------------------------------------------------------##
+## Info box that gets shown when pressing the "info" button.
+##----------------------------------------------------------------------------##
+observeEvent(input[["expression_projection_main_parameters_info"]], {
+ showModal(
+ modalDialog(
+ expression_projection_main_parameters_info$text,
+ title = expression_projection_main_parameters_info$title,
+ easyClose = TRUE,
+ footer = NULL,
+ size = "l"
+ )
+ )
+})
+
+##----------------------------------------------------------------------------##
+## Text in info box.
+##----------------------------------------------------------------------------##
+expression_projection_main_parameters_info <- list(
+ title = "Main parameters for gene (set) expression",
+ text = HTML("
+ The elements in this panel allow you to control what and how results are displayed across the whole tab.
+
+ - Gene(s) / Gene set: Select whether you would like to select individual genes or gene sets. In the case of 'Gene(s)', you can select one or multiple genes from the input field below. If you select multiple genes, the mean expression across the selected genes will be calculated for each cell. If you select 'Gene set', you can select a gene set from the MSigDB. Species-specific gene names will be tried to retrieve, otherwise gene name matching is attempted. A list of which genes are present or missing in the data set can be found below the projection.
+ - Projection: Select here which projection you want to see in the scatter plot on the right.
+
+ "
+ )
+)
diff --git a/inst/shiny/v1.3/gene_expression/UI_projection_additional_parameters.R b/inst/shiny/v1.3/gene_expression/UI_projection_additional_parameters.R
new file mode 100644
index 0000000..d09b3ee
--- /dev/null
+++ b/inst/shiny/v1.3/gene_expression/UI_projection_additional_parameters.R
@@ -0,0 +1,76 @@
+##----------------------------------------------------------------------------##
+## UI elements to set additional plotting parameters.
+##----------------------------------------------------------------------------##
+output[["expression_projection_additional_parameters_UI"]] <- renderUI({
+ tagList(
+ selectInput(
+ "expression_projection_plotting_order",
+ label = "Plotting order",
+ choices = c("Random", "Highest expression on top"),
+ selected = "Random"
+ ),
+ sliderInput(
+ "expression_projection_point_size",
+ label = "Point size",
+ min = preferences[["scatter_plot_point_size"]][["min"]],
+ max = preferences[["scatter_plot_point_size"]][["max"]],
+ step = preferences[["scatter_plot_point_size"]][["step"]],
+ value = preferences[["scatter_plot_point_size"]][["default"]]
+ ),
+ sliderInput(
+ "expression_projection_point_opacity",
+ label = "Point opacity",
+ min = preferences[["scatter_plot_point_opacity"]][["min"]],
+ max = preferences[["scatter_plot_point_opacity"]][["max"]],
+ step = preferences[["scatter_plot_point_opacity"]][["step"]],
+ value = preferences[["scatter_plot_point_opacity"]][["default"]]
+ ),
+ sliderInput(
+ "expression_projection_percentage_cells_to_show",
+ label = "Show % of cells",
+ min = preferences[["scatter_plot_percentage_cells_to_show"]][["min"]],
+ max = preferences[["scatter_plot_percentage_cells_to_show"]][["max"]],
+ step = preferences[["scatter_plot_percentage_cells_to_show"]][["step"]],
+ value = preferences[["scatter_plot_percentage_cells_to_show"]][["default"]]
+ )
+ )
+})
+
+## make sure elements are loaded even though the box is collapsed
+outputOptions(
+ output,
+ "expression_projection_additional_parameters_UI",
+ suspendWhenHidden = FALSE
+)
+
+##----------------------------------------------------------------------------##
+## Info box that gets shown when pressing the "info" button.
+##----------------------------------------------------------------------------##
+observeEvent(input[["expression_projection_additional_parameters_info"]], {
+ showModal(
+ modalDialog(
+ expression_projection_additional_parameters_info$text,
+ title = expression_projection_additional_parameters_info$title,
+ easyClose = TRUE,
+ footer = NULL,
+ size = "l"
+ )
+ )
+})
+
+##----------------------------------------------------------------------------##
+## Text in info box.
+##----------------------------------------------------------------------------##
+expression_projection_additional_parameters_info <- list(
+ title = "Additional parameters for gene (set) expression",
+ text = HTML("
+ The elements in this panel allow you to control what and how results are displayed across the whole tab.
+
+ - Plotting order: Cells can be plotted in random order or so that cells with highest expression are on top.
+ - Point size: Controls how large the cells should be.
+ - Point opacity: Controls the transparency of the cells.
+ - Show % of cells: Using the slider, you can randomly remove a fraction of cells from the plot. This can be useful for large data sets and/or computers with limited resources.
+
+ "
+ )
+)
diff --git a/inst/shiny/v1.3/gene_expression/UI_projection_color_scale.R b/inst/shiny/v1.3/gene_expression/UI_projection_color_scale.R
new file mode 100644
index 0000000..19ba076
--- /dev/null
+++ b/inst/shiny/v1.3/gene_expression/UI_projection_color_scale.R
@@ -0,0 +1,18 @@
+##----------------------------------------------------------------------------##
+## UI elements to set color scale.
+##----------------------------------------------------------------------------##
+output[["expression_projection_color_scale_UI"]] <- renderUI({
+ selectInput(
+ "expression_projection_color_scale",
+ label = "Color scale",
+ choices = c("YlGnBu", "YlOrRd","Blues","Greens","Reds","RdBu","Viridis"),
+ selected = "YlGnBu"
+ )
+})
+
+## make sure elements are loaded even though the box is collapsed
+outputOptions(
+ output,
+ "expression_projection_color_scale_UI",
+ suspendWhenHidden = FALSE
+)
diff --git a/inst/shiny/v1.3/gene_expression/UI_projection_color_scale_range.R b/inst/shiny/v1.3/gene_expression/UI_projection_color_scale_range.R
new file mode 100644
index 0000000..bd6b16b
--- /dev/null
+++ b/inst/shiny/v1.3/gene_expression/UI_projection_color_scale_range.R
@@ -0,0 +1,76 @@
+##----------------------------------------------------------------------------##
+## UI elements to set color scale range.
+##----------------------------------------------------------------------------##
+output[["expression_projection_color_range_UI"]] <- renderUI({
+ req(expression_projection_expression_levels())
+ ## get range of expression levels
+ if (input[["expression_projection_genes_in_separate_panels"]] == TRUE) {
+ expression_levels <- c()
+ for (i in length(expression_projection_expression_levels())) {
+ expression_levels <- c(
+ expression_levels,
+ expression_projection_expression_levels()
+ )
+ }
+ expression_range <- range(expression_levels)
+ } else {
+ expression_range <- range(expression_projection_expression_levels())
+ }
+ ## adjust expression range for color scale
+ ## ... there is no range (from 0 to 0)
+ if (
+ expression_range[1] == 0 &&
+ expression_range[2] == 0
+ ) {
+ ## set range to 0-1
+ expression_range[2] <- 1
+ ## ... otherwise
+ } else {
+ ## round min and max values to 2 digits
+ expression_range <- round(expression_range, digits = 2)
+ }
+ sliderInput(
+ "expression_projection_color_range",
+ label = "Range of color scale",
+ min = expression_range[1],
+ max = expression_range[2],
+ value = expression_range
+ )
+})
+
+## make sure elements are loaded even though the box is collapsed
+outputOptions(
+ output,
+ "expression_projection_color_range_UI",
+ suspendWhenHidden = FALSE
+)
+
+##----------------------------------------------------------------------------##
+## Info box that gets shown when pressing the "info" button.
+##----------------------------------------------------------------------------##
+observeEvent(input[["expression_projection_color_scale_info"]], {
+ showModal(
+ modalDialog(
+ expression_projection_color_scale_info$text,
+ title = expression_projection_color_scale_info$title,
+ easyClose = TRUE,
+ footer = NULL,
+ size = "l"
+ )
+ )
+})
+
+##----------------------------------------------------------------------------##
+## Text in info box.
+##----------------------------------------------------------------------------##
+expression_projection_color_scale_info <- list(
+ title = "Color scale for gene (set) expression",
+ text = HTML("
+ The elements in this panel allow you to control what and how results are displayed across the whole tab.
+
+ - Color scale: Choose your prefered color scale.
+ - Range of color scale: Using the sliders, you can set the limits for the color scale. Values outside the scale will be shown in the color corresponding to the min/max value, respectively.
+
+ "
+ )
+)
diff --git a/inst/shiny/v1.3/gene_expression/UI_projection_genes_separate_panels.R b/inst/shiny/v1.3/gene_expression/UI_projection_genes_separate_panels.R
new file mode 100644
index 0000000..987b3b0
--- /dev/null
+++ b/inst/shiny/v1.3/gene_expression/UI_projection_genes_separate_panels.R
@@ -0,0 +1,17 @@
+##----------------------------------------------------------------------------##
+## UI elements with switch to plot genes in separate panels.
+##----------------------------------------------------------------------------##
+output[["expression_projection_genes_in_separate_panels_UI"]] <- renderUI({
+ shinyWidgets::awesomeCheckbox(
+ inputId = "expression_projection_genes_in_separate_panels",
+ label = HTML("Show genes in separate panels
(experimental)"),
+ value = FALSE
+ )
+})
+
+## make sure elements are loaded even though the box is collapsed
+outputOptions(
+ output,
+ "expression_projection_genes_in_separate_panels_UI",
+ suspendWhenHidden = FALSE
+)
diff --git a/inst/shiny/v1.3/gene_expression/UI_projection_group_filters.R b/inst/shiny/v1.3/gene_expression/UI_projection_group_filters.R
new file mode 100644
index 0000000..a29c884
--- /dev/null
+++ b/inst/shiny/v1.3/gene_expression/UI_projection_group_filters.R
@@ -0,0 +1,54 @@
+##----------------------------------------------------------------------------##
+## UI elements to set group filters.
+##----------------------------------------------------------------------------##
+output[["expression_projection_group_filters_UI"]] <- renderUI({
+ group_filters <- list()
+
+ for ( i in getGroups() ) {
+ group_filters[[i]] <- shinyWidgets::pickerInput(
+ paste0("expression_projection_group_filter_", i),
+ label = i,
+ choices = getGroupLevels(i),
+ selected = getGroupLevels(i),
+ options = list(
+ "actions-box" = TRUE
+ ),
+ multiple = TRUE
+ )
+ }
+ group_filters
+})
+
+## make sure elements are loaded even though the box is collapsed
+outputOptions(
+ output,
+ "expression_projection_group_filters_UI",
+ suspendWhenHidden = FALSE
+)
+
+##----------------------------------------------------------------------------##
+## Info box that gets shown when pressing the "info" button.
+##----------------------------------------------------------------------------##
+observeEvent(input[["expression_projection_group_filters_info"]], {
+ showModal(
+ modalDialog(
+ expression_projection_group_filters_info$text,
+ title = expression_projection_group_filters_info$title,
+ easyClose = TRUE,
+ footer = NULL,
+ size = "l"
+ )
+ )
+})
+
+##----------------------------------------------------------------------------##
+## Text in info box.
+##----------------------------------------------------------------------------##
+#
- Range of X/Y axis (located in dropdown menu above the projection): Set the X/Y axis limits. This is useful when you want to change the aspect ratio of the plot.
+expression_projection_group_filters_info <- list(
+ title = "Group filters for gene (set) expression",
+ text = HTML("
+ The elements in this panel allow you to select which cells should be plotted based on the group(s) they belong to. For each grouping variable, you can activate or deactivate group levels. Only cells that are pass all filters (for each grouping variable) are shown in the projection, the expression by group, and expression by pseudotime (if applicable).
+ "
+ )
+)
diff --git a/inst/shiny/v1.3/gene_expression/UI_projection_input_type.R b/inst/shiny/v1.3/gene_expression/UI_projection_input_type.R
new file mode 100644
index 0000000..effdf6f
--- /dev/null
+++ b/inst/shiny/v1.3/gene_expression/UI_projection_input_type.R
@@ -0,0 +1,26 @@
+##----------------------------------------------------------------------------##
+## UI elements to choose whether gene(s) or gene sets should be analyzed
+##----------------------------------------------------------------------------##
+output[["expression_projection_input_type_UI"]] <- renderUI({
+ req(input[["expression_analysis_mode"]])
+ if ( input[["expression_analysis_mode"]] == "Gene(s)" ) {
+ selectizeInput(
+ 'expression_genes_input',
+ label = 'Gene(s)',
+ choices = data.table::as.data.table(data.frame("Genes" = getGeneNames())),
+ multiple = TRUE,
+ options = list(
+ create = TRUE
+ )
+ )
+ } else if ( input[["expression_analysis_mode"]] == "Gene set" ) {
+ selectizeInput(
+ 'expression_select_gene_set',
+ label = 'Gene set',
+ choices = data.table::as.data.table(
+ data.frame("Gene sets" = c("-", msigdbr:::msigdbr_genesets$gs_name))
+ ),
+ multiple = FALSE
+ )
+ }
+})
diff --git a/inst/shiny/v1.3/gene_expression/UI_projection_point_border.R b/inst/shiny/v1.3/gene_expression/UI_projection_point_border.R
new file mode 100644
index 0000000..a2750b8
--- /dev/null
+++ b/inst/shiny/v1.3/gene_expression/UI_projection_point_border.R
@@ -0,0 +1,17 @@
+##----------------------------------------------------------------------------##
+## UI elements with switch to draw border around cells.
+##----------------------------------------------------------------------------##
+output[["expression_projection_point_border_UI"]] <- renderUI({
+ shinyWidgets::awesomeCheckbox(
+ inputId = "expression_projection_point_border",
+ label = "Draw border around cells",
+ value = FALSE
+ )
+})
+
+## make sure elements are loaded even though the box is collapsed
+outputOptions(
+ output,
+ "expression_projection_point_border_UI",
+ suspendWhenHidden = FALSE
+)
diff --git a/inst/shiny/v1.3/gene_expression/UI_projection_scales.R b/inst/shiny/v1.3/gene_expression/UI_projection_scales.R
new file mode 100644
index 0000000..78779d0
--- /dev/null
+++ b/inst/shiny/v1.3/gene_expression/UI_projection_scales.R
@@ -0,0 +1,58 @@
+##----------------------------------------------------------------------------##
+## UI elements to set X and Y scales in plot. Separate element because it
+## requires user input from other UI elements.
+##----------------------------------------------------------------------------##
+output[["expression_projection_scales_UI"]] <- renderUI({
+ req(input[["expression_projection_to_display"]])
+ if (
+ is.null(input[["expression_projection_to_display"]]) ||
+ is.na(input[["expression_projection_to_display"]])
+ ) {
+ projection_to_display <- availableProjections()[1]
+ } else {
+ projection_to_display <- input[["expression_projection_to_display"]]
+ }
+ ## check if projection or trajectory should be shown
+ ## ... projection
+ if ( input[["expression_projection_to_display"]] %in% availableProjections() ) {
+ XYranges <- getXYranges(getProjection(input[["expression_projection_to_display"]]))
+ ## ... trajectory
+ } else {
+ ## split selection into method and name
+ selection <- strsplit(input[["expression_projection_to_display"]], split = ' // ')[[1]]
+ ## check if method and name exist and don't proceed if not
+ req(
+ selection[1] %in% getMethodsForTrajectories(),
+ selection[2] %in% getNamesOfTrajectories(selection[1])
+ )
+ ## collect trajectory data
+ trajectory_data <- getTrajectory(
+ selection[1],
+ selection[2]
+ )
+ XYranges <- getXYranges(trajectory_data[["meta"]])
+ }
+ tagList(
+ sliderInput(
+ "expression_projection_scale_x_manual_range",
+ label = "Range of X axis",
+ min = XYranges$x$min,
+ max = XYranges$x$max,
+ value = c(XYranges$x$min, XYranges$x$max)
+ ),
+ sliderInput(
+ "expression_projection_scale_y_manual_range",
+ label = "Range of Y axis",
+ min = XYranges$y$min,
+ max = XYranges$y$max,
+ value = c(XYranges$y$min, XYranges$y$max)
+ )
+ )
+})
+
+## make sure elements are loaded even though the box is collapsed
+outputOptions(
+ output,
+ "expression_projection_scales_UI",
+ suspendWhenHidden = FALSE
+)
diff --git a/inst/shiny/v1.3/gene_expression/UI_projection_select_projection.R b/inst/shiny/v1.3/gene_expression/UI_projection_select_projection.R
new file mode 100644
index 0000000..cc2c0fb
--- /dev/null
+++ b/inst/shiny/v1.3/gene_expression/UI_projection_select_projection.R
@@ -0,0 +1,15 @@
+##----------------------------------------------------------------------------##
+## UI elements to choose which projection/trajectory to show.
+##----------------------------------------------------------------------------##
+output[["expression_projection_select_projection_UI"]] <- renderUI({
+ available_projections <- availableProjections()
+ available_trajectories <- available_trajectories()
+ selectInput(
+ "expression_projection_to_display",
+ label = "Projection",
+ choices = list(
+ "Projections" = as.list(available_projections),
+ "Trajectories" = as.list(available_trajectories)
+ )
+ )
+})
diff --git a/inst/shiny/v1.3/gene_expression/table_of_selected_cells.R b/inst/shiny/v1.3/gene_expression/UI_table_of_selected_cells.R
similarity index 82%
rename from inst/shiny/v1.3/gene_expression/table_of_selected_cells.R
rename to inst/shiny/v1.3/gene_expression/UI_table_of_selected_cells.R
index 6bc15b5..3411508 100644
--- a/inst/shiny/v1.3/gene_expression/table_of_selected_cells.R
+++ b/inst/shiny/v1.3/gene_expression/UI_table_of_selected_cells.R
@@ -1,6 +1,4 @@
##----------------------------------------------------------------------------##
-## Tab: Gene (set) expression
-##
## Table for details of selected cells.
##----------------------------------------------------------------------------##
@@ -8,7 +6,6 @@
## UI element with toggle switches (for automatic number formatting and
## coloring) and table.
##----------------------------------------------------------------------------##
-
output[["expression_details_selected_cells_UI"]] <- renderUI({
fluidRow(
cerebroBox(
@@ -40,65 +37,53 @@ output[["expression_details_selected_cells_UI"]] <- renderUI({
##----------------------------------------------------------------------------##
## Table with results.
##----------------------------------------------------------------------------##
-
-output[["expression_details_selected_cells"]] <- DT::renderDataTable(server = FALSE, {
-
- ## don't proceed without these inputs
+output[["expression_details_selected_cells"]] <- DT::renderDataTable({
req(
- input[["expression_projection_to_display"]],
- input[["expression_projection_point_size"]],
- input[["expression_projection_point_opacity"]],
- input[["expression_projection_color_scale"]],
- input[["expression_projection_color_scale_range"]],
- input[["expression_projection_scale_x_manual_range"]],
- input[["expression_projection_scale_y_manual_range"]],
- gene_expression_plot_data()
+ expression_projection_data(),
+ expression_projection_coordinates(),
+ expression_projection_expression_levels()
)
-
+ selected_cells <- expression_projection_selected_cells()
## check selection
- ## ... selection has not been made or there is not cell in it
- if (
- is.null(plotly::event_data("plotly_selected", source = "expression_projection")) ||
- length(plotly::event_data("plotly_selected", source = "expression_projection")) == 0
- ) {
-
+ ## ... selection has not been made or there is no cell in it
+ if ( is.null(selected_cells) ) {
## prepare empty table
getMetaData() %>%
dplyr::slice(0) %>%
prepareEmptyTable()
-
## ... selection has been made and at least 1 cell is in it
} else {
-
- ## get info of selected cells and create identifier from X-Y coordinates
- selected_cells <- plotly::event_data("plotly_selected", source = "expression_projection") %>%
- dplyr::mutate(identifier = paste0(x, '-', y))
-
+ cells_df <- bind_cols(
+ expression_projection_coordinates(),
+ expression_projection_data()
+ )
+ if (is.list(expression_projection_expression_levels())) {
+ cells_df$level <- do.call(cbind, expression_projection_expression_levels()) %>%
+ Matrix::rowMeans()
+ } else {
+ cells_df$level <- expression_projection_expression_levels()
+ }
## filter out non-selected cells with X-Y identifier and select some meta
## data
- table <- gene_expression_plot_data() %>%
+ cells_df <- cells_df %>%
dplyr::rename(X1 = 1, X2 = 2) %>%
dplyr::mutate(identifier = paste0(X1, '-', X2)) %>%
dplyr::filter(identifier %in% selected_cells$identifier) %>%
dplyr::select(-c(X1, X2, identifier)) %>%
dplyr::rename(expression_level = level) %>%
dplyr::select(cell_barcode, expression_level, everything())
-
## check how many cells are left after filtering
## ... no cells are left
- if ( nrow(table) == 0 ) {
-
+ if ( nrow(cells_df) == 0 ) {
## prepare empty table
getMetaData() %>%
dplyr::slice(0) %>%
prepareEmptyTable()
-
## ... at least 1 cell is left
} else {
-
## prepare proper table
prettifyTable(
- table,
+ cells_df,
filter = list(position = "top", clear = TRUE),
dom = "Brtlip",
show_buttons = TRUE,
@@ -114,7 +99,6 @@ output[["expression_details_selected_cells"]] <- DT::renderDataTable(server = FA
##----------------------------------------------------------------------------##
## Info box that gets shown when pressing the "info" button.
##----------------------------------------------------------------------------##
-
observeEvent(input[["expression_details_selected_cells_info"]], {
showModal(
modalDialog(
@@ -130,7 +114,6 @@ observeEvent(input[["expression_details_selected_cells_info"]], {
##----------------------------------------------------------------------------##
## Text in info box.
##----------------------------------------------------------------------------##
-
expression_details_selected_cells_info <- list(
title = "Details of selected cells",
text = HTML("
diff --git a/inst/shiny/v1.3/gene_expression/event_projection_export_plot.R b/inst/shiny/v1.3/gene_expression/event_projection_export_plot.R
new file mode 100644
index 0000000..06fb0ad
--- /dev/null
+++ b/inst/shiny/v1.3/gene_expression/event_projection_export_plot.R
@@ -0,0 +1,138 @@
+##----------------------------------------------------------------------------##
+## Export projection plot to PDF when pressing the "export to PDF" button.
+##----------------------------------------------------------------------------##
+observeEvent(input[["expression_projection_export"]], {
+ req(expression_projection_data_to_plot())
+ ## assign input to variables
+ input_data <- expression_projection_data_to_plot()
+ cells_df <- input_data[['cells_df']]
+ coordinates <- input_data[['coordinates']]
+ expression_levels <- input_data[['expression_levels']]
+ cells_df$level <- expression_levels
+ cells_df <- bind_cols(coordinates, cells_df)
+ plot_parameters <- input_data[['plot_parameters']]
+ color_settings <- input_data[['color_settings']]
+ trajectory <- input_data[['trajectory']]
+ ## open dialog to select where plot should be saved and how the file should
+ ## be named
+ shinyFiles::shinyFileSave(
+ input,
+ id = "expression_projection_export",
+ roots = available_storage_volumes,
+ session = session,
+ restrictions = system.file(package = "base")
+ )
+ ## retrieve info from dialog
+ save_file_input <- shinyFiles::parseSavePath(
+ available_storage_volumes,
+ input[["expression_projection_export"]]
+ )
+ ## only proceed if a path has been provided
+ req(nrow(save_file_input) > 0)
+ ## make ggplot2 functions available
+ require("ggplot2")
+ ## extract specified file path
+ save_file_path <- as.character(save_file_input$datapath[1])
+ ## bring cells in order, either random or highest expression on top
+ if (plot_parameters[['plot_order']]=='Random') {
+ cell_order <- sample(1:length(expression_levels))
+ cells_df <- cells_df[cell_order,]
+ } else if (plot_parameters[['plot_order']]=='Highest expression on top') {
+ cell_order <- order(expression_levels)
+ cells_df <- cells_df[cell_order,]
+ }
+ ##
+ if (
+ is.list(expression_levels) ||
+ ncol(coordinates) == 3
+ ) {
+ shinyWidgets::sendSweetAlert(
+ session = session,
+ title = "Sorry!",
+ text = HTML("
+ The plot could not be exported to a PDF file.
+ Possible reasons:
+
+ - You have selected a 3D dimensional reduction.
+ - Expression is shown in a separate panel per gene.
+
+ Please use the PNG export button in the top-right corner of the projection instead."
+ ),
+ type = "error",
+ html = TRUE
+ )
+ } else {
+ ## check if projection or trajectory should be shown
+ ## ... projection
+ if ( plot_parameters[["projection"]] %in% availableProjections() ) {
+ ## ... separate panels requested and "gene" column present
+ if (
+ input[["expression_projection_genes_in_separate_panels"]] == TRUE &&
+ "gene" %in% colnames(cells_df) == TRUE
+ ) {
+ ## prepare plot
+ plot <- pltExpProj2DMultPanExp(
+ df = cells_df,
+ point_size = plot_parameters[["point_size"]],
+ point_opacity = plot_parameters[["point_opacity"]],
+ point_border = plot_parameters[["draw_border"]],
+ color_scale = color_settings[["color_scale"]],
+ color_range = color_settings[["color_range"]],
+ x_range = plot_parameters[["x_range"]],
+ y_range = plot_parameters[["y_range"]]
+ )
+ } else {
+ ## prepare plot
+ plot <- pltExpProj2DSglPanExp(
+ df = cells_df,
+ point_size = plot_parameters[["point_size"]],
+ point_opacity = plot_parameters[["point_opacity"]],
+ point_border = plot_parameters[["draw_border"]],
+ color_scale = color_settings[["color_scale"]],
+ color_range = color_settings[["color_range"]],
+ x_range = plot_parameters[["x_range"]],
+ y_range = plot_parameters[["y_range"]]
+ )
+ }
+ ## ... trajectory
+ } else {
+ ## prepare plot
+ plot <- pltExpTrj2DSglPanExp(
+ df = cells_df,
+ trajectory_edges = trajectory[["edges"]],
+ point_size = plot_parameters[["point_size"]],
+ point_opacity = plot_parameters[["point_opacity"]],
+ point_border = plot_parameters[["draw_border"]],
+ color_scale = color_settings[["color_scale"]],
+ color_range = color_settings[["color_range"]],
+ x_range = plot_parameters[["x_range"]],
+ y_range = plot_parameters[["y_range"]]
+ )
+ }
+ ## plot must be a ggplot object, otherwise don't proceed
+ req(is.ggplot(plot))
+ ## save plot
+ pdf(NULL)
+ ggsave(save_file_path, plot, height = 8, width = 11)
+ ## check if file was succesfully saved
+ ## ... successful
+ if ( file.exists(save_file_path) ) {
+ ## give positive message
+ shinyWidgets::sendSweetAlert(
+ session = session,
+ title = "Success!",
+ text = paste0("Plot saved successfully as: ", save_file_path),
+ type = "success"
+ )
+ ## ... failed
+ } else {
+ ## give negative message
+ shinyWidgets::sendSweetAlert(
+ session = session,
+ title = "Error!",
+ text = "Sorry, it seems something went wrong...",
+ type = "error"
+ )
+ }
+ }
+})
diff --git a/inst/shiny/v1.3/gene_expression/event_projection_update_plot.R b/inst/shiny/v1.3/gene_expression/event_projection_update_plot.R
new file mode 100644
index 0000000..e525c1d
--- /dev/null
+++ b/inst/shiny/v1.3/gene_expression/event_projection_update_plot.R
@@ -0,0 +1,9 @@
+##----------------------------------------------------------------------------##
+## Update projection plot when expression_projection_data_to_plot() changes.
+##----------------------------------------------------------------------------##
+observeEvent(expression_projection_data_to_plot(), {
+ req(expression_projection_data_to_plot())
+ # message('--> trigger update plot')
+ expression_projection_parameters_other[['reset_axes']] <- FALSE
+ expression_projection_update_plot(expression_projection_data_to_plot())
+})
diff --git a/inst/shiny/v1.3/gene_expression/expression_in_selected_cells.R b/inst/shiny/v1.3/gene_expression/expression_in_selected_cells.R
deleted file mode 100644
index b61eaf3..0000000
--- a/inst/shiny/v1.3/gene_expression/expression_in_selected_cells.R
+++ /dev/null
@@ -1,151 +0,0 @@
-##----------------------------------------------------------------------------##
-## Tab: Gene (set) expression
-##
-## Expression in selected cells.
-##----------------------------------------------------------------------------##
-
-##----------------------------------------------------------------------------##
-## UI element for plot.
-##----------------------------------------------------------------------------##
-
-output[["expression_in_selected_cells_UI"]] <- renderUI({
- fluidRow(
- cerebroBox(
- title = tagList(
- boxTitle("Expression levels in selected cells"),
- cerebroInfoButton("expression_in_selected_cells_info")
- ),
- plotly::plotlyOutput("expression_in_selected_cells")
- )
- )
-})
-
-##----------------------------------------------------------------------------##
-## Violin/box plot.
-##----------------------------------------------------------------------------##
-
-output[["expression_in_selected_cells"]] <- plotly::renderPlotly({
-
- ## don't proceed without these inputs
- req(
- input[["expression_projection_to_display"]],
- input[["expression_projection_point_size"]],
- input[["expression_projection_point_opacity"]],
- input[["expression_projection_color_scale"]],
- input[["expression_projection_color_scale_range"]],
- input[["expression_projection_scale_x_manual_range"]],
- input[["expression_projection_scale_y_manual_range"]],
- gene_expression_plot_data()
- )
-
- ## check if user requested to show expression in separate panels
- ## ... separate panels requested and "gene" column present (which means
- ## expression was actually split by gene)
- if (
- input[["expression_projection_show_genes_in_separate_panels"]] == TRUE &&
- "gene" %in% colnames(gene_expression_plot_data()) == TRUE
- ) {
-
- ## don't plot anything because data is not present
- ## even if I merged all meta data in the data frame, it wouldn't be correct
- ## because cells are plotted once per gene
-
- ## ...
- } else {
-
- ## prepare data to be plotted
- ## ... if no selection was made or no cells are in selection
- if (
- is.null(plotly::event_data("plotly_selected", source = "expression_projection")) |
- length(plotly::event_data("plotly_selected", source = "expression_projection")) == 0
- ) {
-
- ## assign all cells to "not selected" group
- cells_df <- gene_expression_plot_data() %>%
- dplyr::mutate(group = 'not selected')
-
- ## ... if at least 1 cell was selected
- } else {
-
- ## get names of selected cells
- selected_cells <- plotly::event_data("plotly_selected", source = "expression_projection") %>%
- dplyr::mutate(identifier = paste0(x, '-', y))
-
- ## - get data to plot
- ## - assign cells to either "selected" or "not selected" based on their name
- ## - keep only relevant columns
- cells_df <- gene_expression_plot_data() %>%
- dplyr::rename(X1 = 1, X2 = 2) %>%
- dplyr::mutate(
- identifier = paste0(X1, '-', X2),
- group = ifelse(identifier %in% selected_cells$identifier, 'selected', 'not selected'),
- group = factor(group, levels = c('selected', 'not selected'))
- ) %>%
- dplyr::select(group, level)
- }
-
- ## prepare plot
- plotly::plot_ly(
- cells_df,
- x = ~group,
- y = ~level,
- type = "violin",
- box = list(
- visible = TRUE
- ),
- meanline = list(
- visible = TRUE
- ),
- color = ~group,
- colors = setNames(c('#e74c3c','#7f8c8d'),c('selected', 'not selected')),
- source = "subset",
- showlegend = FALSE,
- hoverinfo = "y",
- marker = list(
- size = 5
- )
- ) %>%
- plotly::layout(
- title = "",
- xaxis = list(
- title = "",
- mirror = TRUE,
- showline = TRUE
- ),
- yaxis = list(
- title = "Expression level",
- range = c(0, max(cells_df$level, na.rm = TRUE) * 1.2),
- hoverformat = ".2f",
- mirror = TRUE,
- showline = TRUE
- ),
- dragmode = "select",
- hovermode = "compare"
- )
- }
-})
-
-##----------------------------------------------------------------------------##
-## Info box that gets shown when pressing the "info" button.
-##----------------------------------------------------------------------------##
-
-observeEvent(input[["expression_in_selected_cells_info"]], {
- showModal(
- modalDialog(
- expression_in_selected_cells_info$text,
- title = expression_in_selected_cells_info$title,
- easyClose = TRUE,
- footer = NULL,
- size = "l"
- )
- )
-})
-
-##----------------------------------------------------------------------------##
-## Text in info box.
-##----------------------------------------------------------------------------##
-
-expression_in_selected_cells_info <- list(
- title = "Expression levels in selected cells",
- text = p("This plot shows the log-normalised expression of selected genes for cells grouped by whether they were selected using the box or lasso selection tool. If more than 1 gene was provided, this reflects the average across all cells of each sample.")
-)
diff --git a/inst/shiny/v1.3/gene_expression/func_pltExpProj2DMultPanExp.R b/inst/shiny/v1.3/gene_expression/func_pltExpProj2DMultPanExp.R
new file mode 100644
index 0000000..bc4ba8e
--- /dev/null
+++ b/inst/shiny/v1.3/gene_expression/func_pltExpProj2DMultPanExp.R
@@ -0,0 +1,31 @@
+##----------------------------------------------------------------------------##
+## Function to plot expression in multiple panels in 2D (for export).
+##----------------------------------------------------------------------------##
+pltExpProj2DMultPanExp <- function(
+ df,
+ point_size,
+ point_opacity,
+ point_border,
+ color_scale,
+ color_range,
+ x_range,
+ y_range
+) {
+ ##
+ plot <- plotExpressionSinglePanel2DExport(
+ df = df,
+ point_size = point_size,
+ point_opacity = point_opacity,
+ point_border = point_border,
+ color_scale = color_scale,
+ color_range = color_range,
+ x_range = x_range,
+ y_range = y_range
+ )
+ ## decide how many panel columns should be used
+ ## below 6 panels, use 2 columns, from 6-8 panels use 3 columns
+ number_of_genes <- length(unique(df$gene))
+ number_of_panel_columns <- ifelse(number_of_genes < 6, 2, 3)
+ plot <- plot + facet_wrap(~gene, ncol = number_of_panel_columns)
+ return(plot)
+}
diff --git a/inst/shiny/v1.3/gene_expression/func_pltExpProj2DSglPanExp.R b/inst/shiny/v1.3/gene_expression/func_pltExpProj2DSglPanExp.R
new file mode 100644
index 0000000..0a5fc04
--- /dev/null
+++ b/inst/shiny/v1.3/gene_expression/func_pltExpProj2DSglPanExp.R
@@ -0,0 +1,65 @@
+##----------------------------------------------------------------------------##
+## Function to plot expression in single panel in 2D (for export).
+##----------------------------------------------------------------------------##
+pltExpProj2DSglPanExp <- function(
+ df,
+ point_size,
+ point_opacity,
+ point_border,
+ color_scale,
+ color_range,
+ x_range,
+ y_range
+) {
+ ##
+ if ( point_border == TRUE ) {
+ stroke <- 0.2
+ } else {
+ stroke <- 0
+ }
+ ## prepare plot
+ plot <- ggplot(
+ df,
+ aes_q(
+ x = as.name(colnames(df)[1]),
+ y = as.name(colnames(df)[2]),
+ fill = as.name("level")
+ )
+ ) +
+ geom_point(
+ shape = 21,
+ size = point_size/3,
+ stroke = stroke,
+ color = "#c4c4c4",
+ alpha = point_opacity
+ ) +
+ lims(x = x_range, y = y_range) +
+ theme_bw()
+ ## check if selected color scale
+ ## ... selected color scale is "Viridis"
+ if ( tolower(color_scale) == 'viridis' ) {
+ ## add color scale to plot
+ plot <- plot +
+ viridis::scale_fill_viridis(
+ option = "viridis",
+ limits = color_range,
+ oob = scales::squish,
+ direction = -1,
+ name = "Log-normalised\nexpression",
+ guide = guide_colorbar(frame.colour = "black", ticks.colour = "black")
+ )
+ ## ... selected color scale is anything else than "Viridis"
+ } else {
+ ## add color scale to plot
+ plot <- plot +
+ scale_fill_distiller(
+ palette = color_scale,
+ limits = color_range,
+ oob = scales::squish,
+ direction = 1,
+ name = "Log-normalised\nexpression",
+ guide = guide_colorbar(frame.colour = "black", ticks.colour = "black")
+ )
+ }
+ return(plot)
+}
\ No newline at end of file
diff --git a/inst/shiny/v1.3/gene_expression/func_pltExpTrj2DSglPanExp.R b/inst/shiny/v1.3/gene_expression/func_pltExpTrj2DSglPanExp.R
new file mode 100644
index 0000000..0c197fc
--- /dev/null
+++ b/inst/shiny/v1.3/gene_expression/func_pltExpTrj2DSglPanExp.R
@@ -0,0 +1,75 @@
+##----------------------------------------------------------------------------##
+## Function to plot expression in trajectory (for export).
+##----------------------------------------------------------------------------##
+pltExpTrj2DSglPanExp <- function(
+ df,
+ trajectory_edges,
+ point_size,
+ point_opacity,
+ point_border,
+ color_scale,
+ color_range,
+ x_range,
+ y_range
+) {
+ ##
+ if ( point_border == TRUE ) {
+ stroke <- 0.2
+ } else {
+ stroke <- 0
+ }
+ ## start building the plot
+ plot <- ggplot() +
+ geom_point(
+ data = df,
+ aes_string(
+ x = colnames(df)[1],
+ y = colnames(df)[2],
+ fill = as.name("level")
+ ),
+ shape = 21,
+ size = point_size/3,
+ stroke = stroke,
+ color = "#c4c4c4",
+ alpha = point_opacity
+ ) +
+ geom_segment(
+ data = trajectory_edges,
+ aes(
+ source_dim_1,
+ source_dim_2,
+ xend = target_dim_1,
+ yend = target_dim_2
+ ),
+ size = 0.75, linetype = "solid", na.rm = TRUE
+ ) +
+ theme_bw()
+ ## check if selected color scale
+ ## ... selected color scale is "Viridis"
+ if ( tolower(color_scale) == 'viridis' ) {
+ ## add color scale to plot
+ plot <- plot +
+ viridis::scale_fill_viridis(
+ option = "viridis",
+ limits = color_range,
+ oob = scales::squish,
+ direction = -1,
+ name = "Log-normalised\nexpression",
+ guide = guide_colorbar(frame.colour = "black", ticks.colour = "black")
+ )
+
+ ## ... selected color scale is anything else than "Viridis"
+ } else {
+ ## add color scale to plot
+ plot <- plot +
+ scale_fill_distiller(
+ palette = color_scale,
+ limits = color_range,
+ oob = scales::squish,
+ direction = 1,
+ name = "Log-normalised\nexpression",
+ guide = guide_colorbar(frame.colour = "black", ticks.colour = "black")
+ )
+ }
+ return(plot)
+}
\ No newline at end of file
diff --git a/inst/shiny/v1.3/gene_expression/func_projection_update_plot.R b/inst/shiny/v1.3/gene_expression/func_projection_update_plot.R
new file mode 100644
index 0000000..62765e7
--- /dev/null
+++ b/inst/shiny/v1.3/gene_expression/func_projection_update_plot.R
@@ -0,0 +1,157 @@
+## function to be executed to update figure
+expression_projection_update_plot <- function(input) {
+ # process input parameters and give to JavaScript function to update plot
+ # message('update plot')
+ coordinates <- input[['coordinates']]
+ reset_axes <- input[['reset_axes']]
+ expression_levels <- input[['expression_levels']]
+ plot_parameters <- input[['plot_parameters']]
+ color_settings <- input[['color_settings']]
+ hover_info <- input[['hover_info']]
+ trajectory <- input[['trajectory']]
+ separate_panels <- input[['separate_panels']]
+ ## sort cells based on expression (if applicable)
+ if (
+ plot_parameters[['plot_order']]=='Highest expression on top' &&
+ separate_panels == FALSE
+ ) {
+ cell_order <- order(expression_levels)
+ coordinates <- coordinates[cell_order,]
+ hover_info <- hover_info[cell_order]
+ if (is.list(expression_levels)) {
+ for (i in 1:length(expression_levels)) {
+ expression_levels[[i]] <- expression_levels[[i]][cell_order]
+ }
+ } else {
+ expression_levels <- expression_levels[cell_order]
+ }
+ }
+ ## define output_data
+ output_data <- list(
+ x = coordinates[[1]],
+ y = coordinates[[2]],
+ color = expression_levels,
+ point_size = plot_parameters[["point_size"]],
+ point_opacity = plot_parameters[["point_opacity"]],
+ point_line = list(),
+ x_range = plot_parameters[["x_range"]],
+ y_range = plot_parameters[["y_range"]],
+ reset_axes = reset_axes
+ )
+ if ( plot_parameters[["draw_border"]] ) {
+ output_data[['point_line']] <- list(
+ color = "rgb(196,196,196)",
+ width = 1
+ )
+ }
+ ## define output_color
+ output_color <- list(
+ scale = color_settings[['color_scale']],
+ range = color_settings[['color_range']]
+ )
+ ## prepare hover info
+ output_hover <- list(
+ hoverinfo = ifelse(plot_parameters[["hover_info"]], 'text', 'skip'),
+ text = 'empty'
+ )
+ if ( plot_parameters[["hover_info"]] ) {
+ output_hover[['text']] <- unname(hover_info)
+ }
+ ## process trajectory data
+ trajectory_lines <- list()
+ if (plot_parameters[['is_trajectory']]) {
+ ## fix order of trajectory meta data if cells are sorted by expression
+ if (
+ plot_parameters[['plot_order']]=='Highest expression on top' &&
+ separate_panels == FALSE
+ ) {
+ trajectory[['meta']] <- trajectory[['meta']][cell_order,]
+ }
+ ## add additional info to hover info
+ if (plot_parameters[['hover_info']]) {
+ output_hover[['text']] <- glue::glue(
+ "{output_hover[['text']]}
",
+ "State: {trajectory[['meta']]$state}
",
+ "Pseudotime: {formatC(trajectory[['meta']]$pseudotime, format = 'f', digits = 2)}"
+ )
+ }
+ ## convert edges of trajectory into list format to plot with plotly
+ trajectory_edges <- trajectory[['edges']]
+ for (i in 1:nrow(trajectory_edges) ) {
+ line = list(
+ type = "line",
+ line = list(color = "black", width = 1),
+ xref = "x",
+ yref = "y",
+ x0 = trajectory_edges$source_dim_1[i],
+ y0 = trajectory_edges$source_dim_2[i],
+ x1 = trajectory_edges$target_dim_1[i],
+ y1 = trajectory_edges$target_dim_2[i]
+ )
+ trajectory_lines <- c(trajectory_lines, list(line))
+ }
+ }
+ ## print details for debugging purposes
+ # if (
+ # exists('mode_debugging') &&
+ # mode_debugging == TRUE &&
+ # length(hover_info) > 1
+ # ) {
+ # random_cells <- c(10, 51, 79)
+ # for (i in random_cells) {
+ # current_cell <- gsub(hover_info[i], pattern = 'Cell: ', replacement = '')
+ # current_cell <- gsub(current_cell, pattern = '
.*', replacement = '')
+ # current_cell <- unname(current_cell)
+ # coordinates_shown <- coordinates[i,]
+ # hover_shown <- hover_info[i]
+ # expression_shown <- expression_levels[i]
+ # position_of_current_cell_in_original_data <- which(getMetaData()$cell_barcode == current_cell)
+ # coordinates_should <- data_set()$projections[[expression_projection_parameters_plot()$projection]][position_of_current_cell_in_original_data,]
+ # expression_should <- unname(getMeanExpressionForCells(
+ # cells = c(current_cell),
+ # genes = expression_selected_genes()$genes_to_display_present
+ # ))
+ # if (is.na(expression_should)) {
+ # expression_should <- 0
+ # }
+ # message(
+ # glue::glue(
+ # '{current_cell}: ',
+ # 'coords. {round(coordinates_shown[1], digits=2)}/{round(coordinates_should[1], digits=2)} // ',
+ # '{round(coordinates_shown[2], digits=2)}/{round(coordinates_should[2], digits=2)}, ',
+ # 'expr. {round(expression_shown, digits=2)}/{round(expression_should, digits=2)}'
+ # )
+ # )
+ # }
+ # }
+ ## call JavaScript functions to update plot
+ if (
+ plot_parameters[['n_dimensions']] == 2 &&
+ is.list(input[['expression_levels']]) == FALSE
+ ) {
+ shinyjs::js$expressionProjectionUpdatePlot2D(
+ output_data,
+ output_hover,
+ output_color,
+ trajectory_lines
+ )
+ } else if (
+ plot_parameters[['n_dimensions']] == 2 &&
+ separate_panels == TRUE &&
+ is.list(input[['expression_levels']]) == TRUE
+ ) {
+ shinyjs::js$expressionProjectionUpdatePlot2DMultiPanel(
+ output_data,
+ output_hover,
+ output_color,
+ trajectory_lines
+ )
+ } else if ( plot_parameters[['n_dimensions']] == 3 ) {
+ output_data[['z']] <- coordinates[[3]]
+ shinyjs::js$expressionProjectionUpdatePlot3D(
+ output_data,
+ output_hover,
+ output_color
+ )
+ }
+}
diff --git a/inst/shiny/v1.3/gene_expression/js_projection_update_plot.js b/inst/shiny/v1.3/gene_expression/js_projection_update_plot.js
new file mode 100644
index 0000000..8c0d990
--- /dev/null
+++ b/inst/shiny/v1.3/gene_expression/js_projection_update_plot.js
@@ -0,0 +1,310 @@
+// layout for 2D projections in a single panel
+const expression_projection_layout_2D = {
+ uirevision: 'true',
+ hovermode: 'closest',
+ margin: {
+ l: 50,
+ r: 50,
+ b: 50,
+ t: 50,
+ pad: 4
+ },
+ xaxis: {
+ autorange: true,
+ mirror: true,
+ showline: true,
+ zeroline: false,
+ range: []
+ },
+ yaxis: {
+ autorange: true,
+ mirror: true,
+ showline: true,
+ zeroline: false,
+ range: []
+ },
+ hoverlabel: {
+ font: {
+ size: 11
+ },
+ bgcolor: 'lightgrey',
+ align: 'left'
+ },
+ shapes: []
+};
+
+// layout for 2D projections with multiple panels
+const expression_projection_layout_2D_multi_panel = {
+ uirevision: 'true',
+ hovermode: 'closest',
+ margin: {
+ l: 50,
+ r: 50,
+ b: 50,
+ t: 50,
+ pad: 4
+ },
+ hoverlabel: {
+ font: {
+ size: 11
+ },
+ bgcolor: 'lightgrey',
+ align: 'left'
+ },
+ shapes: []
+};
+
+// layout for 3D projections
+const expression_projection_layout_3D = {
+ uirevision: 'true',
+ hovermode: 'closest',
+ margin: {
+ l: 50,
+ r: 50,
+ b: 50,
+ t: 50,
+ pad: 4
+ },
+ scene: {
+ xaxis: {
+ autorange: true,
+ mirror: true,
+ showline: true,
+ zeroline: false,
+ range: []
+ },
+ yaxis: {
+ autorange: true,
+ mirror: true,
+ showline: true,
+ zeroline: false,
+ range: []
+ },
+ zaxis: {
+ autorange: true,
+ mirror: true,
+ showline: true,
+ zeroline: false
+ },
+ },
+ hoverlabel: {
+ font: {
+ size: 11
+ },
+ bgcolor: 'lightgrey',
+ align: 'left'
+ }
+};
+
+// default structure of input data
+const expression_projection_default_params = {
+ data: {
+ x: [],
+ y: [],
+ z: [],
+ color: [],
+ size: '',
+ opacity: '',
+ line: {},
+ x_range: [],
+ y_range: [],
+ reset_axes: false
+ },
+ hover: {
+ hoverinfo: '',
+ text: []
+ },
+ color: {
+ scale: '',
+ range: [0, 1]
+ },
+ trajectory: []
+}
+
+// update 2D projection with single panel
+shinyjs.expressionProjectionUpdatePlot2D = function(params) {
+ params = shinyjs.getParams(params, expression_projection_default_params);
+ const data = [];
+ data.push(
+ {
+ x: params.data.x,
+ y: params.data.y,
+ mode: 'markers',
+ type: 'scattergl',
+ marker: {
+ size: params.data.point_size,
+ opacity: params.data.point_opacity,
+ line: params.data.point_line,
+ color: params.data.color,
+ colorscale: params.color.scale,
+ reversescale: true,
+ cauto: false,
+ cmin: params.color.range[0],
+ cmax: params.color.range[1],
+ colorbar: {
+ title: {
+ text: 'Expression',
+ ticks: 'outside',
+ outlinewidth: 1,
+ outlinecolor: 'black'
+ }
+ }
+ },
+ hoverinfo: params.hover.hoverinfo,
+ text: params.hover.text,
+ showlegend: false
+ }
+ );
+ const layout_here = Object.assign(expression_projection_layout_2D);
+ if (params.data.reset_axes) {
+ layout_here.xaxis['autorange'] = true;
+ layout_here.yaxis['autorange'] = true;
+ } else {
+ layout_here.xaxis['autorange'] = false;
+ layout_here.xaxis['range'] = params.data.x_range;
+ layout_here.yaxis['autorange'] = false;
+ layout_here.yaxis['range'] = params.data.y_range;
+ }
+ layout_here.shapes = params.trajectory;
+ Plotly.react('expression_projection', data, layout_here);
+}
+
+// update 2D projection with multiple panels
+shinyjs.expressionProjectionUpdatePlot2DMultiPanel = function(params) {
+ params = shinyjs.getParams(params, expression_projection_default_params);
+ if (Array.isArray(params.data.color)) {
+ return null;
+ }
+ const layout_here = Object.assign(expression_projection_layout_2D_multi_panel);
+ layout_here.shapes = params.trajectory;
+ const number_of_genes = Object.keys(params.data.color).length;
+ let n_rows = 1;
+ let n_cols = 1;
+ if (number_of_genes == 2) {
+ n_rows = 1;
+ n_cols = 2;
+ } else if (number_of_genes <= 4) {
+ n_rows = 2;
+ n_cols = 2;
+ } else if (number_of_genes <= 6) {
+ n_rows = 2;
+ n_cols = 3;
+ } else if (number_of_genes <= 9) {
+ n_rows = 3;
+ n_cols = 3;
+ }
+ layout_here.grid = {rows: n_rows, columns: n_cols, pattern: 'independent'};
+ layout_here.annotations = [];
+ const data = [];
+ Object.keys(params.data.color).forEach(function(gene, index) {
+ const x_axis = index===0 ? 'xaxis' : `xaxis${index+1}`;
+ const y_axis = index===0 ? 'yaxis' : `yaxis${index+1}`;
+ const x_anchor = `x${index+1}`;
+ const y_anchor = `y${index+1}`;
+ // create trace and add to data array
+ data.push(
+ {
+ x: params.data.x,
+ y: params.data.y,
+ xaxis: x_anchor,
+ yaxis: y_anchor,
+ mode: 'markers',
+ type: 'scattergl',
+ marker: {
+ size: params.data.point_size,
+ opacity: params.data.point_opacity,
+ line: params.data.point_line,
+ color: params.data.color[gene],
+ colorscale: params.color.scale,
+ reversescale: true,
+ cauto: false,
+ cmin: params.color.range[0],
+ cmax: params.color.range[1]
+ },
+ hoverinfo: params.hover.hoverinfo,
+ text: params.hover.text,
+ showlegend: false
+ }
+ );
+ // add colorbar only to first trace
+ if (index===0) {
+ console.log('add colorbar');
+ data[index].marker.colorbar = {
+ title: {
+ text: 'Expression',
+ ticks: 'outside',
+ outlinewidth: 1,
+ outlinecolor: 'black'
+ }
+ }
+ };
+ console.log(data);
+ // add X/Y axis attributes to layout
+ layout_here[x_axis] = {
+ title: gene,
+ autorange: true,
+ mirror: true,
+ showline: true,
+ zeroline: false,
+ range: [],
+ anchor: x_anchor
+ }
+ layout_here[y_axis] = {
+ autorange: true,
+ mirror: true,
+ showline: true,
+ zeroline: false,
+ range: [],
+ anchor: y_anchor
+ }
+ if (params.data.reset_axes) {
+ layout_here[x_axis]['autorange'] = true;
+ layout_here[y_axis]['autorange'] = true;
+ } else {
+ layout_here[x_axis]['autorange'] = false;
+ layout_here[x_axis]['range'] = params.data.x_range;
+ layout_here[y_axis]['autorange'] = false;
+ layout_here[y_axis]['range'] = params.data.y_range;
+ }
+ });
+ // update plot
+ Plotly.react('expression_projection', data, layout_here);
+}
+
+// update 3D projection
+shinyjs.expressionProjectionUpdatePlot3D = function(params) {
+ params = shinyjs.getParams(params, expression_projection_default_params);
+ const data = [];
+ data.push(
+ {
+ x: params.data.x,
+ y: params.data.y,
+ z: params.data.z,
+ mode: 'markers',
+ type: 'scatter3d',
+ marker: {
+ size: params.data.point_size,
+ opacity: params.data.point_opacity,
+ line: params.data.point_line,
+ color: params.data.color,
+ colorscale: params.color.scale,
+ reversescale: true,
+ cauto: false,
+ cmin: params.color.range[0],
+ cmax: params.color.range[1],
+ colorbar: {
+ title: {
+ text: 'Expression',
+ ticks: 'outside',
+ outlinewidth: 1,
+ outlinecolor: 'black'
+ }
+ }
+ },
+ hoverinfo: params.hover.hoverinfo,
+ text: params.hover.text,
+ showlegend: false
+ }
+ );
+ Plotly.react('expression_projection', data, expression_projection_layout_3D);
+}
diff --git a/inst/shiny/v1.3/gene_expression/obj_projection_cells_to_show.R b/inst/shiny/v1.3/gene_expression/obj_projection_cells_to_show.R
new file mode 100644
index 0000000..f0e413a
--- /dev/null
+++ b/inst/shiny/v1.3/gene_expression/obj_projection_cells_to_show.R
@@ -0,0 +1,36 @@
+##----------------------------------------------------------------------------##
+## Indices of cells to show in projection.
+##----------------------------------------------------------------------------##
+expression_projection_cells_to_show <- reactive({
+ req(input[["expression_projection_percentage_cells_to_show"]])
+ # message('--> trigger "expression_projection_cells_to_show"')
+ ## require group filters UI elements and at least 1 group level to be selected
+ for ( i in getGroups() ) {
+ req(input[[paste0("expression_projection_group_filter_", i)]])
+ }
+ pct_cells <- input[["expression_projection_percentage_cells_to_show"]]
+ group_filters <- list()
+ ## store group filters
+ for ( i in getGroups() ) {
+ group_filters[[i]] <- input[[paste0("expression_projection_group_filter_", i)]]
+ }
+ ## get cell meta data
+ cells_df <- getMetaData() %>%
+ dplyr::mutate(row_id = row_number())
+ for ( i in getGroups() ) {
+ ## make sure that group exists in meta data (as column) and that selected
+ ## groups are not NULL, then subset the data frame
+ if ( i %in% colnames(cells_df) ) {
+ cells_df <- cells_df[which(cells_df[[i]] %in% group_filters[[i]] ),]
+ }
+ }
+ cells_df <- cells_df %>%
+ dplyr::select(cell_barcode, row_id)
+ ## randomly remove cells (if necessary)
+ cells_df <- randomlySubsetCells(cells_df, pct_cells)
+ ## put rows in random order
+ cells_df <- cells_df[sample(1:nrow(cells_df)),]
+ cells_to_show <- cells_df$row_id
+# message(str(cells_to_show))
+ return(cells_to_show)
+})
diff --git a/inst/shiny/v1.3/gene_expression/obj_projection_coordinates.R b/inst/shiny/v1.3/gene_expression/obj_projection_coordinates.R
new file mode 100644
index 0000000..a5bc8b3
--- /dev/null
+++ b/inst/shiny/v1.3/gene_expression/obj_projection_coordinates.R
@@ -0,0 +1,28 @@
+##----------------------------------------------------------------------------##
+## Coordinates of cells in projection.
+##----------------------------------------------------------------------------##
+expression_projection_coordinates <- reactive({
+ req(
+ expression_projection_parameters_plot(),
+ expression_projection_cells_to_show()
+ )
+ # message('--> trigger "expression_projection_coordinates"')
+ parameters <- expression_projection_parameters_plot()
+ cells_to_show <- expression_projection_cells_to_show()
+ req(
+ parameters[["projection"]] %in% availableProjections() ||
+ parameters[["projection"]] %in% available_trajectories()
+ )
+ if ( parameters[["projection"]] %in% availableProjections() ) {
+ coordinates <- getProjection(parameters[["projection"]])[cells_to_show,]
+ } else if ( parameters[["projection"]] %in% available_trajectories() ) {
+ selection <- strsplit(parameters[["projection"]], split = ' // ')[[1]]
+ req(
+ selection[1] %in% getMethodsForTrajectories(),
+ selection[2] %in% getNamesOfTrajectories(selection[1])
+ )
+ coordinates <- getTrajectory(selection[1], selection[2])[['meta']][cells_to_show,c(1,2)]
+ }
+# message(str(coordinates))
+ return(coordinates)
+})
diff --git a/inst/shiny/v1.3/gene_expression/obj_projection_data.R b/inst/shiny/v1.3/gene_expression/obj_projection_data.R
new file mode 100644
index 0000000..4d6147f
--- /dev/null
+++ b/inst/shiny/v1.3/gene_expression/obj_projection_data.R
@@ -0,0 +1,10 @@
+##----------------------------------------------------------------------------##
+## Cell meta data and position in projection.
+##----------------------------------------------------------------------------##
+expression_projection_data <- reactive({
+ req(expression_projection_cells_to_show())
+ # message('--> trigger "expression_projection_data"')
+ cells_df <- getMetaData()[expression_projection_cells_to_show(),]
+ # message(str(cells_df))
+ return(cells_df)
+})
diff --git a/inst/shiny/v1.3/gene_expression/obj_projection_data_to_plot.R b/inst/shiny/v1.3/gene_expression/obj_projection_data_to_plot.R
new file mode 100644
index 0000000..a9c27b3
--- /dev/null
+++ b/inst/shiny/v1.3/gene_expression/obj_projection_data_to_plot.R
@@ -0,0 +1,37 @@
+##----------------------------------------------------------------------------##
+## Object that combines all data required for updating projection plot.
+##----------------------------------------------------------------------------##
+expression_projection_data_to_plot_raw <- reactive({
+ req(
+ expression_projection_coordinates(),
+ expression_projection_parameters_plot(),
+ expression_projection_parameters_color(),
+ expression_projection_hover_info(),
+ expression_projection_trajectory(),
+ nrow(expression_projection_coordinates()) == length(isolate(expression_projection_expression_levels())) ||
+ nrow(expression_projection_coordinates()) == length(isolate(expression_projection_expression_levels())[[1]]),
+ nrow(expression_projection_coordinates()) == length(expression_projection_hover_info()) || expression_projection_hover_info() == "none",
+ !is.null(input[["expression_projection_genes_in_separate_panels"]])
+ )
+ # message('--> trigger "expression_projection_data_to_plot"')
+ parameters <- expression_projection_parameters_plot()
+ if (parameters[['is_trajectory']]) {
+ req(nrow(expression_projection_coordinates()) ==
+ nrow(expression_projection_trajectory()[['meta']]))
+ }
+ to_return <- list(
+ coordinates = expression_projection_coordinates(),
+ reset_axes = isolate(expression_projection_parameters_other[['reset_axes']]),
+ ## use isolate() to avoid udpating before new color range is calculated
+ expression_levels = isolate(expression_projection_expression_levels()),
+ plot_parameters = expression_projection_parameters_plot(),
+ color_settings = expression_projection_parameters_color(),
+ hover_info = expression_projection_hover_info(),
+ trajectory = expression_projection_trajectory(),
+ separate_panels = input[["expression_projection_genes_in_separate_panels"]]
+ )
+ # message(str(to_return))
+ return(to_return)
+})
+
+expression_projection_data_to_plot <- debounce(expression_projection_data_to_plot_raw, 250)
diff --git a/inst/shiny/v1.3/gene_expression/obj_projection_expression_levels.R b/inst/shiny/v1.3/gene_expression/obj_projection_expression_levels.R
new file mode 100644
index 0000000..9e6795f
--- /dev/null
+++ b/inst/shiny/v1.3/gene_expression/obj_projection_expression_levels.R
@@ -0,0 +1,38 @@
+##----------------------------------------------------------------------------##
+## Expression levels of cells in projection.
+##----------------------------------------------------------------------------##
+expression_projection_expression_levels <- reactive({
+ req(
+ expression_projection_data(),
+ expression_selected_genes()
+ )
+ # message('--> trigger "expression_projection_expression_levels"')
+ if ( length(expression_selected_genes()$genes_to_display_present) == 0 ) {
+ expression_levels <- rep(0, nrow(expression_projection_data()))
+ } else {
+ req(expression_projection_coordinates())
+ if (
+ ncol(expression_projection_coordinates()) == 2 &&
+ input[["expression_projection_genes_in_separate_panels"]] == TRUE &&
+ length(expression_selected_genes()$genes_to_display_present) >= 2 &&
+ length(expression_selected_genes()$genes_to_display_present) <= 9
+ ) {
+ expression_matrix <- getExpressionMatrix(
+ cells = expression_projection_data()$cell_barcode,
+ genes = expression_selected_genes()$genes_to_display_present
+ ) %>%
+ Matrix::t()
+ expression_levels <- list()
+ for (i in 1:ncol(expression_matrix)) {
+ expression_levels[[colnames(expression_matrix)[i]]] <- as.vector(expression_matrix[,i])
+ }
+ } else {
+ expression_levels <- unname(getMeanExpressionForCells(
+ cells = expression_projection_data()$cell_barcode,
+ genes = expression_selected_genes()$genes_to_display_present
+ ))
+ }
+ }
+ # message(str(expression_levels))
+ return(expression_levels)
+})
diff --git a/inst/shiny/v1.3/gene_expression/obj_projection_hover_info.R b/inst/shiny/v1.3/gene_expression/obj_projection_hover_info.R
new file mode 100644
index 0000000..0a77951
--- /dev/null
+++ b/inst/shiny/v1.3/gene_expression/obj_projection_hover_info.R
@@ -0,0 +1,20 @@
+##----------------------------------------------------------------------------##
+## Hover info for cells in projection.
+##----------------------------------------------------------------------------##
+expression_projection_hover_info <- reactive({
+ req(
+ hover_info_projections(),
+ expression_projection_cells_to_show()
+ )
+ # message('--> trigger "expression_projection_hover_info"')
+ if (
+ !is.null(preferences[["show_hover_info_in_projections"]]) &&
+ preferences[['show_hover_info_in_projections']] == TRUE
+ ) {
+ hover_info <- hover_info_projections()[expression_projection_cells_to_show()]
+ } else {
+ hover_info <- hover_info_projections()
+ }
+ # message(str(hover_info))
+ return(hover_info)
+})
diff --git a/inst/shiny/v1.3/gene_expression/obj_projection_parameters_color.R b/inst/shiny/v1.3/gene_expression/obj_projection_parameters_color.R
new file mode 100644
index 0000000..3deff76
--- /dev/null
+++ b/inst/shiny/v1.3/gene_expression/obj_projection_parameters_color.R
@@ -0,0 +1,18 @@
+##----------------------------------------------------------------------------##
+## Collect color parameters for projection plot.
+##----------------------------------------------------------------------------##
+expression_projection_parameters_color <- reactive({
+ ## require input UI elements
+ req(
+ input[["expression_projection_color_scale"]],
+ input[["expression_projection_color_range"]]
+ )
+ # message('--> trigger "expression_projection_parameters_color"')
+ ## collect parameters
+ parameters <- list(
+ color_scale = input[["expression_projection_color_scale"]],
+ color_range = input[["expression_projection_color_range"]]
+ )
+ # message(str(parameters))
+ return(parameters)
+})
diff --git a/inst/shiny/v1.3/gene_expression/obj_projection_parameters_plot.R b/inst/shiny/v1.3/gene_expression/obj_projection_parameters_plot.R
new file mode 100644
index 0000000..202070e
--- /dev/null
+++ b/inst/shiny/v1.3/gene_expression/obj_projection_parameters_plot.R
@@ -0,0 +1,55 @@
+##----------------------------------------------------------------------------##
+## Collect parameters for projection plot.
+##----------------------------------------------------------------------------##
+expression_projection_parameters_plot_raw <- reactive({
+ req(
+ input[["expression_projection_to_display"]],
+ input[["expression_projection_plotting_order"]],
+ input[["expression_projection_point_size"]],
+ input[["expression_projection_point_opacity"]],
+ !is.null(input[["expression_projection_point_border"]]),
+ input[["expression_projection_scale_x_manual_range"]],
+ input[["expression_projection_scale_y_manual_range"]],
+ !is.null(preferences[["use_webgl"]]),
+ !is.null(preferences[["show_hover_info_in_projections"]]),
+ input[["expression_projection_to_display"]] %in% availableProjections() ||
+ input[["expression_projection_to_display"]] %in% available_trajectories()
+ )
+ # message('--> trigger "expression_projection_parameters_plot_raw"')
+ if ( input[["expression_projection_to_display"]] %in% availableProjections() ) {
+ is_trajectory = FALSE
+ n_dimensions = ncol(getProjection(input[["expression_projection_to_display"]]))
+ } else {
+ is_trajectory = TRUE
+ # currently, only trajectories with 2 dimensions are supported
+ n_dimensions = 2
+ }
+ parameters <- list(
+ projection = input[["expression_projection_to_display"]],
+ plot_order = input[["expression_projection_plotting_order"]],
+ n_dimensions = n_dimensions,
+ is_trajectory = is_trajectory,
+ point_size = input[["expression_projection_point_size"]],
+ point_opacity = input[["expression_projection_point_opacity"]],
+ draw_border = input[["expression_projection_point_border"]],
+ x_range = input[["expression_projection_scale_x_manual_range"]],
+ y_range = input[["expression_projection_scale_y_manual_range"]],
+ webgl = preferences[["use_webgl"]],
+ hover_info = preferences[["show_hover_info_in_projections"]]
+ )
+ # message(str(parameters))
+ return(parameters)
+})
+
+expression_projection_parameters_plot <- debounce(expression_projection_parameters_plot_raw, 150)
+
+##
+expression_projection_parameters_other <- reactiveValues(
+ reset_axes = FALSE
+)
+
+##
+observeEvent(input[['expression_projection_to_display']], {
+ # message('--> set "gene expression: reset_axes"')
+ expression_projection_parameters_other[['reset_axes']] <- TRUE
+})
diff --git a/inst/shiny/v1.3/gene_expression/obj_projection_selected_cells.R b/inst/shiny/v1.3/gene_expression/obj_projection_selected_cells.R
new file mode 100644
index 0000000..6da40c9
--- /dev/null
+++ b/inst/shiny/v1.3/gene_expression/obj_projection_selected_cells.R
@@ -0,0 +1,28 @@
+##----------------------------------------------------------------------------##
+## Reactive that holds IDs of selected cells (ID is built from position in
+## projection).
+##----------------------------------------------------------------------------##
+expression_projection_selected_cells <- reactive({
+ ## make sure plot parameters are set because it means that the plot can be
+ ## generated
+ req(
+ expression_projection_parameters_plot(),
+ expression_projection_data()
+ )
+ # message('--> trigger "expression_projection_selected_cells"')
+ ## check selection
+ ## ... selection has not been made or there is no cell in it
+ if (
+ is.null(plotly::event_data("plotly_selected", source = "expression_projection")) ||
+ length(plotly::event_data("plotly_selected", source = "expression_projection")) == 0
+ ) {
+ return(NULL)
+ ## ... selection has been made and at least 1 cell is in it
+ } else {
+ ## get number of selected cells
+ selected_cells <- plotly::event_data("plotly_selected", source = "expression_projection") %>%
+ dplyr::mutate(identifier = paste0(x, '-', y))
+ # message(str(selected_cells))
+ return(selected_cells)
+ }
+})
diff --git a/inst/shiny/v1.3/gene_expression/obj_projection_trajectory.R b/inst/shiny/v1.3/gene_expression/obj_projection_trajectory.R
new file mode 100644
index 0000000..fc10e0c
--- /dev/null
+++ b/inst/shiny/v1.3/gene_expression/obj_projection_trajectory.R
@@ -0,0 +1,31 @@
+##----------------------------------------------------------------------------##
+## Data to draw trajectory in projection.
+##----------------------------------------------------------------------------##
+expression_projection_trajectory <- reactive({
+ req(
+ expression_projection_parameters_plot(),
+ expression_projection_cells_to_show()
+ )
+ # message('--> trigger "expression_projection_trajectory"')
+ parameters <- expression_projection_parameters_plot()
+ cells_to_show <- expression_projection_cells_to_show()
+ if ( parameters[["projection"]] %in% availableProjections()) {
+ trajectory_data <- list()
+ } else {
+ ## split selection into method and name
+ selection <- strsplit(parameters[["projection"]], split = ' // ')[[1]]
+ ## check if method and name exist and don't proceed if not
+ req(
+ selection[1] %in% getMethodsForTrajectories(),
+ selection[2] %in% getNamesOfTrajectories(selection[1])
+ )
+ ## collect trajectory data
+ trajectory_data <- getTrajectory(
+ selection[1],
+ selection[2]
+ )
+ trajectory_data[['meta']] <- trajectory_data[['meta']][cells_to_show,]
+ }
+# message(str(trajectory_data))
+ return(trajectory_data)
+})
diff --git a/inst/shiny/v1.3/gene_expression/obj_selected_genes.R b/inst/shiny/v1.3/gene_expression/obj_selected_genes.R
new file mode 100644
index 0000000..c379f07
--- /dev/null
+++ b/inst/shiny/v1.3/gene_expression/obj_selected_genes.R
@@ -0,0 +1,46 @@
+##----------------------------------------------------------------------------##
+## Reactive data that holds genes provided by user or in selected gene set.
+##----------------------------------------------------------------------------##
+## cannot use req() because it delays initialization and plot is updated only
+## with button press so plot doesn't initialize at all
+expression_selected_genes <- reactive({
+ req(input[["expression_analysis_mode"]])
+ # message('--> trigger "expression_selected_genes"')
+ ## prepare empty list for data
+ gene_sets <- list(
+ "genes_to_display" = character(),
+ "genes_to_display_present" = character(),
+ "genes_to_display_missing" = character()
+ )
+ ## ...
+ if ( input[["expression_analysis_mode"]] == "Gene(s)" ) {
+ ## check if user provided input in gene box
+ ## ... if user provided input
+ if ( !is.null(input[["expression_genes_input"]]) ) {
+ ## - grab user input
+ ## - split by comma, space, semicolon and line
+ ## - convert to vector
+ ## - remove spaces
+ ## - remove duplicated strings
+ ## - remove empty strings
+ gene_sets[["genes_to_display"]] <- input[["expression_genes_input"]] %>%
+ strsplit(",| |;|\n") %>%
+ unlist() %>%
+ gsub(pattern = " ", replacement = "", fixed = TRUE) %>%
+ unique() %>%
+ .[. != ""]
+ }
+ ## ...
+ } else if ( input[["expression_analysis_mode"]] == "Gene set" ) {
+ req(input[["expression_select_gene_set"]])
+ gene_sets[["genes_to_display"]] <- getGenesForGeneSet(input[["expression_select_gene_set"]])
+ }
+ ## check which are available in the data set
+ genes_to_display_here <- getGeneNames()[ match(tolower(gene_sets[["genes_to_display"]]), tolower(getGeneNames())) ]
+ ## get which genes are available in the data set
+ gene_sets[["genes_to_display_present"]] <- na.omit(genes_to_display_here)
+ ## get names of provided genes that are not in the data set
+ gene_sets[["genes_to_display_missing"]] <- gene_sets[["genes_to_display"]][ which(is.na(genes_to_display_here)) ]
+ # message(str(gene_sets))
+ return(gene_sets)
+})
diff --git a/inst/shiny/v1.3/gene_expression/out_genes_displayed.R b/inst/shiny/v1.3/gene_expression/out_genes_displayed.R
new file mode 100644
index 0000000..f1976ca
--- /dev/null
+++ b/inst/shiny/v1.3/gene_expression/out_genes_displayed.R
@@ -0,0 +1,17 @@
+##----------------------------------------------------------------------------##
+## Text showing which genes are present and missing.
+##----------------------------------------------------------------------------##
+output[["expression_genes_displayed"]] <- renderText({
+ ## don't proceed without these inputs
+ req(expression_selected_genes())
+ ## prepare text output from reactive data
+ paste0(
+ "Showing expression for ",
+ length(expression_selected_genes()[["genes_to_display_present"]]), " gene(s):
",
+ paste0(expression_selected_genes()[["genes_to_display_present"]], collapse = ", "),
+ "
",
+ length(expression_selected_genes()[["genes_to_display_missing"]]),
+ " gene(s) are not in data set:
",
+ paste0(expression_selected_genes()[["genes_to_display_missing"]], collapse = ", ")
+ )
+})
diff --git a/inst/shiny/v1.3/gene_expression/out_number_of_selected_cells.R b/inst/shiny/v1.3/gene_expression/out_number_of_selected_cells.R
new file mode 100644
index 0000000..f4a7377
--- /dev/null
+++ b/inst/shiny/v1.3/gene_expression/out_number_of_selected_cells.R
@@ -0,0 +1,19 @@
+##----------------------------------------------------------------------------##
+## Text showing the number of selected cells.
+##----------------------------------------------------------------------------##
+output[["expression_number_of_selected_cells"]] <- renderText({
+ ## check selection
+ ## ... selection has not been made or there is no cell in it
+ if ( is.null(expression_projection_selected_cells()) ) {
+ ## manually set counter to 0
+ number_of_selected_cells <- 0
+ ## ... selection has been made and at least 1 cell is in it
+ } else {
+ ## get number of selected cells
+ number_of_selected_cells <- expression_projection_selected_cells() %>%
+ nrow() %>%
+ formatC(format = "f", big.mark = ",", digits = 0)
+ }
+ ## prepare string to show
+ paste0("Number of selected cells: ", number_of_selected_cells)
+})
diff --git a/inst/shiny/v1.3/gene_expression/out_projection.R b/inst/shiny/v1.3/gene_expression/out_projection.R
new file mode 100644
index 0000000..2991c54
--- /dev/null
+++ b/inst/shiny/v1.3/gene_expression/out_projection.R
@@ -0,0 +1,66 @@
+##----------------------------------------------------------------------------##
+## Plot of projection.
+##----------------------------------------------------------------------------##
+output[["expression_projection"]] <- plotly::renderPlotly({
+ plotly::plot_ly(type = 'scattergl', mode = 'markers', source = "expression_projection") %>%
+ plotly::layout(
+ xaxis = list(
+ autorange = TRUE,
+ mirror = TRUE,
+ showline = TRUE,
+ zeroline = FALSE
+ ),
+ yaxis = list(
+ autorange = TRUE,
+ mirror = TRUE,
+ showline = TRUE,
+ zeroline = FALSE
+ )
+ )
+})
+
+##----------------------------------------------------------------------------##
+## Info box that gets shown when pressing the "info" button.
+##----------------------------------------------------------------------------##
+observeEvent(input[["expression_projection_info"]], {
+ showModal(
+ modalDialog(
+ expression_projection_info$text,
+ title = expression_projection_info$title,
+ easyClose = TRUE,
+ footer = NULL,
+ size = "l"
+ )
+ )
+})
+
+##----------------------------------------------------------------------------##
+## Text in info box.
+##----------------------------------------------------------------------------##
+expression_projection_info <- list(
+ title = "Dimensional reduction",
+ text = HTML("
+ Interactive projection of cells into two- or three-dimensional space based on their expression profile.
+
+ - Both tSNE and UMAP are frequently used algorithms for dimensional reduction in single cell transcriptomics. While they generally allow to make similar conclusions, some differences exist between the two (please refer to Google and/or literature, such as Becht E. et al., Dimensionality reduction for visualizing single-cell data using UMAP. Nature Biotechnology, 2018, 37, 38-44).
+ - Cell color reflects the log-normalised expression of entered genes. If more than 1 gene is entered or a gene set is selected, the color reflects the average expression of all genes. Genes must be in separate lines or separated by a space, comma, or semicolon. Reported below the projection are the genes that are present and absent in this data set. Absent genes could either have been annotated with a different name or were not expressed in any of the cells. Matching of gene names is case-insensitive, that means Myc/MYC/myc are treated equally.
+ - Cells can be plotted either randomly (to give a more unbiased perspective) or in the order of expression (with highest expression plotted last), sometimes resulting in a more appealing figure.
+ - The last two slider elements on the left can be used to resize the projection axes. This can be particularly useful when a projection contains a population of cell that is very far away from the rest and therefore creates a big empty space (which is not uncommon for UMAPs).
+
+ The plot is interactive (drag and zoom) but depending on the computer of the user and the number of cells displayed it can become very slow.
+ Experimental options
+ Experimental options can be accessed from the gear icon next to the 'export to PDF' button.
+ Show genes in separate panels
+ When selecting multiple genes as input (up to 8), this option will show the expression of each gene in a separate panel instead of calculating the mean expression across all genes. The option is labeled as 'experimental' because of its poor implementation:
+
+ - Hovering over the cells shows only limited information.
+ - Cells cannot be shown with a (grey) border around them.
+ - All genes have the some color scale.
+ - Cells cannot be selected.
+ - The 'Expression by group' panel needs to be deactivated.
+ - It throws annoying but innocent warning messages in the log.
+
+ Yet, this feature might be useful in some situations.
+ "
+ )
+)
diff --git a/inst/shiny/v1.3/gene_expression/projection.R b/inst/shiny/v1.3/gene_expression/projection.R
deleted file mode 100644
index 1c7e615..0000000
--- a/inst/shiny/v1.3/gene_expression/projection.R
+++ /dev/null
@@ -1,1380 +0,0 @@
-##----------------------------------------------------------------------------##
-## Tab: Gene (set) expression
-##
-## Expression in projection.
-##----------------------------------------------------------------------------##
-
-##----------------------------------------------------------------------------##
-## Function to plot expression of multiple genes in separate facets.
-##----------------------------------------------------------------------------##
-
-plotExpressionMultiplePanels <- function(table) {
-
- ## make ggplot2 functions available
- require("ggplot2")
-
- ## decide how many panel columns should be used
- ## below 6 panels, use 2 columns, from 6-8 panels use 3 columns
- number_of_genes <- length(unique(gene_expression_plot_data()$gene))
- number_of_panel_columns <- ifelse(number_of_genes < 6, 2, 3)
-
- ## get X and Y scale limits
- xlim <- c(
- input[["expression_projection_scale_x_manual_range"]][1],
- input[["expression_projection_scale_x_manual_range"]][2]
- )
- ylim <- c(
- input[["expression_projection_scale_y_manual_range"]][1],
- input[["expression_projection_scale_y_manual_range"]][2]
- )
-
- ## prepare plot
- plot <- ggplot(
- table,
- aes_q(
- x = as.name(colnames(table)[1]),
- y = as.name(colnames(table)[2]),
- color = as.name("level")
- )
- ) +
- geom_point(
- size = input[["expression_projection_point_size"]]/10,
- alpha = input[["expression_projection_point_opacity"]]
- ) +
- lims(x = xlim, y = ylim) +
- theme_bw() +
- facet_wrap(~gene, ncol = number_of_panel_columns)
-
- ## check if selected color scale
- ## ... selected color scale is "viridis"
- if ( input[["expression_projection_color_scale"]] == 'viridis' ) {
-
- ## add color scale to plot
- plot <- plot +
- viridis::scale_color_viridis(
- option = "viridis",
- limits = input[["expression_projection_color_scale_range"]],
- oob = scales::squish,
- direction = -1,
- name = "Log-normalised\nexpression",
- guide = guide_colorbar(frame.colour = "black", ticks.colour = "black")
- )
-
- ## ... selected color scale is anything else than "viridis"
- } else {
-
- ## add color scale to plot
- plot <- plot +
- scale_color_distiller(
- palette = input[["expression_projection_color_scale"]],
- limits = input[["expression_projection_color_scale_range"]],
- oob = scales::squish,
- direction = 1,
- name = "Log-normalised\nexpression",
- guide = guide_colorbar(frame.colour = "black", ticks.colour = "black")
- )
- }
-
- ##
- return(plot)
-}
-
-##----------------------------------------------------------------------------##
-## Function to plot expression in single panel in 3D.
-##----------------------------------------------------------------------------##
-
-plotExpressionSinglePanel3D <- function(table, color_scale, hover_info) {
-
- ## prepare plot
- plot <- plotly::plot_ly(
- table,
- x = table[,1],
- y = table[,2],
- z = table[,3],
- type = "scatter3d",
- mode = "markers",
- marker = list(
- colorbar = list(
- title = "Expression",
- ticks = 'outside',
- outlinewidth = 1,
- outlinecolor = 'black'
- ),
- color = ~level,
- opacity = input[["expression_projection_point_opacity"]],
- colorscale = color_scale,
- cauto = FALSE,
- cmin = input[["expression_projection_color_scale_range"]][1],
- cmax = input[["expression_projection_color_scale_range"]][2],
- reversescale = TRUE,
- line = list(
- color = "rgb(196,196,196)",
- width = 1
- ),
- size = input[["expression_projection_point_size"]]
- ),
- hoverinfo = "text",
- text = ~hover_info,
- source = "expression_projection"
- ) %>%
- plotly::layout(
- scene = list(
- xaxis = list(
- title = colnames(table)[1],
- mirror = TRUE,
- showline = TRUE,
- zeroline = FALSE
- ),
- yaxis = list(
- title = colnames(table)[2],
- mirror = TRUE,
- showline = TRUE,
- zeroline = FALSE
- ),
- zaxis = list(
- title = colnames(table)[3],
- mirror = TRUE,
- showline = TRUE,
- zeroline = FALSE
- )
- ),
- hoverlabel = list(
- font = list(
- size = 11,
- color = "black"
- ),
- bgcolor = "lightgrey",
- align = 'left'
- )
- )
-
- ##
- return(plot)
-}
-
-##----------------------------------------------------------------------------##
-## Function to plot expression in single panel in 2D.
-##----------------------------------------------------------------------------##
-
-plotExpressionSinglePanel2D <- function(table, color_scale, hover_info) {
-
- ## prepare plot
- plot <- plotly::plot_ly(
- table,
- x = table[,1],
- y = table[,2],
- type = "scatter",
- mode = "markers",
- marker = list(
- colorbar = list(
- title = "Expression",
- ticks = 'outside',
- outlinewidth = 1,
- outlinecolor = 'black'
- ),
- color = ~level,
- opacity = input[["expression_projection_point_opacity"]],
- colorscale = color_scale,
- cauto = FALSE,
- cmin = input[["expression_projection_color_scale_range"]][1],
- cmax = input[["expression_projection_color_scale_range"]][2],
- reversescale = TRUE,
- line = list(
- color = "rgb(196,196,196)",
- width = 1
- ),
- size = input[["expression_projection_point_size"]]
- ),
- hoverinfo = "text",
- text = ~hover_info,
- source = "expression_projection"
- ) %>%
- plotly::layout(
- xaxis = list(
- title = colnames(table)[1],
- mirror = TRUE,
- showline = TRUE,
- zeroline = FALSE,
- range = c(
- input[["expression_projection_scale_x_manual_range"]][1],
- input[["expression_projection_scale_x_manual_range"]][2]
- )
- ),
- yaxis = list(
- title = colnames(table)[2],
- mirror = TRUE,
- showline = TRUE,
- zeroline = FALSE,
- range = c(
- input[["expression_projection_scale_y_manual_range"]][1],
- input[["expression_projection_scale_y_manual_range"]][2]
- )
- ),
- dragmode = "pan",
- hoverlabel = list(
- font = list(
- size = 11,
- color = "black"
- ),
- bgcolor = "lightgrey",
- align = 'left'
- )
- )
-
- ##
- return(plot)
-}
-
-##----------------------------------------------------------------------------##
-## Function to plot expression in trajectory.
-##----------------------------------------------------------------------------##
-
-plotExpressionSinglePanel2DTrajectory <- function(
- table,
- trajectory_edges,
- color_scale,
- hover_info
-) {
-
- ## convert edges of trajectory into list format to plot with plotly
- trajectory_lines <- list()
- for (i in 1:nrow(trajectory_edges) ) {
- line = list(
- type = "line",
- line = list(color = "black"),
- xref = "x",
- yref = "y",
- x0 = trajectory_edges$source_dim_1[i],
- y0 = trajectory_edges$source_dim_2[i],
- x1 = trajectory_edges$target_dim_1[i],
- y1 = trajectory_edges$target_dim_2[i]
- )
- trajectory_lines <- c(trajectory_lines, list(line))
- }
-
- ##
- plot <- plotly::plot_ly(
- data = table,
- x = ~DR_1,
- y = ~DR_2,
- type = "scatter",
- mode = "markers",
- marker = list(
- colorbar = list(
- title = "Expression",
- ticks = 'outside',
- outlinewidth = 1,
- outlinecolor = 'black'
- ),
- color = ~level,
- opacity = input[["expression_projection_point_opacity"]],
- colorscale = color_scale,
- cauto = FALSE,
- cmin = input[["expression_projection_color_scale_range"]][1],
- cmax = input[["expression_projection_color_scale_range"]][2],
- reversescale = TRUE,
- line = list(
- color = "rgb(196,196,196)",
- width = 1
- ),
- size = input[["expression_projection_point_size"]]
- ),
- hoverinfo = "text",
- text = ~hover_info,
- source = "expression_projection"
- ) %>%
- plotly::layout(
- shapes = trajectory_lines,
- xaxis = list(
- mirror = TRUE,
- showline = TRUE,
- zeroline = FALSE,
- range = c(
- input[["expression_projection_scale_x_manual_range"]][1],
- input[["expression_projection_scale_x_manual_range"]][2]
- )
- ),
- yaxis = list(
- mirror = TRUE,
- showline = TRUE,
- zeroline = FALSE,
- range = c(
- input[["expression_projection_scale_y_manual_range"]][1],
- input[["expression_projection_scale_y_manual_range"]][2]
- )
- ),
- hoverlabel = list(
- font = list(
- size = 11,
- color = "black"
- ),
- bgcolor = "lightgrey",
- align = 'left'
- )
- )
-
- ##
- return(plot)
-}
-
-##----------------------------------------------------------------------------##
-## Function to plot expression in single panel in 2D (for export).
-##----------------------------------------------------------------------------##
-
-plotExpressionSinglePanel2DExport <- function(table) {
-
- ## make ggplot2 functions available
- require("ggplot2")
-
- ## get X and Y scale limits
- xlim <- c(
- input[["expression_projection_scale_x_manual_range"]][1],
- input[["expression_projection_scale_x_manual_range"]][2]
- )
- ylim <- c(
- input[["expression_projection_scale_y_manual_range"]][1],
- input[["expression_projection_scale_y_manual_range"]][2]
- )
-
- ## prepare plot
- plot <- ggplot(
- table,
- aes_q(
- x = as.name(colnames(table)[1]),
- y = as.name(colnames(table)[2]),
- fill = as.name("level")
- )
- ) +
- geom_point(
- shape = 21,
- size = input[["expression_projection_point_size"]]/3,
- stroke = 0.2,
- color = "#c4c4c4",
- alpha = input[["expression_projection_point_opacity"]]
- ) +
- lims(x = xlim, y = ylim) +
- theme_bw()
-
- ## check if selected color scale
- ## ... selected color scale is "viridis"
- if ( input[["expression_projection_color_scale"]] == 'viridis' ) {
-
- ## add color scale to plot
- plot <- plot +
- viridis::scale_fill_viridis(
- option = "viridis",
- limits = input[["expression_projection_color_scale_range"]],
- oob = scales::squish,
- direction = -1,
- name = "Log-normalised\nexpression",
- guide = guide_colorbar(frame.colour = "black", ticks.colour = "black")
- )
-
- ## ... selected color scale is anything else than "viridis"
- } else {
-
- ## add color scale to plot
- plot <- plot +
- scale_fill_distiller(
- palette = input[["expression_projection_color_scale"]],
- limits = input[["expression_projection_color_scale_range"]],
- oob = scales::squish,
- direction = 1,
- name = "Log-normalised\nexpression",
- guide = guide_colorbar(frame.colour = "black", ticks.colour = "black")
- )
- }
-
- ##
- return(plot)
-}
-
-##----------------------------------------------------------------------------##
-## Function to plot expression in trajectory (for export).
-##----------------------------------------------------------------------------##
-
-plotExpressionSinglePanel2DTrajectoryExport <- function(
- table,
- trajectory_edges
-) {
-
- ## start building the plot
- plot <- ggplot() +
- geom_point(
- data = table,
- aes_string(
- x = colnames(table)[1],
- y = colnames(table)[2],
- fill = as.name("level")
- ),
- shape = 21,
- size = input[["expression_projection_point_size"]]/3,
- stroke = 0.2,
- color = "#c4c4c4",
- alpha = input[["expression_projection_point_opacity"]]
- ) +
- geom_segment(
- data = trajectory_edges,
- aes(
- source_dim_1,
- source_dim_2,
- xend = target_dim_1,
- yend = target_dim_2
- ),
- size = 0.75, linetype = "solid", na.rm = TRUE
- ) +
- theme_bw()
-
- ## check if selected color scale
- ## ... selected color scale is "viridis"
- if ( input[["expression_projection_color_scale"]] == 'viridis' ) {
-
- ## add color scale to plot
- plot <- plot +
- viridis::scale_fill_viridis(
- option = "viridis",
- limits = input[["expression_projection_color_scale_range"]],
- oob = scales::squish,
- direction = -1,
- name = "Log-normalised\nexpression",
- guide = guide_colorbar(frame.colour = "black", ticks.colour = "black")
- )
-
- ## ... selected color scale is anything else than "viridis"
- } else {
-
- ## add color scale to plot
- plot <- plot +
- scale_fill_distiller(
- palette = input[["expression_projection_color_scale"]],
- limits = input[["expression_projection_color_scale_range"]],
- oob = scales::squish,
- direction = 1,
- name = "Log-normalised\nexpression",
- guide = guide_colorbar(frame.colour = "black", ticks.colour = "black")
- )
- }
-
- ##
- return(plot)
-}
-
-##----------------------------------------------------------------------------##
-## UI element with layout for user input and plot.
-##----------------------------------------------------------------------------##
-
-output[["expression_projection_UI"]] <- renderUI({
- fluidRow(
- column(
- width = 3, offset = 0, style = "padding: 0px;",
- tagList(
- cerebroBox(
- title = tagList(
- "Main parameters",
- actionButton(
- inputId = "expression_projection_main_parameters_info",
- label = "info",
- icon = NULL,
- class = "btn-xs",
- title = "Show additional information for this panel.",
- style = "margin-left: 5px"
- )
- ),
- tagList(
- shinyWidgets::radioGroupButtons(
- inputId = "expression_analysis_mode",
- label = NULL,
- choices = c("Gene(s)", "Gene set"),
- status = "primary",
- justified = TRUE,
- width = "100%"
- ),
- uiOutput("expression_projection_input_type_UI"),
- uiOutput("expression_projection_select_projection_UI")
- )
- ),
- cerebroBox(
- title = tagList(
- "Additional parameters",
- actionButton(
- inputId = "expression_projection_additional_parameters_info",
- label = "info",
- icon = NULL,
- class = "btn-xs",
- title = "Show additional information for this panel.",
- style = "margin-left: 5px"
- )
- ),
- uiOutput("expression_projection_select_additional_parameters_UI"),
- collapsed = TRUE
- ),
- cerebroBox(
- title = tagList(
- "Group filters",
- actionButton(
- inputId = "expression_projection_group_filters_info",
- label = "info",
- icon = NULL,
- class = "btn-xs",
- title = "Show additional information for this panel.",
- style = "margin-left: 5px"
- )
- ),
- uiOutput("expression_projection_group_filters_UI"),
- collapsed = TRUE
- ),
- cerebroBox(
- title = tagList(
- "Color scale",
- actionButton(
- inputId = "expression_projection_color_scale_info",
- label = "info",
- icon = NULL,
- class = "btn-xs",
- title = "Show additional information for this panel.",
- style = "margin-left: 5px"
- )
- ),
- tagList(
- uiOutput("expression_projection_color_scale_UI"),
- uiOutput("expression_projection_color_scale_range_UI"),
- ),
- collapsed = TRUE
- )
- )
- ),
- column(
- width = 9, offset = 0, style = "padding: 0px;",
- cerebroBox(
- title = tagList(
- boxTitle("Dimensional reduction"),
- tagList(
- actionButton(
- inputId = "expression_projection_info",
- label = "info",
- icon = NULL,
- class = "btn-xs",
- title = "Show additional information for this panel.",
- style = "margin-right: 3px"
- ),
- shinyFiles::shinySaveButton(
- "expression_projection_export",
- label = "export to PDF",
- title = "Export dimensional reduction to PDF file.",
- filetype = "pdf",
- viewtype = "icon",
- class = "btn-xs",
- style = "margin-right: 3px"
- ),
- shinyWidgets::dropdownButton(
- tags$div(
- tags$style(
- HTML("div.awesome-checkbox {margin-top: 10px;}")
- ),
- style = "color: black !important;",
- tagList(
- ## TODO: figure out how to vertically center box and label
- shinyWidgets::awesomeCheckbox(
- inputId = "expression_projection_show_genes_in_separate_panels",
- label = HTML("Show genes in separate panels
(experimental)"),
- value = FALSE
- ),
- hr(),
- uiOutput("expression_projection_scales_UI")
- )
- ),
- circle = FALSE,
- icon = icon("cog"),
- inline = TRUE,
- size = "xs"
- )
- )
- ),
- tagList(
- shinycssloaders::withSpinner(
- plotly::plotlyOutput(
- "expression_projection",
- width = "auto",
- height = "85vh"
- ),
- type = 8,
- hide.ui = FALSE
- ),
- tags$br(),
- htmlOutput("expression_number_of_selected_cells"),
- tags$br(),
- htmlOutput("expression_genes_displayed")
- )
- )
- )
- )
-})
-
-##----------------------------------------------------------------------------##
-## UI elements to choose whether gene(s) or gene sets should be analyzed
-##----------------------------------------------------------------------------##
-
-output[["expression_projection_input_type_UI"]] <- renderUI({
-
- req(
- input[["expression_analysis_mode"]]
- )
-
- if ( input[["expression_analysis_mode"]] == "Gene(s)" ) {
- selectizeInput(
- 'expression_genes_input',
- label = 'Gene(s)',
- choices = data.table::as.data.table(data.frame("Genes" = getGeneNames())),
- multiple = TRUE,
- options = list(create = TRUE)
- )
- } else if ( input[["expression_analysis_mode"]] == "Gene set" ) {
- selectizeInput(
- 'expression_select_gene_set',
- label = 'Gene set',
- choices = data.table::as.data.table(
- data.frame("Gene sets" = c("-", msigdbr:::msigdbr_genesets$gs_name))
- ),
- multiple = FALSE
- )
- }
-})
-
-##----------------------------------------------------------------------------##
-## UI elements to choose which projection/trajectory to show.
-##----------------------------------------------------------------------------##
-
-output[["expression_projection_select_projection_UI"]] <- renderUI({
-
- ## get available projections
- available_projections <- availableProjections()
-
- ## collect available trajectories across all methods and create selectable
- ## options
- available_trajectories <- c()
- available_trajectory_method <- getMethodsForTrajectories()
-
- ## check if at least 1 trajectory method exists
- if ( length(available_trajectory_method) > 0 ) {
-
- ## cycle through trajectory methods
- for ( i in seq_along(available_trajectory_method) ) {
-
- ## get current method and names of trajectories for this method
- current_method <- available_trajectory_method[i]
- available_trajectories_for_this_method <- getNamesOfTrajectories(current_method)
-
- ## check if at least 1 trajectory is available for this method
- if ( length(available_trajectories_for_this_method) > 0 ) {
-
- ## cycle through trajectories for this method
- for ( j in seq_along(available_trajectories_for_this_method) ) {
-
- ## create selectable combination of method and trajectory name and add
- ## it to the available trajectories
- current_trajectory <- available_trajectories_for_this_method[j]
- available_trajectories <- c(
- available_trajectories,
- glue::glue("{current_method} // {current_trajectory}")
- )
- }
- }
- }
- }
-
- selectInput(
- "expression_projection_to_display",
- label = "Projection",
- choices = list(
- "Projections" = as.list(available_projections),
- "Trajectories" = as.list(available_trajectories)
- )
- )
-})
-
-##----------------------------------------------------------------------------##
-## Info box that gets shown when pressing the "info" button.
-##----------------------------------------------------------------------------##
-
-observeEvent(input[["expression_projection_main_parameters_info"]], {
- showModal(
- modalDialog(
- expression_projection_main_parameters_info$text,
- title = expression_projection_main_parameters_info$title,
- easyClose = TRUE,
- footer = NULL,
- size = "l"
- )
- )
-})
-
-##----------------------------------------------------------------------------##
-## Text in info box.
-##----------------------------------------------------------------------------##
-
-expression_projection_main_parameters_info <- list(
- title = "Main parameters for gene (set) expression",
- text = HTML("
- The elements in this panel allow you to control what and how results are displayed across the whole tab.
-
- - Gene(s) / Gene set: Select whether you would like to select individual genes or gene sets. In the case of 'Gene(s)', you can select one or multiple genes from the input field below. If you select multiple genes, the mean expression across the selected genes will be calculated for each cell. If you select 'Gene set', you can select a gene set from the MSigDB. Species-specific gene names will be tried to retrieve, otherwise gene name matching is attempted. A list of which genes are present or missing in the data set can be found below the projection.
- - Projection: Select here which projection you want to see in the scatter plot on the right.
-
- "
- )
-)
-
-##----------------------------------------------------------------------------##
-## UI elements to set additional plotting parameters.
-##----------------------------------------------------------------------------##
-
-output[["expression_projection_select_additional_parameters_UI"]] <- renderUI({
- tagList(
- selectInput(
- "expression_projection_plotting_order",
- label = "Plotting order",
- choices = c("Random", "Highest expression on top"),
- selected = "Random"
- ),
- sliderInput(
- "expression_projection_point_size",
- label = "Point size",
- min = scatter_plot_point_size[["min"]],
- max = scatter_plot_point_size[["max"]],
- step = scatter_plot_point_size[["step"]],
- value = scatter_plot_point_size[["default"]]
- ),
- sliderInput(
- "expression_projection_point_opacity",
- label = "Point opacity",
- min = scatter_plot_point_opacity[["min"]],
- max = scatter_plot_point_opacity[["max"]],
- step = scatter_plot_point_opacity[["step"]],
- value = scatter_plot_point_opacity[["default"]]
- ),
- sliderInput(
- "expression_percentage_cells_to_show",
- label = "Show % of cells",
- min = scatter_plot_percentage_cells_to_show[["min"]],
- max = scatter_plot_percentage_cells_to_show[["max"]],
- step = scatter_plot_percentage_cells_to_show[["step"]],
- value = scatter_plot_percentage_cells_to_show[["default"]]
- )
- )
-})
-
-## make sure elements are loaded even though the box is collapsed
-outputOptions(
- output,
- "expression_projection_select_additional_parameters_UI",
- suspendWhenHidden = FALSE
-)
-
-##----------------------------------------------------------------------------##
-## Info box that gets shown when pressing the "info" button.
-##----------------------------------------------------------------------------##
-
-observeEvent(input[["expression_projection_additional_parameters_info"]], {
- showModal(
- modalDialog(
- expression_projection_additional_parameters_info$text,
- title = expression_projection_additional_parameters_info$title,
- easyClose = TRUE,
- footer = NULL,
- size = "l"
- )
- )
-})
-
-##----------------------------------------------------------------------------##
-## Text in info box.
-##----------------------------------------------------------------------------##
-
-expression_projection_additional_parameters_info <- list(
- title = "Additional parameters for gene (set) expression",
- text = HTML("
- The elements in this panel allow you to control what and how results are displayed across the whole tab.
-
- - Plotting order: Cells can be plotted in random order or so that cells with highest expression are on top.
- - Point size: Controls how large the cells should be.
- - Point opacity: Controls the transparency of the cells.
- - Show % of cells: Using the slider, you can randomly remove a fraction of cells from the plot. This can be useful for large data sets and/or computers with limited resources.
-
- "
- )
-)
-
-##----------------------------------------------------------------------------##
-## UI elements to set group filters.
-##----------------------------------------------------------------------------##
-
-output[["expression_projection_group_filters_UI"]] <- renderUI({
- group_filters <- list()
- for ( i in getGroups() ) {
- group_filters[[i]] <- shinyWidgets::pickerInput(
- paste0("expression_projection_group_filter_", i),
- label = i,
- choices = getGroupLevels(i),
- selected = getGroupLevels(i),
- options = list("actions-box" = TRUE),
- multiple = TRUE
- )
- }
- group_filters
-})
-
-## make sure elements are loaded even though the box is collapsed
-outputOptions(
- output,
- "expression_projection_group_filters_UI",
- suspendWhenHidden = FALSE
-)
-
-##----------------------------------------------------------------------------##
-## Info box that gets shown when pressing the "info" button.
-##----------------------------------------------------------------------------##
-
-observeEvent(input[["expression_projection_group_filters_info"]], {
- showModal(
- modalDialog(
- expression_projection_group_filters_info$text,
- title = expression_projection_group_filters_info$title,
- easyClose = TRUE,
- footer = NULL,
- size = "l"
- )
- )
-})
-
-##----------------------------------------------------------------------------##
-## Text in info box.
-##----------------------------------------------------------------------------##
-# - Range of X/Y axis (located in dropdown menu above the projection): Set the X/Y axis limits. This is useful when you want to change the aspect ratio of the plot.
-
-expression_projection_group_filters_info <- list(
- title = "Group filters for gene (set) expression",
- text = HTML("
- The elements in this panel allow you to select which cells should be plotted based on the group(s) they belong to. For each grouping variable, you can activate or deactivate group levels. Only cells that are pass all filters (for each grouping variable) are shown in the projection, the expression by group, and expression by pseudotime (if applicable).
- "
- )
-)
-
-##----------------------------------------------------------------------------##
-## UI elements to set color scale.
-##----------------------------------------------------------------------------##
-
-output[["expression_projection_color_scale_UI"]] <- renderUI({
- selectInput(
- "expression_projection_color_scale",
- label = "Color scale",
- choices = c("YlGnBu", "YlOrRd","Blues","Greens","Reds","RdBu","viridis"),
- selected = "YlGnBu"
- )
-})
-
-## make sure elements are loaded even though the box is collapsed
-outputOptions(
- output,
- "expression_projection_color_scale_UI",
- suspendWhenHidden = FALSE
-)
-
-##----------------------------------------------------------------------------##
-## UI elements to set color scale range.
-##----------------------------------------------------------------------------##
-
-output[["expression_projection_color_scale_range_UI"]] <- renderUI({
-
- ## get range of expression levels
- expression_range <- range(gene_expression_plot_data()$level)
-
- ## adjust expression range for color scale
- ## ... there is no range (from 0 to 0)
- if (
- expression_range[1] == 0 &&
- expression_range[2] == 0
- ) {
-
- ## set range to 0-1
- expression_range[2] = 1
-
- ## ... otherwise
- } else {
-
- ## round min and max values to 2 digits
- expression_range <- round(expression_range, digits = 2)
- }
-
- sliderInput(
- "expression_projection_color_scale_range",
- label = "Range of color scale",
- min = expression_range[1],
- max = expression_range[2],
- value = expression_range
- )
-})
-
-## make sure elements are loaded even though the box is collapsed
-outputOptions(
- output,
- "expression_projection_color_scale_range_UI",
- suspendWhenHidden = FALSE
-)
-
-##----------------------------------------------------------------------------##
-## Info box that gets shown when pressing the "info" button.
-##----------------------------------------------------------------------------##
-
-observeEvent(input[["expression_projection_color_scale_info"]], {
- showModal(
- modalDialog(
- expression_projection_color_scale_info$text,
- title = expression_projection_color_scale_info$title,
- easyClose = TRUE,
- footer = NULL,
- size = "l"
- )
- )
-})
-
-##----------------------------------------------------------------------------##
-## Text in info box.
-##----------------------------------------------------------------------------##
-
-expression_projection_color_scale_info <- list(
- title = "Color scale for gene (set) expression",
- text = HTML("
- The elements in this panel allow you to control what and how results are displayed across the whole tab.
-
- - Color scale: Choose your prefered color scale.
- - Range of color scale: Using the sliders, you can set the limits for the color scale. Values outside the scale will be shown in the color corresponding to the min/max value, respectively.
-
- "
- )
-)
-
-##----------------------------------------------------------------------------##
-## UI elements to set X and Y scales in plot. Separate element because it
-## requires user input from other UI elements.
-##----------------------------------------------------------------------------##
-output[["expression_projection_scales_UI"]] <- renderUI({
-
- ## don't proceed without these inputs
- req(
- input[["expression_projection_to_display"]]
- )
-
- ## check if projection or trajectory should be shown
- ## ... projection
- if ( input[["expression_projection_to_display"]] %in% availableProjections() ) {
-
- ##
- XYranges <- getXYranges(getProjection(input[["expression_projection_to_display"]]))
-
- ## ... trajectory
- } else {
-
- ## split selection into method and name
- selection <- strsplit(input[["expression_projection_to_display"]], split = ' // ')[[1]]
-
- ## check if method and name exist and don't proceed if not
- req(
- selection[1] %in% getMethodsForTrajectories(),
- selection[2] %in% getNamesOfTrajectories(selection[1])
- )
-
- ## collect trajectory data
- trajectory_data <- getTrajectory(
- selection[1],
- selection[2]
- )
-
- ##
- XYranges <- getXYranges(trajectory_data[["meta"]])
- }
-
- tagList(
- sliderInput(
- "expression_projection_scale_x_manual_range",
- label = "Range of X axis",
- min = XYranges$x$min,
- max = XYranges$x$max,
- value = c(XYranges$x$min, XYranges$x$max)
- ),
- sliderInput(
- "expression_projection_scale_y_manual_range",
- label = "Range of Y axis",
- min = XYranges$y$min,
- max = XYranges$y$max,
- value = c(XYranges$y$min, XYranges$y$max)
- )
- )
-})
-
-## make sure elements are loaded even though the box is collapsed
-outputOptions(
- output,
- "expression_projection_scales_UI",
- suspendWhenHidden = FALSE
-)
-
-##----------------------------------------------------------------------------##
-## Plot of projection.
-##----------------------------------------------------------------------------##
-
-output[["expression_projection"]] <- plotly::renderPlotly({
-
- ## don't proceed without these inputs
- req(
- input[["expression_projection_to_display"]],
- input[["expression_projection_point_size"]],
- input[["expression_projection_point_opacity"]],
- input[["expression_projection_color_scale"]],
- input[["expression_projection_color_scale_range"]],
- input[["expression_projection_scale_x_manual_range"]],
- input[["expression_projection_scale_y_manual_range"]],
- gene_expression_plot_data()
- )
-
- ## check selected color scale
- ## ... selected color scale is "viridis"
- if ( input[["expression_projection_color_scale"]] == 'viridis' ) {
- color_scale <- 'Viridis'
-
- ## ... selected color scale is anything else than "viridis"
- } else {
- color_scale <- input[["expression_projection_color_scale"]]
- }
-
- ## check if projection or trajectory should be shown
- ## ... projection
- if ( input[["expression_projection_to_display"]] %in% availableProjections() ) {
-
- ## check if user requested to show expression in separate panels
- ## ... separate panels requested, two-dimensional projection selected, and
- ## "gene" column present
- if (
- ncol(getProjection(input[["expression_projection_to_display"]])) == 2 &&
- input[["expression_projection_show_genes_in_separate_panels"]] == TRUE &&
- "gene" %in% colnames(gene_expression_plot_data()) == TRUE
- ) {
-
- ## prepare plot
- plot <- plotExpressionMultiplePanels(gene_expression_plot_data())
-
- ## convert ggplot to plotly
- plot <- plotly::ggplotly(plot)
-
- ## ... if conditions for multiple panels are not met
- } else {
-
- ## prepare hover info
- hover_info <- buildHoverInfoForProjections(gene_expression_plot_data())
-
- ## add expression levels to hover info
- hover_info <- glue::glue(
- "{hover_info}
- Expression level: {formatC(gene_expression_plot_data()$level, format = 'f', digits = 3)}"
- )
-
- ## check if selection projection consists of 2 or 3 dimensions
- ## ... selection projection consists of 3 dimensions
- if ( ncol(getProjection(input[["expression_projection_to_display"]])) == 3 ) {
-
- ## prepare plot
- plot <- plotExpressionSinglePanel3D(gene_expression_plot_data(), color_scale, hover_info)
-
- ## ... selection projection consists of 2 dimensions
- } else if ( ncol(getProjection(input[["expression_projection_to_display"]])) == 2 ) {
-
- ## prepare plot
- plot <- plotExpressionSinglePanel2D(gene_expression_plot_data(), color_scale, hover_info)
- }
- }
-
- ## ... trajectory
- } else {
-
- ## split selection into method and name
- selection <- strsplit(input[["expression_projection_to_display"]], split = ' // ')[[1]]
-
- req(
- selection[1] %in% getMethodsForTrajectories(),
- selection[2] %in% getNamesOfTrajectories(selection[1])
- )
-
- ## collect trajectory data
- trajectory_data <- getTrajectory(
- selection[1],
- selection[2]
- )
-
- ## prepare hover info
- hover_info <- buildHoverInfoForProjections(gene_expression_plot_data())
-
- ## add expression levels to hover info
- hover_info <- glue::glue(
- "{hover_info}
- State: {gene_expression_plot_data()$state}
- Pseudotime: {formatC(gene_expression_plot_data()$pseudotime, format = 'f', digits = 2)}
- Expression level: {formatC(gene_expression_plot_data()$level, format = 'f', digits = 3)}"
- )
-
- plot <- plotExpressionSinglePanel2DTrajectory(
- gene_expression_plot_data(),
- trajectory_data[["edges"]],
- color_scale,
- hover_info
- )
- }
-
- ## return plot either with WebGL or without, depending on setting
- if ( preferences$use_webgl == TRUE ) {
- plot %>% plotly::toWebGL()
- } else {
- plot
- }
-})
-
-##----------------------------------------------------------------------------##
-## Text showing the number of selected cells.
-##----------------------------------------------------------------------------##
-
-output[["expression_number_of_selected_cells"]] <- renderText({
-
- ## don't proceed without these inputs
- req(
- input[["expression_projection_to_display"]],
- input[["expression_projection_point_size"]],
- input[["expression_projection_point_opacity"]],
- input[["expression_projection_color_scale"]],
- input[["expression_projection_color_scale_range"]],
- input[["expression_projection_scale_x_manual_range"]],
- input[["expression_projection_scale_y_manual_range"]],
- gene_expression_plot_data()
- )
-
- ## check selection
- ## ... selection has not been made or there is not cell in it
- if (
- is.null(plotly::event_data("plotly_selected", source = "expression_projection")) ||
- length(plotly::event_data("plotly_selected", source = "expression_projection")) == 0
- ) {
-
- ## manually set counter to 0
- number_of_selected_cells <- 0
-
- ## ... selection has been made and at least 1 cell is in it
- } else {
-
- ## get number of selected cells
- number_of_selected_cells <- nrow(plotly::event_data("plotly_selected", source = "expression_projection"))
- }
-
- ## prepare string to show
- paste0("Number of selected cells: ", number_of_selected_cells)
-})
-
-##----------------------------------------------------------------------------##
-## Text showing which genes are present and missing.
-##----------------------------------------------------------------------------##
-
-output[["expression_genes_displayed"]] <- renderText({
-
- ## don't proceed without these inputs
- req(
- genesToPlot()
- )
-
- ## prepare text output from reactive data
- paste0(
- "Showing expression for ",
- length(genesToPlot()[["genes_to_display_present"]]), " gene(s):
",
- paste0(genesToPlot()[["genes_to_display_present"]], collapse = ", "),
- "
",
- length(genesToPlot()[["genes_to_display_missing"]]),
- " gene(s) are not in data set:
",
- paste0(genesToPlot()[["genes_to_display_missing"]], collapse = ", ")
- )
-})
-
-##----------------------------------------------------------------------------##
-## Info box that gets shown when pressing the "info" button.
-##----------------------------------------------------------------------------##
-
-observeEvent(input[["expression_projection_info"]], {
- showModal(
- modalDialog(
- expression_projection_info$text,
- title = expression_projection_info$title,
- easyClose = TRUE,
- footer = NULL,
- size = "l"
- )
- )
-})
-
-##----------------------------------------------------------------------------##
-## Text in info box.
-##----------------------------------------------------------------------------##
-
-expression_projection_info <- list(
- title = "Dimensional reduction",
- text = HTML("
- Interactive projection of cells into two- or three-dimensional space based on their expression profile.
-
- - Both tSNE and UMAP are frequently used algorithms for dimensional reduction in single cell transcriptomics. While they generally allow to make similar conclusions, some differences exist between the two (please refer to Google and/or literature, such as Becht E. et al., Dimensionality reduction for visualizing single-cell data using UMAP. Nature Biotechnology, 2018, 37, 38-44).
- - Cell color reflects the log-normalised expression of entered genes. If more than 1 gene is entered or a gene set is selected, the color reflects the average expression of all genes. Genes must be in separate lines or separated by a space, comma, or semicolon. Reported below the projection are the genes that are present and absent in this data set. Absent genes could either have been annotated with a different name or were not expressed in any of the cells. Matching of gene names is case-insensitive, that means Myc/MYC/myc are treated equally.
- - Cells can be plotted either randomly (to give a more unbiased perspective) or in the order of expression (with highest expression plotted last), sometimes resulting in a more appealing figure.
- - The last two slider elements on the left can be used to resize the projection axes. This can be particularly useful when a projection contains a population of cell that is very far away from the rest and therefore creates a big empty space (which is not uncommon for UMAPs).
-
- The plot is interactive (drag and zoom) but depending on the computer of the user and the number of cells displayed it can become very slow.
- Experimental options
- Experimental options can be accessed from the gear icon next to the 'export to PDF' button.
- Show genes in separate panels
- When selecting multiple genes as input (up to 8), this option will show the expression of each gene in a separate panel instead of calculating the mean expression across all genes. The option is labeled as 'experimental' because of its poor implementation:
-
- - Hovering over the cells shows only limited information.
- - Cells cannot be shown with a (grey) border around them.
- - All genes have the some color scale.
- - Cells cannot be selected.
- - The 'Expression by group' panel needs to be deactivated.
- - It throws annoying but innocent warning messages in the log.
-
- Yet, this feature might be useful in some situations.
- "
- )
-)
-
-##----------------------------------------------------------------------------##
-## Export projection plot to PDF when pressing the "export to PDF" button.
-##----------------------------------------------------------------------------##
-
-observeEvent(input[["expression_projection_export"]], {
-
- ## don't proceed without these inputs
- req(
- input[["expression_projection_to_display"]],
- input[["expression_projection_plotting_order"]],
- input[["expression_projection_point_size"]],
- input[["expression_projection_point_opacity"]],
- input[["expression_projection_color_scale"]],
- input[["expression_projection_color_scale_range"]],
- input[["expression_projection_scale_x_manual_range"]],
- input[["expression_projection_scale_y_manual_range"]]
- )
-
- ## open dialog to select where plot should be saved and how the file should
- ## be named
- shinyFiles::shinyFileSave(
- input,
- id = "expression_projection_export",
- roots = available_storage_volumes,
- session = session,
- restrictions = system.file(package = "base")
- )
-
- ## retrieve info from dialog
- save_file_input <- shinyFiles::parseSavePath(available_storage_volumes, input[["expression_projection_export"]])
-
- ## only proceed if a path has been provided
- req(
- nrow(save_file_input) > 0
- )
-
- ## extract specified file path
- save_file_path <- as.character(save_file_input$datapath[1])
-
- ## check if projection or trajectory should be shown
- ## ... projection
- if ( input[["expression_projection_to_display"]] %in% availableProjections() ) {
-
- ## check if selection projection consists of 2 or 3 dimensions
- ## ... selection projection consists of 3 dimensions
- if ( ncol(getProjection(input[["expression_projection_to_display"]])) == 3 ) {
-
- ## give error message
- shinyWidgets::sendSweetAlert(
- session = session,
- title = "Sorry!",
- text = "It's currently not possible to create PDF plots from 3D dimensional reductions. Please use the PNG export button in the panel or a 2D dimensional reduction instead.",
- type = "error"
- )
-
- ## ... selection projection consists of 2 dimensions
- } else if ( ncol(getProjection(input[["expression_projection_to_display"]])) == 2 ) {
-
- ## ... separate panels requested and "gene" column present
- if (
- input[["expression_projection_show_genes_in_separate_panels"]] == TRUE &&
- "gene" %in% colnames(gene_expression_plot_data()) == TRUE
- ) {
-
- ## prepare plot
- plot <- plotExpressionMultiplePanels(gene_expression_plot_data())
-
- ## ...
- } else {
-
- ## prepare plot
- plot <- plotExpressionSinglePanel2DExport(gene_expression_plot_data())
- }
- }
-
- ## ... trajectory
- } else {
-
- ## split selection into method and name
- selection <- strsplit(input[["expression_projection_to_display"]], split = ' // ')[[1]]
-
- req(
- selection[1] %in% getMethodsForTrajectories(),
- selection[2] %in% getNamesOfTrajectories(selection[1])
- )
-
- ## collect trajectory data
- trajectory_data <- getTrajectory(
- selection[1],
- selection[2]
- )
-
- ## prepare plot
- plot <- plotExpressionSinglePanel2DTrajectoryExport(
- gene_expression_plot_data(),
- trajectory_data[["edges"]]
- )
- }
-
- ## plot must be a ggplot object, otherwise don't proceed
- req(
- is.ggplot(plot)
- )
-
- ## save plot
- pdf(NULL)
- ggsave(save_file_path, plot, height = 8, width = 11)
-
- ## check if file was succesfully saved
- ## ... successful
- if ( file.exists(save_file_path) ) {
-
- ## give positive message
- shinyWidgets::sendSweetAlert(
- session = session,
- title = "Success!",
- text = paste0("Plot saved successfully as: ", save_file_path),
- type = "success"
- )
-
- ## ... failed
- } else {
-
- ## give negative message
- shinyWidgets::sendSweetAlert(
- session = session,
- title = "Error!",
- text = "Sorry, it seems something went wrong...",
- type = "error"
- )
- }
-})
diff --git a/inst/shiny/v1.3/gene_expression/server.R b/inst/shiny/v1.3/gene_expression/server.R
index 45c921e..84a1c14 100644
--- a/inst/shiny/v1.3/gene_expression/server.R
+++ b/inst/shiny/v1.3/gene_expression/server.R
@@ -1,202 +1,12 @@
##----------------------------------------------------------------------------##
## Tab: Gene (set) expression
##----------------------------------------------------------------------------##
-
-source(paste0(Cerebro.options[["cerebro_root"]], "/shiny/v1.3/gene_expression/projection.R"), local = TRUE)
-source(paste0(Cerebro.options[["cerebro_root"]], "/shiny/v1.3/gene_expression/table_of_selected_cells.R"), local = TRUE)
-source(paste0(Cerebro.options[["cerebro_root"]], "/shiny/v1.3/gene_expression/expression_in_selected_cells.R"), local = TRUE)
-source(paste0(Cerebro.options[["cerebro_root"]], "/shiny/v1.3/gene_expression/expression_by_group.R"), local = TRUE)
-source(paste0(Cerebro.options[["cerebro_root"]], "/shiny/v1.3/gene_expression/expression_by_gene.R"), local = TRUE)
-source(paste0(Cerebro.options[["cerebro_root"]], "/shiny/v1.3/gene_expression/expression_by_pseudotime.R"), local = TRUE)
-
-##----------------------------------------------------------------------------##
-## Reactive data that holds genes provided by user or in selected gene set.
-##----------------------------------------------------------------------------##
-
-## cannot use req() because it delays initialization and plot is updated only
-## with button press so plot doesn't initialize at all
-genesToPlot <- reactive({
-
- ## prepare empty list for data
- gene_sets <- list(
- "genes_to_display" = character(),
- "genes_to_display_present" = character(),
- "genes_to_display_missing" = character()
- )
-
- if ( input[["expression_analysis_mode"]] == "Gene(s)" ) {
-
- ## check if user provided input in gene box
- ## ... if user provided input
- if ( is.null(input[["expression_genes_input"]]) == FALSE ) {
-
- ## - grab user input
- ## - split by comma, space, semicolon and line
- ## - convert to vector
- ## - remove spaces
- ## - remove duplicated strings
- ## - remove empty strings
- gene_sets[["genes_to_display"]] <- input[["expression_genes_input"]] %>%
- strsplit(",| |;|\n") %>%
- unlist() %>%
- gsub(pattern = " ", replacement = "", fixed = TRUE) %>%
- unique() %>%
- .[. != ""]
- }
-
- } else if ( input[["expression_analysis_mode"]] == "Gene set" ) {
-
- ##
- req(
- input[["expression_select_gene_set"]]
- )
-
- gene_sets[["genes_to_display"]] <- getGenesForGeneSet(input[["expression_select_gene_set"]])
- }
-
- ## check which are available in the data set
- genes_to_display_here <- getGeneNames()[ match(tolower(gene_sets[["genes_to_display"]]), tolower(getGeneNames())) ]
-
- ## get which genes are available in the data set
- gene_sets[["genes_to_display_present"]] <- na.omit(genes_to_display_here)
-
- ## get names of provided genes that are not in the data set
- gene_sets[["genes_to_display_missing"]] <- gene_sets[["genes_to_display"]][ which(is.na(genes_to_display_here)) ]
-
- return(gene_sets)
-})
-
-##----------------------------------------------------------------------------##
-## Reactive data that holds data to be plotted.
-##----------------------------------------------------------------------------##
-
-gene_expression_plot_data <- reactive({
-
- ## don't proceed without these inputs
- req(
- input[["expression_projection_to_display"]],
- input[["expression_percentage_cells_to_show"]],
- input[["expression_projection_plotting_order"]],
- !is.null(input[["expression_projection_show_genes_in_separate_panels"]]),
- genesToPlot()
- )
-
- ## check if projection or trajectory should be shown
- ## ... projection
- if ( input[["expression_projection_to_display"]] %in% availableProjections() ) {
-
- ## build data frame with data
- cells_df <- cbind(
- getProjection(input[["expression_projection_to_display"]]),
- getMetaData()
- )
-
- ## ... trajectory
- } else {
-
- ## split selection into method and name
- selection <- strsplit(input[["expression_projection_to_display"]], split = ' // ')[[1]]
-
- ## check if method and name exist and don't proceed if not
- req(
- selection[1] %in% getMethodsForTrajectories(),
- selection[2] %in% getNamesOfTrajectories(selection[1])
- )
-
- ## collect trajectory data
- trajectory_data <- getTrajectory(
- selection[1],
- selection[2]
- )
-
- ## merge meta data and trajectory info and remove cells without pseudotime
- cells_df <- cbind(trajectory_data[["meta"]], getMetaData()) %>%
- dplyr::filter(!is.na(pseudotime))
- }
-
- ## available group filters
- group_filters <- names(input)[grepl(names(input), pattern = 'expression_projection_group_filter_')]
-
- ## remove cells based on group filters
- for ( i in group_filters ) {
- group <- strsplit(i, split = 'expression_projection_group_filter_')[[1]][2]
- if ( group %in% colnames(cells_df) ) {
- cells_df <- cells_df[which(cells_df[[group]] %in% input[[i]] ),]
- }
- }
-
- ## randomly remove cells (if necessary)
- cells_df <- randomlySubsetCells(cells_df, input[["expression_percentage_cells_to_show"]])
-
- ## get expression values that will be plotted; depends on how many genes are
- ## available
- ## ... no genes are available
- if ( length(genesToPlot()$genes_to_display_present) == 0 ) {
-
- ## set expression level to 0
- cells_df$level <- 0
-
- ## ... at least 1 gene is available
- } else {
-
- ## check if user requested to show expression in separate panels
- ## ... separate panels requested, at least 2 genes but not more than 8
- ## genes selected
- if (
- input[["expression_projection_show_genes_in_separate_panels"]] == TRUE &&
- input[["expression_projection_to_display"]] %in% availableProjections() &&
- length(genesToPlot()$genes_to_display_present) >= 2 &&
- length(genesToPlot()$genes_to_display_present) <= 8
- ) {
-
- ## - get expression matrix
- ## - transpose matrix
- ## - convert to data frame with genes as columns and cells as rows
- ## - add projection coordinates (only first two columns because 3D is not
- ## supported anyway)
- ## - bring data in longer format
- ## NOTE: I don't merge the expression value with cell meta data because
- ## hover info doesn't work properly anyway so like this the data
- ## frame stays smaller, especially with large data sets
- cells_df <- getExpressionMatrix(
- cells = cells_df$cell_barcode,
- genes = genesToPlot()$genes_to_display_present
- ) %>%
- Matrix::t() %>%
- as.data.frame() %>%
- cbind(cells_df[,1:2], .) %>%
- tidyr::pivot_longer(
- cols = tidyselect::all_of(genesToPlot()$genes_to_display_present),
- names_to = "gene",
- values_to = "level"
- )
-
- ## ... if proper conditions for separate panels are not met
- } else {
-
- ## calculate mean across all genes for each cell
- cells_df$level <- getMeanExpressionForCells(
- cells = cells_df$cell_barcode,
- genes = genesToPlot()$genes_to_display_present
- )
- }
- }
-
- ## set plotting order, depending on user input
- plot_order <- input[["expression_projection_plotting_order"]]
-
- ## ... if plotting order is random
- if ( plot_order == "Random" ) {
-
- ## randomize row order
- cells_df <- cells_df[ sample(1:nrow(cells_df), nrow(cells_df)) , ]
-
- ## ... if plotting order is from high to low
- } else if ( plot_order == "Highest expression on top" ) {
-
- ## sort rows by expression level from low to high
- cells_df <- cells_df[ order(cells_df$level, decreasing = FALSE) , ]
- }
-
- return(cells_df)
-})
+files_to_load <- list.files(
+ paste0(Cerebro.options[["cerebro_root"]], "/shiny/v1.3/gene_expression"),
+ pattern = "func_|obj_|UI_|out_|event_",
+ full.names = TRUE
+)
+
+for ( i in files_to_load ) {
+ source(i, local = TRUE)
+}
diff --git a/inst/shiny/v1.3/gene_id_conversion/UI.R b/inst/shiny/v1.3/gene_id_conversion/UI.R
index 7736d9a..b553d2f 100644
--- a/inst/shiny/v1.3/gene_id_conversion/UI.R
+++ b/inst/shiny/v1.3/gene_id_conversion/UI.R
@@ -1,7 +1,6 @@
##----------------------------------------------------------------------------##
## Tab: Gene ID/symbol conversion
##----------------------------------------------------------------------------##
-
tab_gene_id_conversion <- tabItem(
tabName = "geneIdConversion",
fluidRow(
diff --git a/inst/shiny/v1.3/gene_id_conversion/server.R b/inst/shiny/v1.3/gene_id_conversion/server.R
index ec6385d..54bece0 100644
--- a/inst/shiny/v1.3/gene_id_conversion/server.R
+++ b/inst/shiny/v1.3/gene_id_conversion/server.R
@@ -1,11 +1,6 @@
-##----------------------------------------------------------------------------##
-## Tab: Gene ID/symbol conversion
-##----------------------------------------------------------------------------##
-
##----------------------------------------------------------------------------##
## Table of gene IDs and symbols.
##----------------------------------------------------------------------------##
-
output[["gene_info"]] <- DT::renderDataTable({
if ( input[["geneIdConversion_organism"]] == "mouse" ) {
conversion_table <- read.table(
@@ -37,7 +32,6 @@ output[["gene_info"]] <- DT::renderDataTable({
##----------------------------------------------------------------------------##
## Info box that gets shown when pressing the "info" button.
##----------------------------------------------------------------------------##
-
observeEvent(input[["geneIdConversion_info"]], {
showModal(
modalDialog(
@@ -53,7 +47,6 @@ observeEvent(input[["geneIdConversion_info"]], {
##----------------------------------------------------------------------------##
## Text in info box.
##----------------------------------------------------------------------------##
-
geneIdConversion_info <- list(
title = "Gene ID/symbol conversion",
text = p("Conversion table containing Gencode identifiers, Ensembl identifiers, Havana identifiers, gene symbol and gene type for mouse (version M16) and human (version 27).")
diff --git a/inst/shiny/v1.3/groups/UI.R b/inst/shiny/v1.3/groups/UI.R
index 0c21e2e..6d0591b 100644
--- a/inst/shiny/v1.3/groups/UI.R
+++ b/inst/shiny/v1.3/groups/UI.R
@@ -1,7 +1,6 @@
##----------------------------------------------------------------------------##
## Tab: Groups
##----------------------------------------------------------------------------##
-
tab_groups <- tabItem(
tabName = "groups",
shinyjs::inlineCSS("
diff --git a/inst/shiny/v1.3/groups/cell_cycle.R b/inst/shiny/v1.3/groups/cell_cycle.R
index 105654d..c99450d 100644
--- a/inst/shiny/v1.3/groups/cell_cycle.R
+++ b/inst/shiny/v1.3/groups/cell_cycle.R
@@ -1,13 +1,10 @@
##----------------------------------------------------------------------------##
-## Tab: Groups
-##
## Composition by cell cycle.
##----------------------------------------------------------------------------##
##----------------------------------------------------------------------------##
## UI element for output.
##----------------------------------------------------------------------------##
-
output[["groups_cell_cycle_UI"]] <- renderUI({
fluidRow(
cerebroBox(
@@ -27,7 +24,6 @@ output[["groups_cell_cycle_UI"]] <- renderUI({
## UI element that either shows buttons or a text message if data is not
## available.
##----------------------------------------------------------------------------##
-
output[["groups_by_cell_cycle_UI_buttons"]] <- renderUI({
if ( length(getCellCycle()) > 0 ) {
tagList(
@@ -75,7 +71,6 @@ output[["groups_by_cell_cycle_UI_buttons"]] <- renderUI({
##----------------------------------------------------------------------------##
## UI element that either shows the plot (and a table if selected) or nothing.
##----------------------------------------------------------------------------##
-
output[["groups_by_cell_cycle_UI_rest"]] <- renderUI({
if ( length(getCellCycle()) > 0 ) {
tagList(
@@ -92,19 +87,13 @@ output[["groups_by_cell_cycle_UI_rest"]] <- renderUI({
##----------------------------------------------------------------------------##
## Bar plot.
##----------------------------------------------------------------------------##
-
output[["groups_by_cell_cycle_plot"]] <- plotly::renderPlotly({
-
- ##
req(
- input[["groups_selected_group"]],
- input[["groups_by_cell_cycle_column"]],
+ input[["groups_selected_group"]] %in% getGroups(),
+ input[["groups_by_cell_cycle_column"]] %in% getCellCycle(),
input[["groups_by_cell_cycle_plot_type"]]
)
-
- ##
if ( input[["groups_by_cell_cycle_plot_type"]] == "Bar chart" ) {
-
## calculate table
composition_df <- calculateTableAB(
getMetaData(),
@@ -113,7 +102,6 @@ output[["groups_by_cell_cycle_plot"]] <- plotly::renderPlotly({
mode = "long",
percent = input[["groups_by_cell_cycle_show_as_percent"]]
)
-
## generate plot
plotlyBarChart(
table = composition_df,
@@ -122,10 +110,8 @@ output[["groups_by_cell_cycle_plot"]] <- plotly::renderPlotly({
colors = reactive_colors()[[ input[[ "groups_by_cell_cycle_column" ]] ]],
percent = input[["groups_by_cell_cycle_show_as_percent"]]
)
-
##
} else if ( input[["groups_by_cell_cycle_plot_type"]] == "Sankey plot" ) {
-
## calculate table
composition_df <- calculateTableAB(
getMetaData(),
@@ -134,13 +120,11 @@ output[["groups_by_cell_cycle_plot"]] <- plotly::renderPlotly({
mode = "long",
percent = FALSE
)
-
## get color code for all group levels (from both groups)
colors_for_groups <- c(
assignColorsToGroups(composition_df, input[[ "groups_selected_group" ]]),
assignColorsToGroups(composition_df, input[[ "groups_by_cell_cycle_column" ]])
)
-
## generate plot
plotlySankeyPlot(
table = composition_df,
@@ -156,13 +140,11 @@ output[["groups_by_cell_cycle_plot"]] <- plotly::renderPlotly({
##----------------------------------------------------------------------------##
output[["groups_by_cell_cycle_table"]] <- DT::renderDataTable({
-
##
req(
- input[["groups_selected_group"]],
- input[["groups_by_cell_cycle_column"]],
+ input[["groups_selected_group"]] %in% getGroups(),
+ input[["groups_by_cell_cycle_column"]] %in% getCellCycle(),
)
-
##
composition_df <- calculateTableAB(
getMetaData(),
@@ -171,14 +153,12 @@ output[["groups_by_cell_cycle_table"]] <- DT::renderDataTable({
mode = "wide",
percent = input[["groups_by_cell_cycle_show_as_percent"]]
)
-
## get indices of columns that should be formatted as percent
if ( input[["groups_by_cell_cycle_show_as_percent"]] == TRUE ) {
columns_percentage <- c(3:ncol(composition_df))
} else {
columns_percentage <- NULL
}
-
##
composition_df %>%
dplyr::rename("# of cells" = total_cell_count) %>%
@@ -196,7 +176,6 @@ output[["groups_by_cell_cycle_table"]] <- DT::renderDataTable({
##----------------------------------------------------------------------------##
## Alternative text message if data is missing.
##----------------------------------------------------------------------------##
-
output[["groups_by_cell_cycle_text"]] <- renderText({
"No cell cycle assignments available."
})
@@ -204,7 +183,6 @@ output[["groups_by_cell_cycle_text"]] <- renderText({
##----------------------------------------------------------------------------##
## Info box that gets shown when pressing the "info" button.
##----------------------------------------------------------------------------##
-
observeEvent(input[["groups_by_cell_cycle_info"]], {
showModal(
modalDialog(
@@ -220,7 +198,6 @@ observeEvent(input[["groups_by_cell_cycle_info"]], {
##----------------------------------------------------------------------------##
## Text in info box.
##----------------------------------------------------------------------------##
-
groups_by_cell_cycle_info <- list(
title = "Cell cycle analysis",
text = p("Shown here is the relationship between the subpopulations of the selected grouping variable and the selected cell cycle assignments. If these assignments were generated with the method embedded in the Seurat framework, for each cell, a score is calculated for both G2M and S phase based on lists of genes (see 'Analysis info' tab on the left). The cell cycle phase is then assigned on the basis of these scores.")
diff --git a/inst/shiny/v1.3/groups/composition.R b/inst/shiny/v1.3/groups/composition.R
index a09e6ff..ef782ed 100644
--- a/inst/shiny/v1.3/groups/composition.R
+++ b/inst/shiny/v1.3/groups/composition.R
@@ -1,13 +1,10 @@
##----------------------------------------------------------------------------##
-## Tab: Groups
-##
## Composition of selected group by other group.
##----------------------------------------------------------------------------##
##----------------------------------------------------------------------------##
## UI element for output.
##----------------------------------------------------------------------------##
-
output[["groups_composition_UI"]] <- renderUI({
fluidRow(
cerebroBox(
@@ -26,14 +23,8 @@ output[["groups_composition_UI"]] <- renderUI({
##----------------------------------------------------------------------------##
## UI elements to select second grouping variable and buttons.
##----------------------------------------------------------------------------##
-
output[["groups_by_other_group_other_group_buttons_UI"]] <- renderUI({
-
- ##
- req(
- input[[ "groups_selected_group" ]]
- )
-
+ req(input[[ "groups_selected_group" ]] %in% getGroups())
tagList(
selectInput(
"groups_by_other_group_second_group",
@@ -77,10 +68,7 @@ output[["groups_by_other_group_other_group_buttons_UI"]] <- renderUI({
## UI element that shows either just the plot or also the table, depending on
## buttons.
##----------------------------------------------------------------------------##
-
output[["groups_by_other_group_output_UI"]] <- renderUI({
-
- ##
tagList(
plotly::plotlyOutput("groups_by_other_group_plot"),
{
@@ -97,21 +85,17 @@ output[["groups_by_other_group_output_UI"]] <- renderUI({
##----------------------------------------------------------------------------##
## Plot showing composition of groups, either as a bar chart or a Sankey plot.
##----------------------------------------------------------------------------##
-
output[["groups_by_other_group_plot"]] <- plotly::renderPlotly({
-
## only proceed if the two groups are not the same (otherwise it can give an
## error when switching between groups)
req(
- input[["groups_selected_group"]],
- input[["groups_by_other_group_second_group"]],
+ input[["groups_selected_group"]] %in% getGroups(),
+ input[["groups_by_other_group_second_group"]] %in% getGroups(),
input[["groups_selected_group"]] != input[["groups_by_other_group_second_group"]],
input[["groups_by_other_group_plot_type"]]
)
-
##
if ( input[["groups_by_other_group_plot_type"]] == "Bar chart" ) {
-
## calculate table
composition_df <- calculateTableAB(
getMetaData(),
@@ -120,7 +104,6 @@ output[["groups_by_other_group_plot"]] <- plotly::renderPlotly({
mode = "long",
percent = input[["groups_by_other_group_show_as_percent"]]
)
-
## generate plot
plotlyBarChart(
table = composition_df,
@@ -129,10 +112,8 @@ output[["groups_by_other_group_plot"]] <- plotly::renderPlotly({
colors = reactive_colors()[[ input[[ "groups_by_other_group_second_group" ]] ]],
percent = input[["groups_by_other_group_show_as_percent"]]
)
-
##
} else if ( input[["groups_by_other_group_plot_type"]] == "Sankey plot" ) {
-
## calculate table
composition_df <- calculateTableAB(
getMetaData(),
@@ -141,13 +122,11 @@ output[["groups_by_other_group_plot"]] <- plotly::renderPlotly({
mode = "long",
percent = FALSE
)
-
## get color code for all group levels (from both groups)
colors_for_groups <- c(
assignColorsToGroups(composition_df, input[[ "groups_selected_group" ]]),
assignColorsToGroups(composition_df, input[[ "groups_by_other_group_second_group" ]])
)
-
## generate plot
plotlySankeyPlot(
table = composition_df,
@@ -161,9 +140,7 @@ output[["groups_by_other_group_plot"]] <- plotly::renderPlotly({
##----------------------------------------------------------------------------##
## Table showing numbers of plot.
##----------------------------------------------------------------------------##
-
output[["groups_by_other_group_table"]] <- DT::renderDataTable({
-
## only proceed if the two groups are not the same (otherwise it can give an
## error when switching between groups)
req(
@@ -171,7 +148,6 @@ output[["groups_by_other_group_table"]] <- DT::renderDataTable({
input[[ "groups_by_other_group_second_group" ]],
input[[ "groups_selected_group" ]] != input[[ "groups_by_other_group_second_group" ]]
)
-
## generate table
composition_df <- calculateTableAB(
getMetaData(),
@@ -180,14 +156,12 @@ output[["groups_by_other_group_table"]] <- DT::renderDataTable({
mode = "wide",
percent = input[["groups_by_other_group_show_as_percent"]]
)
-
## get indices of columns that should be formatted as percent
if ( input[["groups_by_other_group_show_as_percent"]] == TRUE ) {
columns_percentage <- c(3:ncol(composition_df))
} else {
columns_percentage <- NULL
}
-
composition_df %>%
dplyr::rename("# of cells" = total_cell_count) %>%
prettifyTable(
@@ -204,7 +178,6 @@ output[["groups_by_other_group_table"]] <- DT::renderDataTable({
##----------------------------------------------------------------------------##
## Info box that gets shown when pressing the "info" button.
##----------------------------------------------------------------------------##
-
observeEvent(input[["groups_by_other_group_info"]], {
showModal(
modalDialog(
@@ -220,7 +193,6 @@ observeEvent(input[["groups_by_other_group_info"]], {
##----------------------------------------------------------------------------##
## Text in info box.
##----------------------------------------------------------------------------##
-
groups_by_other_group_info <- list(
title = "Composition of group by another group",
text = HTML("This plot allows to see how cell groups are related to each other. This can be represented as a bar char or a Sankey plot. Optionally, a table can be shown below. To highlight composition in very small cell groups, results can be shown as percentages rather than actual cell counts. Groups can be removed from the plot by clicking on them in the legend.")
diff --git a/inst/shiny/v1.3/groups/expression_metrics.R b/inst/shiny/v1.3/groups/expression_metrics.R
index 0389e25..a62a758 100644
--- a/inst/shiny/v1.3/groups/expression_metrics.R
+++ b/inst/shiny/v1.3/groups/expression_metrics.R
@@ -1,6 +1,4 @@
##----------------------------------------------------------------------------##
-## Tab: Groups
-##
## Expression metrics:
## - number of transcripts
## - number of expressed genes
@@ -11,7 +9,6 @@
##----------------------------------------------------------------------------##
## UI element for output.
##----------------------------------------------------------------------------##
-
output[["groups_expression_metrics_UI"]] <- renderUI({
fluidRow(
cerebroBox(
@@ -47,7 +44,6 @@ output[["groups_expression_metrics_UI"]] <- renderUI({
##----------------------------------------------------------------------------##
## Number of transcripts.
##----------------------------------------------------------------------------##
-
output[["groups_nUMI_UI"]] <- renderUI({
if ( "nUMI" %in% colnames(getMetaData()) ) {
plotly::plotlyOutput("groups_nUMI_plot")
@@ -61,13 +57,7 @@ output[["groups_nUMI_text"]] <- renderText({
})
output[["groups_nUMI_plot"]] <- plotly::renderPlotly({
-
- ##
- req(
- input[["groups_selected_group"]]
- )
-
- ##
+ req(input[["groups_selected_group"]] %in% getGroups())
plotlyViolin(
table = getMetaData(),
metric = "nUMI",
@@ -81,7 +71,6 @@ output[["groups_nUMI_plot"]] <- plotly::renderPlotly({
##----------------------------------------------------------------------------##
## Number of expressed genes.
##----------------------------------------------------------------------------##
-
output[["groups_nGene_UI"]] <- renderUI({
if ( "nGene" %in% colnames(getMetaData()) ) {
plotly::plotlyOutput("groups_nGene_plot")
@@ -95,13 +84,7 @@ output[["groups_nGene_text"]] <- renderText({
})
output[["groups_nGene_plot"]] <- plotly::renderPlotly({
-
- ##
- req(
- input[["groups_selected_group"]]
- )
-
- ##
+ req(input[["groups_selected_group"]] %in% getGroups())
plotlyViolin(
table = getMetaData(),
metric = "nGene",
@@ -115,7 +98,6 @@ output[["groups_nGene_plot"]] <- plotly::renderPlotly({
##----------------------------------------------------------------------------##
## Expression from mitochondrial genes.
##----------------------------------------------------------------------------##
-
output[["groups_percent_mt_UI"]] <- renderUI({
if ( "percent_mt" %in% colnames(getMetaData()) ) {
plotly::plotlyOutput("groups_percent_mt_plot")
@@ -129,13 +111,7 @@ output[["groups_percent_mt_text"]] <- renderText({
})
output[["groups_percent_mt_plot"]] <- plotly::renderPlotly({
-
- ##
- req(
- input[["groups_selected_group"]]
- )
-
- ##
+ req(input[["groups_selected_group"]] %in% getGroups())
plotlyViolin(
table = getMetaData(),
metric = "percent_mt",
@@ -149,7 +125,6 @@ output[["groups_percent_mt_plot"]] <- plotly::renderPlotly({
##----------------------------------------------------------------------------##
## Expression from ribosomal genes.
##----------------------------------------------------------------------------##
-
output[["groups_percent_ribo_UI"]] <- renderUI({
if ( "percent_ribo" %in% colnames(getMetaData()) ) {
plotly::plotlyOutput("groups_percent_ribo_plot")
@@ -163,13 +138,7 @@ output[["groups_percent_ribo_text"]] <- renderText({
})
output[["groups_percent_ribo_plot"]] <- plotly::renderPlotly({
-
- ##
- req(
- input[["groups_selected_group"]]
- )
-
- ##
+ req(input[["groups_selected_group"]] %in% getGroups())
plotlyViolin(
table = getMetaData(),
metric = "percent_ribo",
@@ -183,7 +152,6 @@ output[["groups_percent_ribo_plot"]] <- plotly::renderPlotly({
##----------------------------------------------------------------------------##
## Info box that gets shown when pressing the "info" button.
##----------------------------------------------------------------------------##
-
observeEvent(input[["groups_expression_metrics_info"]], {
showModal(
modalDialog(
@@ -199,7 +167,6 @@ observeEvent(input[["groups_expression_metrics_info"]], {
##----------------------------------------------------------------------------##
## Text in info box.
##----------------------------------------------------------------------------##
-
groups_expression_metrics_info <- list(
title = "Number of transcripts",
text = HTML("Violin plots showing the number of transcripts (nUMI/nCounts), the number of expressed genes (nGene/nFeature), as well as the percentage of transcripts coming from mitochondrial and ribosomal genes in each group.")
diff --git a/inst/shiny/v1.3/groups/select_group.R b/inst/shiny/v1.3/groups/select_group.R
index 51e5b59..cfd4236 100644
--- a/inst/shiny/v1.3/groups/select_group.R
+++ b/inst/shiny/v1.3/groups/select_group.R
@@ -1,13 +1,10 @@
##----------------------------------------------------------------------------##
-## Tab: Groups
-##
## Select group.
##----------------------------------------------------------------------------##
##----------------------------------------------------------------------------##
## UI element to select which group should be shown.
##----------------------------------------------------------------------------##
-
output[["groups_select_group_UI"]] <- renderUI({
tagList(
div(
diff --git a/inst/shiny/v1.3/groups/server.R b/inst/shiny/v1.3/groups/server.R
index 5b45562..1edf58b 100644
--- a/inst/shiny/v1.3/groups/server.R
+++ b/inst/shiny/v1.3/groups/server.R
@@ -1,7 +1,6 @@
##----------------------------------------------------------------------------##
## Tab: Groups
##----------------------------------------------------------------------------##
-
source(paste0(Cerebro.options[["cerebro_root"]], "/shiny/v1.3/groups/select_group.R"), local = TRUE)
source(paste0(Cerebro.options[["cerebro_root"]], "/shiny/v1.3/groups/tree.R"), local = TRUE)
source(paste0(Cerebro.options[["cerebro_root"]], "/shiny/v1.3/groups/composition.R"), local = TRUE)
diff --git a/inst/shiny/v1.3/groups/tree.R b/inst/shiny/v1.3/groups/tree.R
index 2f8d91b..d6b786b 100644
--- a/inst/shiny/v1.3/groups/tree.R
+++ b/inst/shiny/v1.3/groups/tree.R
@@ -1,13 +1,10 @@
##----------------------------------------------------------------------------##
-## Tab: Groups
-##
## Relationship tree.
##----------------------------------------------------------------------------##
##----------------------------------------------------------------------------##
## UI element for output.
##----------------------------------------------------------------------------##
-
output[["groups_tree_UI"]] <- renderUI({
fluidRow(
cerebroBox(
@@ -70,13 +67,7 @@ output[["groups_tree_UI"]] <- renderUI({
##----------------------------------------------------------------------------##
output[["groups_tree_plot_or_message"]] <- renderUI({
-
- ##
- req(
- input[["groups_selected_group"]]
- )
-
- ##
+ req(input[["groups_selected_group"]] %in% getGroups())
if ( !is.null(getTree( input[["groups_selected_group"]] )) ) {
tagList(
shinyWidgets::radioGroupButtons(
@@ -100,32 +91,25 @@ output[["groups_tree_plot_or_message"]] <- renderUI({
##----------------------------------------------------------------------------##
output[["groups_tree_plot"]] <- renderPlot({
-
- ##
req(
- input[["groups_selected_group"]],
+ input[["groups_selected_group"]] %in% getGroups(),
input[["groups_tree_edge_width"]],
input[["groups_tree_label_size"]],
input[["groups_tree_label_offset"]],
!is.null(input[["groups_tree_margin"]])
)
-
## only proceed if tree is present (this check is necessary because it can
## otherwise result in an error when switching between groups)
if (
!is.null(getTree( input[["groups_selected_group"]] )) &&
class(getTree( input[["groups_selected_group"]] )) == 'phylo'
) {
-
## retrieve tree from Cerebro object
tree <- getTree( input[["groups_selected_group"]] )
-
## get color assignments for groups
group_colors <- reactive_colors()[[ input[["groups_selected_group"]] ]]
-
## get put colors in correct order
tip_colors <- group_colors[match(tree$tip.label, names(group_colors))]
-
##
if ( input[["groups_tree_plot_type"]] == "Unrooted" ) {
ape::plot.phylo(
@@ -140,7 +124,6 @@ output[["groups_tree_plot"]] <- renderPlot({
cex = input[["groups_tree_label_size"]],
no.margin = input[["groups_tree_margin"]]
)
-
##
} else if ( input[["groups_tree_plot_type"]] == "Phylogram" ) {
ape::plot.phylo(
@@ -164,13 +147,11 @@ output[["groups_tree_plot"]] <- renderPlot({
##----------------------------------------------------------------------------##
## Alternative text message if data is missing.
##----------------------------------------------------------------------------##
-
output[["groups_tree_text"]] <- renderText({ "Data not available." })
##----------------------------------------------------------------------------##
## Info box that gets shown when pressing the "info" button.
##----------------------------------------------------------------------------##
-
observeEvent(input[["groups_tree_info"]], {
showModal(
modalDialog(
@@ -186,7 +167,6 @@ observeEvent(input[["groups_tree_info"]], {
##----------------------------------------------------------------------------##
## Text in info box.
##----------------------------------------------------------------------------##
-
groups_tree_info <- list(
title = "Relationship tree",
text = p("The relationship tree reflects the similarity of groups based on their expression profiles. Instead of using the expression values, the correlation is calculated using the user-specified number of principal components (see 'Analysis info' tab on the left).")
diff --git a/inst/shiny/v1.3/load_data/UI.R b/inst/shiny/v1.3/load_data/UI.R
index 3df206b..ae9271d 100644
--- a/inst/shiny/v1.3/load_data/UI.R
+++ b/inst/shiny/v1.3/load_data/UI.R
@@ -1,7 +1,6 @@
##----------------------------------------------------------------------------##
## Tab: Load data
##----------------------------------------------------------------------------##
-
tab_load_data <- tabItem(
tabName = "loadData",
uiOutput("load_data_select_file_UI"),
diff --git a/inst/shiny/v1.3/load_data/sample_info.R b/inst/shiny/v1.3/load_data/sample_info.R
index 1bcdd0f..69f19e0 100644
--- a/inst/shiny/v1.3/load_data/sample_info.R
+++ b/inst/shiny/v1.3/load_data/sample_info.R
@@ -1,13 +1,10 @@
##----------------------------------------------------------------------------##
-## Tab: Load data
-##
## Sample info.
##----------------------------------------------------------------------------##
##----------------------------------------------------------------------------##
## UI elements that show some basic information about the loaded data set.
##----------------------------------------------------------------------------##
-
output[["load_data_sample_info_UI"]] <- renderUI({
tagList(
fluidRow(
@@ -32,7 +29,6 @@ output[["load_data_sample_info_UI"]] <- renderUI({
## - date of analysis
## - date of export
##----------------------------------------------------------------------------##
-
## experiment name
output[["load_data_experiment_name"]] <- renderValueBox({
valueBox(
diff --git a/inst/shiny/v1.3/load_data/server.R b/inst/shiny/v1.3/load_data/server.R
index 05f6fb1..c1a0065 100644
--- a/inst/shiny/v1.3/load_data/server.R
+++ b/inst/shiny/v1.3/load_data/server.R
@@ -1,6 +1,5 @@
##----------------------------------------------------------------------------##
## Tab: Load data
##----------------------------------------------------------------------------##
-
source(paste0(Cerebro.options[["cerebro_root"]], "/shiny/v1.3/load_data/select_file.R"), local = TRUE)
source(paste0(Cerebro.options[["cerebro_root"]], "/shiny/v1.3/load_data/sample_info.R"), local = TRUE)
diff --git a/inst/shiny/v1.3/marker_genes/UI.R b/inst/shiny/v1.3/marker_genes/UI.R
index dd50eed..ab58451 100644
--- a/inst/shiny/v1.3/marker_genes/UI.R
+++ b/inst/shiny/v1.3/marker_genes/UI.R
@@ -1,7 +1,6 @@
##----------------------------------------------------------------------------##
## Tab: Marker genes
##----------------------------------------------------------------------------##
-
tab_marker_genes <- tabItem(
tabName = "markerGenes",
shinyjs::inlineCSS("
diff --git a/inst/shiny/v1.3/marker_genes/select_content.R b/inst/shiny/v1.3/marker_genes/select_content.R
index eb80c09..4ff2231 100644
--- a/inst/shiny/v1.3/marker_genes/select_content.R
+++ b/inst/shiny/v1.3/marker_genes/select_content.R
@@ -1,6 +1,4 @@
##----------------------------------------------------------------------------##
-## Tab: Marker genes
-##
## Select method and table (group).
##----------------------------------------------------------------------------##
@@ -8,10 +6,7 @@
## UI element to set layout for selection of method and group, which are split
## because the group depends on which method is selected.
##----------------------------------------------------------------------------##
-
output[["marker_genes_select_method_and_table_UI"]] <- renderUI({
-
- ## ...
if (
!is.null(getMethodsForMarkerGenes()) &&
length(getMethodsForMarkerGenes()) > 0
@@ -28,8 +23,6 @@ output[["marker_genes_select_method_and_table_UI"]] <- renderUI({
)
)
)
-
- ## ...
} else {
fluidRow(
cerebroBox(
@@ -43,7 +36,6 @@ output[["marker_genes_select_method_and_table_UI"]] <- renderUI({
##----------------------------------------------------------------------------##
## UI element to select from which method the results should be shown.
##----------------------------------------------------------------------------##
-
output[["marker_genes_selected_method_UI"]] <- renderUI({
tagList(
div(
@@ -67,15 +59,8 @@ output[["marker_genes_selected_method_UI"]] <- renderUI({
##----------------------------------------------------------------------------##
## UI element to select which group should be shown.
##----------------------------------------------------------------------------##
-
output[["marker_genes_selected_table_UI"]] <- renderUI({
-
- ##
- req(
- input[["marker_genes_selected_method"]]
- )
-
- ##
+ req(input[["marker_genes_selected_method"]])
tagList(
div(
HTML('Choose a table:')
@@ -98,7 +83,6 @@ output[["marker_genes_selected_table_UI"]] <- renderUI({
##----------------------------------------------------------------------------##
## Alternative text message if data is missing.
##----------------------------------------------------------------------------##
-
output[["marker_genes_message_no_method_found"]] <- renderText({
"No data available."
})
diff --git a/inst/shiny/v1.3/marker_genes/server.R b/inst/shiny/v1.3/marker_genes/server.R
index 9a272c9..75ce9fe 100644
--- a/inst/shiny/v1.3/marker_genes/server.R
+++ b/inst/shiny/v1.3/marker_genes/server.R
@@ -1,6 +1,5 @@
##----------------------------------------------------------------------------##
## Tab: Marker genes
##----------------------------------------------------------------------------##
-
source(paste0(Cerebro.options[["cerebro_root"]], "/shiny/v1.3/marker_genes/select_content.R"), local = TRUE)
source(paste0(Cerebro.options[["cerebro_root"]], "/shiny/v1.3/marker_genes/table.R"), local = TRUE)
diff --git a/inst/shiny/v1.3/marker_genes/table.R b/inst/shiny/v1.3/marker_genes/table.R
index 7612b6e..e2f5edc 100644
--- a/inst/shiny/v1.3/marker_genes/table.R
+++ b/inst/shiny/v1.3/marker_genes/table.R
@@ -1,21 +1,15 @@
##----------------------------------------------------------------------------##
-## Tab: Marker genes
-##
## Table or info text when data is missing.
##----------------------------------------------------------------------------##
##----------------------------------------------------------------------------##
## UI element for output.
##----------------------------------------------------------------------------##
-
output[["marker_genes_table_UI"]] <- renderUI({
-
- ##
req(
input[["marker_genes_selected_method"]],
input[["marker_genes_selected_table"]]
)
-
fluidRow(
cerebroBox(
title = tagList(
@@ -32,23 +26,17 @@ output[["marker_genes_table_UI"]] <- renderUI({
## results, automatic number formatting, automatic coloring of values), or text
## messages if no marker genes were found or data is missing.
##----------------------------------------------------------------------------##
-
output[["marker_genes_table_or_text_UI"]] <- renderUI({
-
- ##
req(
input[["marker_genes_selected_method"]],
input[["marker_genes_selected_table"]],
input[["marker_genes_selected_table"]] %in% getGroupsWithMarkerGenes(input[["marker_genes_selected_method"]])
)
-
## fetch results
results_type <- getMarkerGenes(
input[["marker_genes_selected_method"]],
input[["marker_genes_selected_table"]]
)
-
- ##
if ( length(results_type) > 0 ) {
if ( is.data.frame(results_type) ) {
fluidRow(
@@ -96,26 +84,20 @@ output[["marker_genes_table_or_text_UI"]] <- renderUI({
##----------------------------------------------------------------------------##
## UI element for sub-filtering of results if toggled.
##----------------------------------------------------------------------------##
-
output[["marker_genes_filter_subgroups_UI"]] <- renderUI({
-
- ##
req(
input[["marker_genes_selected_method"]],
input[["marker_genes_selected_table"]],
input[["marker_genes_selected_table"]] %in% getGroupsWithMarkerGenes(input[["marker_genes_selected_method"]]),
!is.null(input[["marker_genes_table_filter_switch"]])
)
-
## fetch results
results_df <- getMarkerGenes(
input[["marker_genes_selected_method"]],
input[["marker_genes_selected_table"]]
)
-
## don't proceed if input is not a data frame
req(is.data.frame(results_df))
-
## check if pre-filtering is activated and name of first column in table is
## one of the registered groups
## ... it's not
@@ -123,20 +105,16 @@ output[["marker_genes_filter_subgroups_UI"]] <- renderUI({
input[["marker_genes_table_filter_switch"]] == TRUE ||
colnames(results_df)[1] %in% getGroups() == FALSE
) {
-
## return nothing (empty row)
fluidRow()
-
## ... it is
} else {
-
## check for which groups results exist
if ( is.character(results_df[[1]]) ) {
available_groups <- unique(results_df[[1]])
} else if ( is.factor(results_df[[1]]) ) {
available_groups <- levels(results_df[[1]])
}
-
## create input selection for available groups
fluidRow(
column(12,
@@ -153,52 +131,40 @@ output[["marker_genes_filter_subgroups_UI"]] <- renderUI({
##----------------------------------------------------------------------------##
## Table with results.
##----------------------------------------------------------------------------##
-
-output[["marker_genes_table"]] <- DT::renderDataTable(server = FALSE, {
-
- ##
+output[["marker_genes_table"]] <- DT::renderDataTable({
req(
input[["marker_genes_selected_method"]],
input[["marker_genes_selected_table"]],
input[["marker_genes_selected_table"]] %in% getGroupsWithMarkerGenes(input[["marker_genes_selected_method"]])
)
-
## fetch results
results_df <- getMarkerGenes(
input[["marker_genes_selected_method"]],
input[["marker_genes_selected_table"]]
)
-
## don't proceed if input is not a data frame
req(is.data.frame(results_df))
-
## filter the table for a specific subgroup only if specified by the user
## (otherwise show all results)
if (
input[["marker_genes_table_filter_switch"]] == FALSE &&
colnames(results_df)[1] %in% getGroups() == TRUE
) {
-
## don't proceed if selection of subgroup is not available
req(input[["marker_genes_table_select_group_level"]])
-
## filter table
results_df <- results_df[ which(results_df[[1]] == input[["marker_genes_table_select_group_level"]]) , ]
}
-
## if the table is empty, e.g. because the filtering of results for a specific
## subgroup did not work properly, skip the processing and show and empty
## table (otherwise the procedure would result in an error)
if ( nrow(results_df) == 0 ) {
-
results_df %>%
as.data.frame() %>%
dplyr::slice(0) %>%
prepareEmptyTable()
-
## if there is at least 1 row, create proper table
} else {
-
prettifyTable(
results_df,
filter = list(position = "top", clear = TRUE),
@@ -221,7 +187,6 @@ output[["marker_genes_table"]] <- DT::renderDataTable(server = FALSE, {
##----------------------------------------------------------------------------##
## Alternative text message if no marker genes were found.
##----------------------------------------------------------------------------##
-
output[["marker_genes_table_no_markers_found"]] <- renderText({
"No marker genes were identified for any of the subpopulations of this grouping variable."
})
@@ -229,7 +194,6 @@ output[["marker_genes_table_no_markers_found"]] <- renderText({
##----------------------------------------------------------------------------##
## Alternative text message if data is missing.
##----------------------------------------------------------------------------##
-
output[["marker_genes_table_no_data"]] <- renderText({
"Data not available. Possible reasons: Only 1 group in this data set or data not generated."
})
@@ -237,7 +201,6 @@ output[["marker_genes_table_no_data"]] <- renderText({
##----------------------------------------------------------------------------##
## Info box that gets shown when pressing the "info" button.
##----------------------------------------------------------------------------##
-
observeEvent(input[["marker_genes_info"]], {
showModal(
modalDialog(
@@ -253,7 +216,6 @@ observeEvent(input[["marker_genes_info"]], {
##----------------------------------------------------------------------------##
## Text in info box.
##----------------------------------------------------------------------------##
-
marker_genes_info <- list(
title = "Marker genes",
text = HTML("
diff --git a/inst/shiny/v1.3/most_expressed_genes/UI.R b/inst/shiny/v1.3/most_expressed_genes/UI.R
index 02cdba2..2003ad8 100644
--- a/inst/shiny/v1.3/most_expressed_genes/UI.R
+++ b/inst/shiny/v1.3/most_expressed_genes/UI.R
@@ -1,7 +1,6 @@
##----------------------------------------------------------------------------##
## Tab: Most expressed genes
##----------------------------------------------------------------------------##
-
tab_most_expressed_genes <- tabItem(
tabName = "mostExpressedGenes",
shinyjs::inlineCSS("
diff --git a/inst/shiny/v1.3/most_expressed_genes/select_group.R b/inst/shiny/v1.3/most_expressed_genes/select_group.R
index 8a62618..fb547c5 100644
--- a/inst/shiny/v1.3/most_expressed_genes/select_group.R
+++ b/inst/shiny/v1.3/most_expressed_genes/select_group.R
@@ -7,10 +7,7 @@
##----------------------------------------------------------------------------##
## UI element to select which group should be shown.
##----------------------------------------------------------------------------##
-
output[["most_expressed_genes_select_group_UI"]] <- renderUI({
-
- ## ...
if (
!is.null(getGroupsWithMostExpressedGenes()) &&
length(getGroupsWithMostExpressedGenes()) > 0
@@ -32,20 +29,5 @@ output[["most_expressed_genes_select_group_UI"]] <- renderUI({
column(2)
)
)
- } else {
- fluidRow(
- cerebroBox(
- title = boxTitle("Most expressed genes"),
- textOutput("most_expressed_genes_message_no_data_found")
- )
- )
}
})
-
-##----------------------------------------------------------------------------##
-## Alternative text message if data is missing.
-##----------------------------------------------------------------------------##
-
-output[["most_expressed_genes_message_no_data_found"]] <- renderText({
- "No data available."
-})
diff --git a/inst/shiny/v1.3/most_expressed_genes/server.R b/inst/shiny/v1.3/most_expressed_genes/server.R
index aa5dee6..876d804 100644
--- a/inst/shiny/v1.3/most_expressed_genes/server.R
+++ b/inst/shiny/v1.3/most_expressed_genes/server.R
@@ -1,6 +1,5 @@
##----------------------------------------------------------------------------##
## Tab: Most expressed genes
##----------------------------------------------------------------------------##
-
source(paste0(Cerebro.options[["cerebro_root"]], "/shiny/v1.3/most_expressed_genes/select_group.R"), local = TRUE)
source(paste0(Cerebro.options[["cerebro_root"]], "/shiny/v1.3/most_expressed_genes/table.R"), local = TRUE)
diff --git a/inst/shiny/v1.3/most_expressed_genes/table.R b/inst/shiny/v1.3/most_expressed_genes/table.R
index 85fc25f..ddeafb8 100644
--- a/inst/shiny/v1.3/most_expressed_genes/table.R
+++ b/inst/shiny/v1.3/most_expressed_genes/table.R
@@ -1,30 +1,33 @@
##----------------------------------------------------------------------------##
-## Tab: Most expressed genes
-##
## Table or info text when data is missing.
##----------------------------------------------------------------------------##
##----------------------------------------------------------------------------##
## UI element for output.
##----------------------------------------------------------------------------##
-
output[["most_expressed_genes_table_UI"]] <- renderUI({
-
- ##
- req(
- input[["most_expressed_genes_selected_group"]]
- )
-
- ##
- fluidRow(
- cerebroBox(
- title = tagList(
- boxTitle("Most expressed genes"),
- cerebroInfoButton("most_expressed_genes_info")
- ),
- uiOutput("most_expressed_genes_table_or_text_UI")
+ selected_group <- input[['most_expressed_genes_selected_group']]
+ if (
+ is.null(selected_group) ||
+ selected_group %in% getGroups() == FALSE
+ ) {
+ fluidRow(
+ cerebroBox(
+ title = boxTitle("Most expressed genes"),
+ textOutput("most_expressed_genes_message_no_data_found")
+ )
)
- )
+ } else {
+ fluidRow(
+ cerebroBox(
+ title = tagList(
+ boxTitle("Most expressed genes"),
+ cerebroInfoButton("most_expressed_genes_info")
+ ),
+ uiOutput("most_expressed_genes_table_or_text_UI")
+ )
+ )
+ }
})
##----------------------------------------------------------------------------##
@@ -32,10 +35,7 @@ output[["most_expressed_genes_table_UI"]] <- renderUI({
## of results and the corresponding selector, or a text message if data is
## missing.
##----------------------------------------------------------------------------##
-
output[["most_expressed_genes_table_or_text_UI"]] <- renderUI({
-
- ##
fluidRow(
column(12,
shinyWidgets::materialSwitch(
@@ -58,23 +58,14 @@ output[["most_expressed_genes_table_or_text_UI"]] <- renderUI({
##----------------------------------------------------------------------------##
## UI element for sub-filtering of results (if toggled).
##----------------------------------------------------------------------------##
-
output[["most_expressed_genes_filter_subgroups_UI"]] <- renderUI({
-
- ##
- req(
- input[["most_expressed_genes_selected_group"]],
- !is.null(input[["most_expressed_genes_table_filter_switch"]])
- )
-
+ req(!is.null(input[["most_expressed_genes_table_filter_switch"]]))
+ selected_group <- input[['most_expressed_genes_selected_group']]
+ req(selected_group %in% getGroups())
## fetch results
- results_df <- getMostExpressedGenes(
- input[["most_expressed_genes_selected_group"]]
- )
-
+ results_df <- getMostExpressedGenes(selected_group)
## don't proceed if input is not a data frame
req(is.data.frame(results_df))
-
## check if pre-filtering is activated and name of first column in table is
## one of the registered groups
## ... it's not
@@ -82,20 +73,16 @@ output[["most_expressed_genes_filter_subgroups_UI"]] <- renderUI({
input[["most_expressed_genes_table_filter_switch"]] == TRUE ||
colnames(results_df)[1] %in% getGroups() == FALSE
) {
-
## return nothing (empty row)
fluidRow()
-
## ... it is
} else {
-
## check for which groups results exist
if ( is.character(results_df[[1]]) ) {
available_groups <- unique(results_df[[1]])
} else if ( is.factor(results_df[[1]]) ) {
available_groups <- levels(results_df[[1]])
}
-
fluidRow(
column(12,
selectInput(
@@ -111,34 +98,21 @@ output[["most_expressed_genes_filter_subgroups_UI"]] <- renderUI({
##----------------------------------------------------------------------------##
## Table with results.
##----------------------------------------------------------------------------##
-
-output[["most_expressed_genes_table"]] <- DT::renderDataTable(server = FALSE, {
-
- ##
- req(
- input[["most_expressed_genes_selected_group"]]
- )
-
+output[["most_expressed_genes_table"]] <- DT::renderDataTable({
+ selected_group <- input[['most_expressed_genes_selected_group']]
+ req(selected_group %in% getGroups())
## fetch results
- results_df <- getMostExpressedGenes(
- input[["most_expressed_genes_selected_group"]]
- )
-
+ results_df <- getMostExpressedGenes(selected_group)
## don't proceed if input is not a data frame
- req(
- is.data.frame(results_df)
- )
-
+ req(is.data.frame(results_df))
## filter the table for a specific subgroup only if specified by the user,
## otherwise show all results
if (
input[["most_expressed_genes_table_filter_switch"]] == FALSE &&
colnames(results_df)[1] %in% getGroups() == TRUE
) {
-
## don't proceed if selection of subgroup is not available
req(input[["most_expressed_genes_table_select_group_level"]])
-
## filter table
results_df <- results_df[ which(results_df[[1]] == input[["most_expressed_genes_table_select_group_level"]]) , ]
}
@@ -147,15 +121,12 @@ output[["most_expressed_genes_table"]] <- DT::renderDataTable(server = FALSE, {
## subgroup did not work properly, skip the processing and show and empty
## table (otherwise the procedure would result in an error)
if ( nrow(results_df) == 0 ) {
-
results_df %>%
as.data.frame() %>%
dplyr::slice(0) %>%
prepareEmptyTable()
-
## if there is at least 1 row in the table, create proper table
} else {
-
results_df %>%
dplyr::rename("% of total expression" = pct) %>%
prettifyTable(
@@ -177,9 +148,15 @@ output[["most_expressed_genes_table"]] <- DT::renderDataTable(server = FALSE, {
})
##----------------------------------------------------------------------------##
-## Info box that gets shown when pressing the "info" button.
+## Alternative text message if data is missing.
##----------------------------------------------------------------------------##
+output[["most_expressed_genes_message_no_data_found"]] <- renderText({
+ "No data available."
+})
+##----------------------------------------------------------------------------##
+## Info box that gets shown when pressing the "info" button.
+##----------------------------------------------------------------------------##
observeEvent(input[["most_expressed_genes_info"]], {
showModal(
modalDialog(
@@ -195,7 +172,6 @@ observeEvent(input[["most_expressed_genes_info"]], {
##----------------------------------------------------------------------------##
## Text in info box.
##----------------------------------------------------------------------------##
-
most_expressed_genes_info <- list(
title = "Most expressed genes",
text = HTML("
diff --git a/inst/shiny/v1.3/overview/UI.R b/inst/shiny/v1.3/overview/UI.R
index 2410ca0..9f5e550 100644
--- a/inst/shiny/v1.3/overview/UI.R
+++ b/inst/shiny/v1.3/overview/UI.R
@@ -1,6 +1,9 @@
##----------------------------------------------------------------------------##
## Tab: Overview
##----------------------------------------------------------------------------##
+js_code_overview_projection <- readr::read_file(
+ paste0(Cerebro.options[["cerebro_root"]], "/shiny/v1.3/overview/js_projection_update_plot.js")
+)
tab_overview <- tabItem(
tabName = "overview",
@@ -14,6 +17,15 @@ tab_overview <- tabItem(
}
"
),
+ shinyjs::extendShinyjs(
+ text = js_code_overview_projection,
+ functions = c(
+ "updatePlot2DContinuous",
+ "updatePlot3DContinuous",
+ "updatePlot2DCategorical",
+ "updatePlot3DCategorical"
+ )
+ ),
uiOutput("overview_projection_UI"),
uiOutput("overview_selected_cells_plot_UI"),
uiOutput("overview_selected_cells_table_UI")
diff --git a/inst/shiny/v1.3/overview/UI_projection.R b/inst/shiny/v1.3/overview/UI_projection.R
new file mode 100644
index 0000000..0499050
--- /dev/null
+++ b/inst/shiny/v1.3/overview/UI_projection.R
@@ -0,0 +1,104 @@
+##----------------------------------------------------------------------------##
+## Layout of the UI elements.
+##----------------------------------------------------------------------------##
+output[["overview_projection_UI"]] <- renderUI({
+ fluidRow(
+ ## selections and parameters
+ column(width = 3, offset = 0, style = "padding: 0px;",
+ cerebroBox(
+ title = tagList(
+ "Main parameters",
+ actionButton(
+ inputId = "overview_projection_main_parameters_info",
+ label = "info",
+ icon = NULL,
+ class = "btn-xs",
+ title = "Show additional information for this panel.",
+ style = "margin-left: 5px"
+ )
+ ),
+ uiOutput("overview_projection_main_parameters_UI")
+ ),
+ cerebroBox(
+ title = tagList(
+ "Additional parameters",
+ actionButton(
+ inputId = "overview_projection_additional_parameters_info",
+ label = "info",
+ icon = NULL,
+ class = "btn-xs",
+ title = "Show additional information for this panel.",
+ style = "margin-left: 5px"
+ )
+ ),
+ uiOutput("overview_projection_additional_parameters_UI"),
+ collapsed = TRUE
+ ),
+ cerebroBox(
+ title = tagList(
+ "Group filters",
+ actionButton(
+ inputId = "overview_projection_group_filters_info",
+ label = "info",
+ icon = NULL,
+ class = "btn-xs",
+ title = "Show additional information for this panel.",
+ style = "margin-left: 5px"
+ )
+ ),
+ uiOutput("overview_projection_group_filters_UI"),
+ collapsed = TRUE
+ )
+ ),
+ ## plot
+ column(width = 9, offset = 0, style = "padding: 0px;",
+ cerebroBox(
+ title = tagList(
+ boxTitle("Dimensional reduction"),
+ actionButton(
+ inputId = "overview_projection_info",
+ label = "info",
+ title = "Show additional information for this panel.",
+ icon = NULL,
+ class = "btn-xs",
+ style = "margin-right: 3px"
+ ),
+ shinyFiles::shinySaveButton(
+ "overview_projection_export",
+ label = "export to PDF",
+ title = "Export dimensional reduction to PDF file.",
+ filetype = "pdf",
+ viewtype = "icon",
+ class = "btn-xs",
+ style = "margin-right: 3px"
+ ),
+ shinyWidgets::dropdownButton(
+ tags$div(
+ style = "color: black !important;",
+ uiOutput("overview_projection_show_group_label_UI"),
+ uiOutput("overview_projection_point_border_UI"),
+ uiOutput("overview_projection_scales_UI")
+ ),
+ circle = FALSE,
+ icon = icon("cog"),
+ inline = TRUE,
+ size = "xs"
+ )
+ ),
+ tagList(
+ shinycssloaders::withSpinner(
+ plotly::plotlyOutput(
+ "overview_projection",
+ width = "auto",
+ height = "85vh"
+ ),
+ type = 8,
+ hide.ui = FALSE
+ ),
+ tags$br(),
+ htmlOutput("overview_number_of_selected_cells"),
+ )
+ )
+ )
+ )
+})
diff --git a/inst/shiny/v1.3/overview/UI_projection_additional_parameters.R b/inst/shiny/v1.3/overview/UI_projection_additional_parameters.R
new file mode 100644
index 0000000..c92f8cd
--- /dev/null
+++ b/inst/shiny/v1.3/overview/UI_projection_additional_parameters.R
@@ -0,0 +1,70 @@
+##----------------------------------------------------------------------------##
+## UI elements to set additional parameters for the projection.
+##----------------------------------------------------------------------------##
+output[["overview_projection_additional_parameters_UI"]] <- renderUI({
+ tagList(
+ sliderInput(
+ "overview_projection_point_size",
+ label = "Point size",
+ min = preferences[["scatter_plot_point_size"]][["min"]],
+ max = preferences[["scatter_plot_point_size"]][["max"]],
+ step = preferences[["scatter_plot_point_size"]][["step"]],
+ value = preferences[["scatter_plot_point_size"]][["default"]]
+ ),
+ sliderInput(
+ "overview_projection_point_opacity",
+ label = "Point opacity",
+ min = preferences[["scatter_plot_point_opacity"]][["min"]],
+ max = preferences[["scatter_plot_point_opacity"]][["max"]],
+ step = preferences[["scatter_plot_point_opacity"]][["step"]],
+ value = preferences[["scatter_plot_point_opacity"]][["default"]]
+ ),
+ sliderInput(
+ "overview_projection_percentage_cells_to_show",
+ label = "Show % of cells",
+ min = preferences[["scatter_plot_percentage_cells_to_show"]][["min"]],
+ max = preferences[["scatter_plot_percentage_cells_to_show"]][["max"]],
+ step = preferences[["scatter_plot_percentage_cells_to_show"]][["step"]],
+ value = preferences[["scatter_plot_percentage_cells_to_show"]][["default"]]
+ )
+ )
+})
+
+## make sure elements are loaded even though the box is collapsed
+outputOptions(
+ output,
+ "overview_projection_additional_parameters_UI",
+ suspendWhenHidden = FALSE
+)
+
+##----------------------------------------------------------------------------##
+## Info box that gets shown when pressing the "info" button.
+##----------------------------------------------------------------------------##
+observeEvent(input[["overview_projection_additional_parameters_info"]], {
+ showModal(
+ modalDialog(
+ overview_projection_additional_parameters_info[["text"]],
+ title = overview_projection_additional_parameters_info[["title"]],
+ easyClose = TRUE,
+ footer = NULL,
+ size = "l"
+ )
+ )
+})
+
+##----------------------------------------------------------------------------##
+## Text in info box.
+##----------------------------------------------------------------------------##
+#
- Range of X/Y axis (located in dropdown menu above the projection): Set the X/Y axis limits. This is useful when you want to change the aspect ratio of the plot.
+overview_projection_additional_parameters_info <- list(
+ title = "Additional parameters for projection",
+ text = HTML("
+ The elements in this panel allow you to control what and how results are displayed across the whole tab.
+
+ - Point size: Controls how large the cells should be.
+ - Point opacity: Controls the transparency of the cells.
+ - Show % of cells: Using the slider, you can randomly remove a fraction of cells from the plot. This can be useful for large data sets and/or computers with limited resources.
+
+ "
+ )
+)
diff --git a/inst/shiny/v1.3/overview/UI_projection_group_filters.R b/inst/shiny/v1.3/overview/UI_projection_group_filters.R
new file mode 100644
index 0000000..c638f7c
--- /dev/null
+++ b/inst/shiny/v1.3/overview/UI_projection_group_filters.R
@@ -0,0 +1,94 @@
+##----------------------------------------------------------------------------##
+## UI elements to set group filters for the projection.
+##----------------------------------------------------------------------------##
+output[["overview_projection_group_filters_UI"]] <- renderUI({
+ group_filters <- list()
+ for ( i in getGroups() ) {
+ group_filters[[i]] <- shinyWidgets::pickerInput(
+ paste0("overview_projection_group_filter_", i),
+ label = i,
+ choices = getGroupLevels(i),
+ selected = getGroupLevels(i),
+ options = list(
+ "actions-box" = TRUE
+ ),
+ multiple = TRUE
+ )
+ }
+ return(group_filters)
+})
+
+## make sure elements are loaded even though the box is collapsed
+outputOptions(
+ output,
+ "overview_projection_group_filters_UI",
+ suspendWhenHidden = FALSE
+)
+
+##----------------------------------------------------------------------------##
+## Info box that gets shown when pressing the "info" button.
+##----------------------------------------------------------------------------##
+observeEvent(input[["overview_projection_group_filters_info"]], {
+ showModal(
+ modalDialog(
+ overview_projection_group_filters_info[["text"]],
+ title = overview_projection_group_filters_info[["title"]],
+ easyClose = TRUE,
+ footer = NULL,
+ size = "l"
+ )
+ )
+})
+
+##----------------------------------------------------------------------------##
+## Text in info box.
+##----------------------------------------------------------------------------##
+overview_projection_group_filters_info <- list(
+ title = "Group filters for projection",
+ text = HTML("
+ The elements in this panel allow you to select which cells should be plotted based on the group(s) they belong to. For each grouping variable, you can activate or deactivate group levels. Only cells that are pass all filters (for each grouping variable) are shown in the projection.
+ "
+ )
+)
+
+##----------------------------------------------------------------------------##
+## example for implementation of nested checkboxes with shinyTree for selection
+## of group levels to show; works similar to cellxgene; anyway decided against
+## it because it creates a new dependency and isn't as aesthetically pleasing as
+## the existing solution
+##----------------------------------------------------------------------------##
+
+# output[["overview_projection_group_filters_tree"]] <- shinyTree::renderTree({
+# groups <- list()
+# for ( i in getGroups() ) {
+# groups[[i]] <- structure(
+# as.list(
+# setNames(
+# getGroupLevels(i),
+# getGroupLevels(i)
+# )
+# ),
+# stselected = TRUE
+# )
+# }
+# groups
+# })
+
+# output[["overview_projection_group_filters_selected_groups"]] <- renderPrint({
+# tree <- input[["overview_projection_group_filters_tree"]]
+# req(overview_projection_group_filters_tree)
+# str(shinyTree::get_selected(tree, format = "slices"))
+# })
+
+# output[["overview_projection_group_filters_tree_UI"]] <- renderUI({
+# tagList(
+# shinyTree::shinyTree(
+# "overview_projection_group_filters_tree",
+# theme = "proton",
+# themeIcons = FALSE,
+# themeDots = FALSE,
+# checkbox = TRUE
+# ),
+# verbatimTextOutput("sel_slices")
+# )
+# })
diff --git a/inst/shiny/v1.3/overview/UI_projection_main_parameters.R b/inst/shiny/v1.3/overview/UI_projection_main_parameters.R
new file mode 100644
index 0000000..d485122
--- /dev/null
+++ b/inst/shiny/v1.3/overview/UI_projection_main_parameters.R
@@ -0,0 +1,46 @@
+##----------------------------------------------------------------------------##
+## UI elements to set main parameters for the projection.
+##----------------------------------------------------------------------------##
+output[["overview_projection_main_parameters_UI"]] <- renderUI({
+ tagList(
+ selectInput(
+ "overview_projection_to_display",
+ label = "Projection",
+ choices = availableProjections()
+ ),
+ selectInput(
+ "overview_projection_point_color",
+ label = "Color cells by",
+ choices = colnames(getMetaData())[! colnames(getMetaData()) %in% c("cell_barcode")]
+ )
+ )
+})
+
+##----------------------------------------------------------------------------##
+## Info box that gets shown when pressing the "info" button.
+##----------------------------------------------------------------------------##
+observeEvent(input[["overview_projection_main_parameters_info"]], {
+ showModal(
+ modalDialog(
+ overview_projection_main_parameters_info[["text"]],
+ title = overview_projection_main_parameters_info[["title"]],
+ easyClose = TRUE,
+ footer = NULL,
+ size = "l"
+ )
+ )
+})
+##----------------------------------------------------------------------------##
+## Text in info box.
+##----------------------------------------------------------------------------##
+overview_projection_main_parameters_info <- list(
+ title = "Main parameters for projection",
+ text = HTML("
+ The elements in this panel allow you to control what and how results are displayed across the whole tab.
+
+ - Projection: Select here which projection you want to see in the scatter plot on the right.
+ - Color cells by: Select which variable, categorical or continuous, from the meta data should be used to color the cells.
+
+ "
+ )
+)
diff --git a/inst/shiny/v1.3/overview/UI_projection_point_border.R b/inst/shiny/v1.3/overview/UI_projection_point_border.R
new file mode 100644
index 0000000..e5972fc
--- /dev/null
+++ b/inst/shiny/v1.3/overview/UI_projection_point_border.R
@@ -0,0 +1,17 @@
+##----------------------------------------------------------------------------##
+## UI elements with switch to draw border around cells.
+##----------------------------------------------------------------------------##
+output[["overview_projection_point_border_UI"]] <- renderUI({
+ shinyWidgets::awesomeCheckbox(
+ inputId = "overview_projection_point_border",
+ label = "Draw border around cells",
+ value = FALSE
+ )
+})
+
+## make sure elements are loaded even though the box is collapsed
+outputOptions(
+ output,
+ "overview_projection_point_border_UI",
+ suspendWhenHidden = FALSE
+)
diff --git a/inst/shiny/v1.3/overview/UI_projection_scales.R b/inst/shiny/v1.3/overview/UI_projection_scales.R
new file mode 100644
index 0000000..5750edf
--- /dev/null
+++ b/inst/shiny/v1.3/overview/UI_projection_scales.R
@@ -0,0 +1,40 @@
+##----------------------------------------------------------------------------##
+## UI elements to select X and Y limits in projection.
+##----------------------------------------------------------------------------##
+output[["overview_projection_scales_UI"]] <- renderUI({
+ if (
+ is.null(input[["overview_projection_to_display"]]) ||
+ is.na(input[["overview_projection_to_display"]]) ||
+ input[["overview_projection_to_display"]] %in% availableProjections() == FALSE
+ ) {
+ projection_to_display <- availableProjections()[1]
+ } else {
+ projection_to_display <- input[["overview_projection_to_display"]]
+ }
+ ##
+ XYranges <- getXYranges(getProjection(projection_to_display))
+ ##
+ tagList(
+ sliderInput(
+ "overview_projection_scale_x_manual_range",
+ label = "Range of X axis",
+ min = XYranges$x$min,
+ max = XYranges$x$max,
+ value = c(XYranges$x$min, XYranges$x$max)
+ ),
+ sliderInput(
+ "overview_projection_scale_y_manual_range",
+ label = "Range of Y axis",
+ min = XYranges$y$min,
+ max = XYranges$y$max,
+ value = c(XYranges$y$min, XYranges$y$max)
+ )
+ )
+})
+
+## make sure elements are loaded even though the box is collapsed
+outputOptions(
+ output,
+ "overview_projection_scales_UI",
+ suspendWhenHidden = FALSE
+)
diff --git a/inst/shiny/v1.3/overview/UI_projection_show_group_label.R b/inst/shiny/v1.3/overview/UI_projection_show_group_label.R
new file mode 100644
index 0000000..1845d5c
--- /dev/null
+++ b/inst/shiny/v1.3/overview/UI_projection_show_group_label.R
@@ -0,0 +1,20 @@
+##----------------------------------------------------------------------------##
+## UI elements with switch to show group labels in projection.
+##----------------------------------------------------------------------------##
+output[["overview_projection_show_group_label_UI"]] <- renderUI({
+ req(input[["overview_projection_point_color"]])
+ if ( input[["overview_projection_point_color"]] %in% getGroups() ) {
+ shinyWidgets::awesomeCheckbox(
+ inputId = "overview_projection_show_group_label",
+ label = "Plot group labels in exported PDF",
+ value = TRUE
+ )
+ }
+})
+
+## make sure elements are loaded even though the box is collapsed
+outputOptions(
+ output,
+ "overview_projection_show_group_label_UI",
+ suspendWhenHidden = FALSE
+)
diff --git a/inst/shiny/v1.3/overview/UI_selected_cells_plot.R b/inst/shiny/v1.3/overview/UI_selected_cells_plot.R
new file mode 100644
index 0000000..2efaeb6
--- /dev/null
+++ b/inst/shiny/v1.3/overview/UI_selected_cells_plot.R
@@ -0,0 +1,44 @@
+##----------------------------------------------------------------------------##
+## UI element for output.
+##----------------------------------------------------------------------------##
+output[["overview_selected_cells_plot_UI"]] <- renderUI({
+ fluidRow(
+ cerebroBox(
+ title = tagList(
+ boxTitle("Plot of selected cells"),
+ cerebroInfoButton("overview_details_selected_cells_plot_info")
+ ),
+ tagList(
+ selectInput(
+ "overview_selected_cells_plot_select_variable",
+ label = "Variable to compare:",
+ choices = colnames(getMetaData())[! colnames(getMetaData()) %in% c("cell_barcode")]
+ ),
+ plotly::plotlyOutput("overview_details_selected_cells_plot")
+ )
+ )
+ )
+})
+
+##----------------------------------------------------------------------------##
+## Info box that gets shown when pressing the "info" button.
+##----------------------------------------------------------------------------##
+observeEvent(input[["overview_details_selected_cells_plot_info"]], {
+ showModal(
+ modalDialog(
+ overview_details_selected_cells_plot_info$text,
+ title = overview_details_selected_cells_plot_info$title,
+ easyClose = TRUE,
+ footer = NULL,
+ size = "l"
+ )
+ )
+})
+
+##----------------------------------------------------------------------------##
+## Text in info box.
+##----------------------------------------------------------------------------##
+overview_details_selected_cells_plot_info <- list(
+ title = "Plot of selected cells",
+ text = p("Depending on the variable selected to color cells in the dimensional reduction, this plot will show different things. If you select a categorical variable, e.g. 'sample' or 'cluster', you will get a bar plot showing which groups the cells selected with the box or lasso tool come from. Instead, if you select a continuous variable, e.g. the number of transcripts (nUMI), you will see a violin/box plot showing the distribution of that variable in the selected vs. non-selected cells.")
+)
diff --git a/inst/shiny/v1.3/overview/selected_cells_table.R b/inst/shiny/v1.3/overview/UI_selected_cells_table.R
similarity index 57%
rename from inst/shiny/v1.3/overview/selected_cells_table.R
rename to inst/shiny/v1.3/overview/UI_selected_cells_table.R
index 6886f25..d6a50cf 100644
--- a/inst/shiny/v1.3/overview/selected_cells_table.R
+++ b/inst/shiny/v1.3/overview/UI_selected_cells_table.R
@@ -1,13 +1,6 @@
-##----------------------------------------------------------------------------##
-## Tab: Overview
-##
-## Table of selected cells.
-##----------------------------------------------------------------------------##
-
##----------------------------------------------------------------------------##
## UI element for output.
##----------------------------------------------------------------------------##
-
output[["overview_selected_cells_table_UI"]] <- renderUI({
fluidRow(
cerebroBox(
@@ -36,82 +29,9 @@ output[["overview_selected_cells_table_UI"]] <- renderUI({
)
})
-##----------------------------------------------------------------------------##
-## Table.
-##----------------------------------------------------------------------------##
-
-output[["overview_details_selected_cells_table"]] <- DT::renderDataTable(server = FALSE, {
-
- ## don't proceed without these inputs
- req(
- input[["overview_projection_to_display"]]
- )
-
- ## check selection
- ## ... selection has not been made or there is not cell in it
- if (
- is.null(plotly::event_data("plotly_selected", source = "overview_projection")) ||
- length(plotly::event_data("plotly_selected", source = "overview_projection")) == 0
- ) {
-
- ## prepare empty table
- getMetaData() %>%
- dplyr::slice(0) %>%
- prepareEmptyTable()
-
- ## ... selection has been made and at least 1 cell is in it
- } else {
-
- ## get info of selected cells and create identifier from X-Y coordinates
- selected_cells <- plotly::event_data("plotly_selected", source = "overview_projection") %>%
- dplyr::mutate(identifier = paste0(x, '-', y))
-
- ## extract cells for table
- cells_df <- cbind(
- getProjection(input[["overview_projection_to_display"]]),
- getMetaData()
- ) %>%
- as.data.frame()
-
- ## filter out non-selected cells with X-Y identifier
- cells_df <- cells_df %>%
- dplyr::rename(X1 = 1, X2 = 2) %>%
- dplyr::mutate(identifier = paste0(X1, '-', X2)) %>%
- dplyr::filter(identifier %in% selected_cells$identifier) %>%
- dplyr::select(-c(X1, X2, identifier)) %>%
- dplyr::select(cell_barcode, everything())
-
- ## check how many cells are left after filtering
- ## ... no cells are left
- if ( nrow(cells_df) == 0 ) {
-
- ## prepare empty table
- getMetaData() %>%
- dplyr::slice(0) %>%
- prepareEmptyTable()
-
- ## ... at least 1 cell is left
- } else {
-
- ## prepare proper table
- prettifyTable(
- cells_df,
- filter = list(position = "top", clear = TRUE),
- dom = "Brtlip",
- show_buttons = TRUE,
- number_formatting = input[["overview_details_selected_cells_table_number_formatting"]],
- color_highlighting = input[["overview_details_selected_cells_table_color_highlighting"]],
- hide_long_columns = TRUE,
- download_file_name = "overview_details_of_selected_cells"
- )
- }
- }
-})
-
##----------------------------------------------------------------------------##
## Info box that gets shown when pressing the "info" button.
##----------------------------------------------------------------------------##
-
observeEvent(input[["overview_details_selected_cells_table_info"]], {
showModal(
modalDialog(
@@ -127,7 +47,6 @@ observeEvent(input[["overview_details_selected_cells_table_info"]], {
##----------------------------------------------------------------------------##
## Text in info box.
##----------------------------------------------------------------------------##
-
overview_details_selected_cells_table_info <- list(
title = "Details of selected cells",
text = HTML("
diff --git a/inst/shiny/v1.3/overview/event_projection_export_plot.R b/inst/shiny/v1.3/overview/event_projection_export_plot.R
new file mode 100644
index 0000000..debabfa
--- /dev/null
+++ b/inst/shiny/v1.3/overview/event_projection_export_plot.R
@@ -0,0 +1,128 @@
+##----------------------------------------------------------------------------##
+## Export projection plot to PDF when pressing the "export to PDF" button.
+##----------------------------------------------------------------------------##
+observeEvent(input[["overview_projection_export"]], {
+ req(overview_projection_data_to_plot())
+ input_data <- overview_projection_data_to_plot()
+ cells_df <- input_data[['cells_df']]
+ coordinates <- input_data[['coordinates']]
+ plot_parameters <- input_data[['plot_parameters']]
+ color_assignments <- input_data[['color_assignments']]
+ ## open dialog to select where plot should be saved and how the file should
+ ## be named
+ shinyFiles::shinyFileSave(
+ input,
+ id = "overview_projection_export",
+ roots = available_storage_volumes,
+ session = session,
+ restrictions = system.file(package = "base")
+ )
+ ## retrieve info from dialog
+ save_file_input <- shinyFiles::parseSavePath(
+ available_storage_volumes,
+ input[["overview_projection_export"]]
+ )
+ ## only proceed if a path has been provided
+ req(nrow(save_file_input) > 0)
+ ## ggplot2 functions are necessary to create the plot
+ require("ggplot2")
+ ## extract specified file path
+ save_file_path <- as.character(save_file_input$datapath[1])
+ ##
+ variable_to_color_cells <- plot_parameters[["color_variable"]]
+ ## check if selection projection consists of 2 or 3 dimensions
+ ## ... selection projection consists of 2 dimensions
+ if ( plot_parameters[['n_dimensions']] == 2 ) {
+ ##
+ stroke <- ifelse(plot_parameters[["draw_border"]], 0.2, 0)
+ ## start building the plot
+ plot <- ggplot(
+ cbind(coordinates, cells_df),
+ aes_q(
+ x = as.name(colnames(coordinates)[1]),
+ y = as.name(colnames(coordinates)[2]),
+ fill = as.name(variable_to_color_cells)
+ )
+ ) +
+ geom_point(
+ shape = 21,
+ size = plot_parameters[["point_size"]]/3,
+ stroke = stroke,
+ color = "#c4c4c4",
+ alpha = plot_parameters[["point_opacity"]]
+ ) +
+ lims(
+ x = plot_parameters[["x_range"]],
+ y = plot_parameters[["y_range"]]
+ ) +
+ theme_bw()
+ ## depending on type of cell coloring, add different color scale
+ ## ... categorical
+ if (
+ is.factor(cells_df[[ variable_to_color_cells ]]) ||
+ is.character(cells_df[[ variable_to_color_cells ]])
+ ) {
+ ## add color assignments
+ plot <- plot + scale_fill_manual(values = color_assignments)
+ ## check if group labels should be plotted and, if so, add them
+ if ( plot_parameters[["group_labels"]] == TRUE ) {
+ ## calculate group level centers
+ group_labels <- centerOfGroups(coordinates, cells_df, 2, variable_to_color_cells)
+ ## add group level labels at center of respective groups
+ plot <- plot +
+ geom_label(
+ data = group_labels,
+ mapping = aes(x_median, y_median, label = group),
+ fill = 'white',
+ size = 4.5,
+ color = 'black',
+ alpha = 0.5,
+ fontface = 'bold',
+ label.size = 0,
+ show.legend = FALSE
+ )
+ }
+ ## ... not categorical (probably numerical)
+ } else {
+ ## add continuous color scale
+ plot <- plot +
+ scale_fill_distiller(
+ palette = "YlGnBu",
+ direction = 1,
+ guide = guide_colorbar(frame.colour = "black", ticks.colour = "black")
+ )
+ }
+ ## save plot
+ pdf(NULL)
+ ggsave(save_file_path, plot, height = 8, width = 11)
+ ## check if file was succesfully saved
+ ## ... successful
+ if ( file.exists(save_file_path) ) {
+ ## give positive message
+ shinyWidgets::sendSweetAlert(
+ session = session,
+ title = "Success!",
+ text = paste0("Plot saved successfully as: ", save_file_path),
+ type = "success"
+ )
+ ## ... failed
+ } else {
+ ## give negative message
+ shinyWidgets::sendSweetAlert(
+ session = session,
+ title = "Error!",
+ text = "Sorry, it seems something went wrong...",
+ type = "error"
+ )
+ }
+ ## ... selection projection consists of 3 dimensions
+ } else if ( plot_parameters[['n_dimensions']] == 3 ) {
+ ## give error message
+ shinyWidgets::sendSweetAlert(
+ session = session,
+ title = "Sorry!",
+ text = "It's currently not possible to create PDF plots from 3D dimensional reductions. Please use the PNG export button in the panel or a 2D dimensional reduction instead.",
+ type = "error"
+ )
+ }
+})
diff --git a/inst/shiny/v1.3/overview/event_projection_update_plot.R b/inst/shiny/v1.3/overview/event_projection_update_plot.R
new file mode 100644
index 0000000..3701c79
--- /dev/null
+++ b/inst/shiny/v1.3/overview/event_projection_update_plot.R
@@ -0,0 +1,8 @@
+##----------------------------------------------------------------------------##
+## Update projection plot when overview_projection_data_to_plot() changes.
+##----------------------------------------------------------------------------##
+observeEvent(overview_projection_data_to_plot(), {
+ req(overview_projection_data_to_plot())
+ # message('update_plot')
+ overview_projection_update_plot(overview_projection_data_to_plot())
+})
diff --git a/inst/shiny/v1.3/overview/func_projection_update_plot.R b/inst/shiny/v1.3/overview/func_projection_update_plot.R
new file mode 100644
index 0000000..9842ad4
--- /dev/null
+++ b/inst/shiny/v1.3/overview/func_projection_update_plot.R
@@ -0,0 +1,158 @@
+##----------------------------------------------------------------------------##
+## Function that updates projections.
+##----------------------------------------------------------------------------##
+overview_projection_update_plot <- function(input) {
+ ## assign input data to new variables
+ cells_df <- input[['cells_df']]
+ coordinates <- input[['coordinates']]
+ reset_axes <- input[['reset_axes']]
+ plot_parameters <- input[['plot_parameters']]
+ color_assignments <- input[['color_assignments']]
+ hover_info <- input[['hover_info']]
+ color_input <- cells_df[[ plot_parameters[['color_variable']] ]]
+ ## follow this when the coloring variable is numeric
+ if ( is.numeric(color_input) ) {
+ ## put together meta data
+ output_meta <- list(
+ color_type = 'continuous',
+ traces = plot_parameters[['color_variable']],
+ color_variable = plot_parameters[['color_variable']]
+ )
+ ## put together data
+ output_data <- list(
+ x = coordinates[[1]],
+ y = coordinates[[2]],
+ color = color_input,
+ point_size = plot_parameters[["point_size"]],
+ point_opacity = plot_parameters[["point_opacity"]],
+ point_line = list(),
+ x_range = plot_parameters[["x_range"]],
+ y_range = plot_parameters[["y_range"]],
+ reset_axes = reset_axes
+ )
+ if ( plot_parameters[["draw_border"]] ) {
+ output_data[['point_line']] <- list(
+ color = "rgb(196,196,196)",
+ width = 1
+ )
+ }
+ ## put together hover info
+ output_hover <- list(
+ hoverinfo = ifelse(plot_parameters[["hover_info"]], 'text', 'skip'),
+ text = 'empty'
+ )
+ if ( plot_parameters[["hover_info"]] ) {
+ output_hover[['text']] <- unname(hover_info)
+ }
+ ## send request to update projection to JavaScript functions (2D / 3D)
+ if ( plot_parameters[['n_dimensions']] == 2 ) {
+ shinyjs::js$updatePlot2DContinuous(
+ output_meta,
+ output_data,
+ output_hover
+ )
+ } else if ( plot_parameters[['n_dimensions']] == 3 ) {
+ output_data[['z']] <- coordinates[[3]]
+ shinyjs::js$updatePlot3DContinuous(
+ output_meta,
+ output_data,
+ output_hover
+ )
+ }
+ ## follow this procedure when coloring variable is not numeric
+ } else {
+ ## put together meta data
+ output_meta <- list(
+ color_type = 'categorical',
+ traces = list(),
+ color_variable = plot_parameters[['color_variable']]
+ )
+ ## put together data
+ output_data <- list(
+ x = list(),
+ y = list(),
+ z = list(),
+ color = list(),
+ point_size = plot_parameters[["point_size"]],
+ point_opacity = plot_parameters[["point_opacity"]],
+ point_line = list(),
+ x_range = plot_parameters[["x_range"]],
+ y_range = plot_parameters[["y_range"]],
+ reset_axes = reset_axes
+ )
+ if ( plot_parameters[["draw_border"]] ) {
+ output_data[['point_line']] <- list(
+ color = "rgb(196,196,196)",
+ width = 1
+ )
+ }
+ ## put together hover info
+ output_hover <- list(
+ hoverinfo = ifelse(plot_parameters[["hover_info"]], 'text', 'skip'),
+ text = ifelse(plot_parameters[["hover_info"]], list(), 'test')
+ )
+ ## prepare trace for each group of the catergorical coloring variable and
+ ## send request to update projection to JavaScript function (2D/3D)
+ if ( plot_parameters[['n_dimensions']] == 2 ) {
+ i <- 1
+ for ( j in names(color_assignments) ) {
+ output_meta[['traces']][[i]] <- j
+ cells_to_extract <- which(color_input==j)
+ output_data[['x']][[i]] <- coordinates[[1]][cells_to_extract]
+ output_data[['y']][[i]] <- coordinates[[2]][cells_to_extract]
+ output_data[['color']][[i]] <- unname(color_assignments[which(names(color_assignments)==j)])
+ if ( plot_parameters[["hover_info"]] ) {
+ hover_info_matched <- match(
+ cells_df[['cell_barcode']][cells_to_extract],
+ names(hover_info)
+ )
+ output_hover[['text']][[i]] <- unname(hover_info[hover_info_matched])
+ }
+ i <- i + 1
+ }
+ group_centers_df <- centerOfGroups(coordinates, cells_df, 2, plot_parameters[['color_variable']])
+ output_group_centers <- list(
+ group = group_centers_df[['group']],
+ x = group_centers_df[['x_median']],
+ y = group_centers_df[['y_median']]
+ )
+ shinyjs::js$updatePlot2DCategorical(
+ output_meta,
+ output_data,
+ output_hover,
+ output_group_centers
+ )
+ } else if ( plot_parameters[['n_dimensions']] == 3 ) {
+ i <- 1
+ for ( j in names(color_assignments) ) {
+ output_meta[['traces']][[i]] <- j
+ cells_to_extract <- which(color_input==j)
+ output_data[['x']][[i]] <- coordinates[[1]][cells_to_extract]
+ output_data[['y']][[i]] <- coordinates[[2]][cells_to_extract]
+ output_data[['z']][[i]] <- coordinates[[3]][cells_to_extract]
+ output_data[['color']][[i]] <- unname(color_assignments[which(names(color_assignments)==j)])
+ if ( plot_parameters[["hover_info"]] ) {
+ hover_info_matched <- match(
+ cells_df[['cell_barcode']][cells_to_extract],
+ names(hover_info)
+ )
+ output_hover[['text']][[i]] <- unname(hover_info[hover_info_matched])
+ }
+ i <- i + 1
+ }
+ group_centers_df <- centerOfGroups(coordinates, cells_df, 3, plot_parameters[['color_variable']])
+ output_group_centers <- list(
+ group = group_centers_df[['group']],
+ x = group_centers_df[['x_median']],
+ y = group_centers_df[['y_median']],
+ z = group_centers_df[['z_median']]
+ )
+ shinyjs::js$updatePlot3DCategorical(
+ output_meta,
+ output_data,
+ output_hover,
+ output_group_centers
+ )
+ }
+ }
+}
diff --git a/inst/shiny/v1.3/overview/js_projection_update_plot.js b/inst/shiny/v1.3/overview/js_projection_update_plot.js
new file mode 100644
index 0000000..3bb98c4
--- /dev/null
+++ b/inst/shiny/v1.3/overview/js_projection_update_plot.js
@@ -0,0 +1,293 @@
+// layout for 2D projections
+const overview_projection_layout_2D = {
+ uirevision: 'true',
+ hovermode: 'closest',
+ margin: {
+ l: 50,
+ r: 50,
+ b: 50,
+ t: 50,
+ pad: 4
+ },
+ legend: {
+ itemsizing: 'constant',
+ },
+ xaxis: {
+ autorange: true,
+ mirror: true,
+ showline: true,
+ zeroline: false,
+ range: []
+ },
+ yaxis: {
+ autorange: true,
+ mirror: true,
+ showline: true,
+ zeroline: false,
+ range: []
+ },
+ hoverlabel: {
+ font: {
+ size: 11
+ },
+ align: 'left'
+ }
+};
+
+// layout for 3D projections
+const overview_projection_layout_3D = {
+ uirevision: 'true',
+ hovermode: 'closest',
+ margin: {
+ l: 50,
+ r: 50,
+ b: 50,
+ t: 50,
+ pad: 4
+ },
+ legend: {
+ itemsizing: 'constant',
+ },
+ scene: {
+ xaxis: {
+ autorange: true,
+ mirror: true,
+ showline: true,
+ zeroline: false,
+ range: []
+ },
+ yaxis: {
+ autorange: true,
+ mirror: true,
+ showline: true,
+ zeroline: false,
+ range: []
+ },
+ zaxis: {
+ autorange: true,
+ mirror: true,
+ showline: true,
+ zeroline: false
+ },
+ },
+ hoverlabel: {
+ font: {
+ size: 11
+ },
+ align: 'left'
+ }
+};
+
+// structure of input data
+const overview_projection_default_params = {
+ meta: {
+ color_type: '',
+ traces: [],
+ color_variable: ''
+ },
+ data: {
+ x: [],
+ y: [],
+ z: [],
+ color: [],
+ size: '',
+ opacity: '',
+ line: {},
+ x_range: [],
+ y_range: [],
+ reset_axes: false
+ },
+ hover: {
+ hoverinfo: '',
+ text: []
+ },
+ group_centers: {
+ group: [],
+ x: [],
+ y: [],
+ z: []
+ }
+}
+
+// update 2D projection with continuous coloring
+shinyjs.updatePlot2DContinuous = function(params) {
+ params = shinyjs.getParams(params, overview_projection_default_params);
+ const data = [];
+ data.push(
+ {
+ x: params.data.x,
+ y: params.data.y,
+ mode: 'markers',
+ type: 'scattergl',
+ marker: {
+ size: params.data.point_size,
+ opacity: params.data.point_opacity,
+ line: params.data.point_line,
+ color: params.data.color,
+ colorscale: 'YlGnBu',
+ reversescale: true,
+ colorbar: {
+ title: {
+ text: params.meta.color_variable
+ }
+ }
+ },
+ hoverinfo: params.hover.hoverinfo,
+ text: params.hover.text,
+ showlegend: false
+ }
+ );
+ const layout_here = Object.assign(overview_projection_layout_2D);
+ if (params.data.reset_axes) {
+ layout_here.xaxis['autorange'] = true;
+ layout_here.yaxis['autorange'] = true;
+ } else {
+ layout_here.xaxis['autorange'] = false;
+ layout_here.xaxis['range'] = params.data.x_range;
+ layout_here.yaxis['autorange'] = false;
+ layout_here.yaxis['range'] = params.data.y_range;
+ }
+ Plotly.react('overview_projection', data, layout_here);
+}
+
+// update 3D projection with continuous coloring
+shinyjs.updatePlot3DContinuous = function(params) {
+ params = shinyjs.getParams(params, overview_projection_default_params);
+ const data = [];
+ data.push(
+ {
+ x: params.data.x,
+ y: params.data.y,
+ z: params.data.z,
+ mode: 'markers',
+ type: 'scatter3d',
+ marker: {
+ size: params.data.point_size,
+ opacity: params.data.point_opacity,
+ line: params.data.point_line,
+ color: params.data.color,
+ colorscale: 'YlGnBu',
+ reversescale: true,
+ colorbar: {
+ title: {
+ text: params.meta.color_variable
+ }
+ }
+ },
+ hoverinfo: params.hover.hoverinfo,
+ text: params.hover.text,
+ showlegend: false
+ }
+ );
+ Plotly.react('overview_projection', data, overview_projection_layout_3D);
+}
+
+// update 2D projection with categorical coloring
+shinyjs.updatePlot2DCategorical = function(params) {
+ params = shinyjs.getParams(params, overview_projection_default_params);
+ const data = [];
+ for (let i = 0; i < params.data.x.length; i++) {
+ data.push(
+ {
+ x: params.data.x[i],
+ y: params.data.y[i],
+ name: params.meta.traces[i],
+ mode: 'markers',
+ type: 'scattergl',
+ marker: {
+ size: params.data.point_size,
+ opacity: params.data.point_opacity,
+ line: params.data.point_line,
+ color: params.data.color[i]
+ },
+ hoverinfo: params.hover.hoverinfo,
+ text: params.hover.text[i],
+ hoverlabel: {
+ bgcolor: params.data.color[i]
+ },
+ showlegend: true
+ }
+ );
+ }
+ if (params.group_centers.group.length >= 1) {
+ data.push(
+ {
+ x: params.group_centers.x,
+ y: params.group_centers.y,
+ text: params.group_centers.group,
+ type: 'scattergl',
+ mode: 'text',
+ name: 'Labels',
+ textposition: 'middle center',
+ textfont: {
+ color: '#000000',
+ size: 16
+ },
+ hoverinfo: 'skip',
+ inherit: false
+ }
+ );
+ }
+ const layout_here = Object.assign(overview_projection_layout_2D);
+ if (params.data.reset_axes) {
+ layout_here.xaxis['autorange'] = true;
+ layout_here.yaxis['autorange'] = true;
+ } else {
+ layout_here.xaxis['autorange'] = false;
+ layout_here.xaxis['range'] = params.data.x_range;
+ layout_here.yaxis['autorange'] = false;
+ layout_here.yaxis['range'] = params.data.y_range;
+ }
+ Plotly.react('overview_projection', data, layout_here);
+}
+
+// update 3D projection with categorical coloring
+shinyjs.updatePlot3DCategorical = function(params) {
+ params = shinyjs.getParams(params, overview_projection_default_params);
+ const data = [];
+ for (let i = 0; i < params.data.x.length; i++) {
+ data.push(
+ {
+ x: params.data.x[i],
+ y: params.data.y[i],
+ z: params.data.z[i],
+ name: params.meta.traces[i],
+ mode: 'markers',
+ type: 'scatter3d',
+ marker: {
+ size: params.data.point_size,
+ opacity: params.data.point_opacity,
+ line: params.data.point_line,
+ color: params.data.color[i]
+ },
+ hoverinfo: params.hover.hoverinfo,
+ text: params.hover.text[i],
+ hoverlabel: {
+ bgcolor: params.data.color[i]
+ },
+ showlegend: true
+ }
+ );
+ }
+ if (params.group_centers.group.length >= 1) {
+ data.push(
+ {
+ x: params.group_centers.x,
+ y: params.group_centers.y,
+ z: params.group_centers.z,
+ text: params.group_centers.group,
+ type: 'scatter3d',
+ mode: 'text',
+ name: 'Labels',
+ textposition: 'middle center',
+ textfont: {
+ color: '#000000',
+ size: 16
+ },
+ hoverinfo: 'skip',
+ inherit: false
+ }
+ );
+ }
+ Plotly.react('overview_projection', data, overview_projection_layout_3D);
+}
diff --git a/inst/shiny/v1.3/overview/obj_projection_cells_to_show.R b/inst/shiny/v1.3/overview/obj_projection_cells_to_show.R
new file mode 100644
index 0000000..debdbd2
--- /dev/null
+++ b/inst/shiny/v1.3/overview/obj_projection_cells_to_show.R
@@ -0,0 +1,37 @@
+##----------------------------------------------------------------------------##
+## Indices of cells to show in projection.
+##----------------------------------------------------------------------------##
+overview_projection_cells_to_show <- reactive({
+ req(input[["overview_projection_percentage_cells_to_show"]])
+ # message('--> trigger "overview_projection_cells_to_show"')
+ groups <- getGroups()
+ ## require group filters UI elements and at least 1 group level to be selected
+ for ( i in groups ) {
+ req(input[[paste0("overview_projection_group_filter_", i)]])
+ }
+ pct_cells <- input[["overview_projection_percentage_cells_to_show"]]
+ group_filters <- list()
+ ## store group filters
+ for ( i in groups ) {
+ group_filters[[i]] <- input[[paste0("overview_projection_group_filter_", i)]]
+ }
+ cells_df <- getMetaData() %>%
+ dplyr::mutate(row_id = row_number())
+ ## remove cells based on group filters
+ for ( i in groups ) {
+ ## make sure that group exists in meta data (as column) and that selected
+ ## groups are not NULL, then subset the data frame
+ if ( i %in% colnames(cells_df) ) {
+ cells_df <- cells_df[which(cells_df[[i]] %in% group_filters[[i]] ),]
+ }
+ }
+ cells_df <- cells_df %>%
+ dplyr::select(cell_barcode, row_id)
+ ## randomly remove cells (if necessary)
+ cells_df <- randomlySubsetCells(cells_df, pct_cells)
+ ## put rows in random order
+ cells_df <- cells_df[ sample(1:nrow(cells_df)) , ]
+ cells_to_show <- cells_df$row_id
+ # message(str(cells_to_show))
+ return(cells_to_show)
+})
diff --git a/inst/shiny/v1.3/overview/obj_projection_color_assignments.R b/inst/shiny/v1.3/overview/obj_projection_color_assignments.R
new file mode 100644
index 0000000..ebf41cb
--- /dev/null
+++ b/inst/shiny/v1.3/overview/obj_projection_color_assignments.R
@@ -0,0 +1,16 @@
+##----------------------------------------------------------------------------##
+## Color assignments.
+##----------------------------------------------------------------------------##
+overview_projection_color_assignments <- reactive({
+ req(
+ overview_projection_data(),
+ overview_projection_parameters_plot()
+ )
+ # message('--> trigger "overview_projection_color_assignments"')
+ colors <- assignColorsToGroups(
+ overview_projection_data(),
+ overview_projection_parameters_plot()[['color_variable']]
+ )
+ # message(str(colors))
+ return(colors)
+})
diff --git a/inst/shiny/v1.3/overview/obj_projection_coordinates.R b/inst/shiny/v1.3/overview/obj_projection_coordinates.R
new file mode 100644
index 0000000..da21ce5
--- /dev/null
+++ b/inst/shiny/v1.3/overview/obj_projection_coordinates.R
@@ -0,0 +1,16 @@
+##----------------------------------------------------------------------------##
+## Coordinates of cells in projection.
+##----------------------------------------------------------------------------##
+overview_projection_coordinates <- reactive({
+ req(
+ overview_projection_parameters_plot(),
+ overview_projection_cells_to_show()
+ )
+ # message('--> trigger "overview_projection_coordinates"')
+ parameters <- overview_projection_parameters_plot()
+ cells_to_show <- overview_projection_cells_to_show()
+ req(parameters[["projection"]] %in% availableProjections())
+ coordinates <- getProjection(parameters[["projection"]])[cells_to_show,]
+# message(str(coordinates))
+ return(coordinates)
+})
diff --git a/inst/shiny/v1.3/overview/obj_projection_data.R b/inst/shiny/v1.3/overview/obj_projection_data.R
new file mode 100644
index 0000000..ea66ee1
--- /dev/null
+++ b/inst/shiny/v1.3/overview/obj_projection_data.R
@@ -0,0 +1,10 @@
+##----------------------------------------------------------------------------##
+## Cell meta data and position in projection.
+##----------------------------------------------------------------------------##
+overview_projection_data <- reactive({
+ req(overview_projection_cells_to_show())
+ # message('--> trigger "overview_projection_data"')
+ cells_df <- getMetaData()[overview_projection_cells_to_show(),]
+ # message(str(cells_df))
+ return(cells_df)
+})
diff --git a/inst/shiny/v1.3/overview/obj_projection_data_to_plot.R b/inst/shiny/v1.3/overview/obj_projection_data_to_plot.R
new file mode 100644
index 0000000..6563fd1
--- /dev/null
+++ b/inst/shiny/v1.3/overview/obj_projection_data_to_plot.R
@@ -0,0 +1,58 @@
+##----------------------------------------------------------------------------##
+## Collect data required to update projection.
+##----------------------------------------------------------------------------##
+overview_projection_data_to_plot_raw <- reactive({
+ req(
+ overview_projection_data(),
+ overview_projection_coordinates(),
+ overview_projection_parameters_plot(),
+ reactive_colors(),
+ overview_projection_hover_info(),
+ nrow(overview_projection_data()) == length(overview_projection_hover_info()) || overview_projection_hover_info() == "none"
+ )
+ # message('--> trigger "overview_projection_data_to_plot"')
+ ## get colors for groups (if applicable)
+ if ( is.numeric(overview_projection_parameters_plot()[['color_variable']]) ) {
+ color_assignments <- NA
+ } else {
+ color_assignments <- assignColorsToGroups(
+ overview_projection_data(),
+ overview_projection_parameters_plot()[['color_variable']]
+ )
+ }
+ ## print details for debugging purposes
+ # if (
+ # exists('mode_debugging') &&
+ # mode_debugging == TRUE &&
+ # length(overview_projection_hover_info()) > 1
+ # ) {
+ # random_cells <- c(10, 51, 79)
+ # for (i in random_cells) {
+ # current_cell <- overview_projection_data()$cell_barcode[i]
+ # coordinates_shown <- overview_projection_coordinates()[i,]
+ # hover_shown <- overview_projection_hover_info()[i]
+ # position_of_current_cell_in_original_data <- which(getMetaData()$cell_barcode == current_cell)
+ # coordinates_should <- data_set()$projections[[overview_projection_parameters_plot()$projection]][position_of_current_cell_in_original_data,]
+ # message(
+ # glue::glue(
+ # '{current_cell}: ',
+ # 'coords. {round(coordinates_shown[1], digits=2)}/{round(coordinates_should[1], digits=2)} // ',
+ # '{round(coordinates_shown[2], digits=2)}/{round(coordinates_should[2], digits=2)}'
+ # )
+ # )
+ # }
+ # }
+ ## return collect data
+ to_return <- list(
+ cells_df = overview_projection_data(),
+ coordinates = overview_projection_coordinates(),
+ reset_axes = isolate(overview_projection_parameters_other[['reset_axes']]),
+ plot_parameters = overview_projection_parameters_plot(),
+ color_assignments = color_assignments,
+ hover_info = overview_projection_hover_info()
+ )
+ # message(str(to_return))
+ return(to_return)
+})
+
+overview_projection_data_to_plot <- debounce(overview_projection_data_to_plot_raw, 150)
diff --git a/inst/shiny/v1.3/overview/obj_projection_hover_info.R b/inst/shiny/v1.3/overview/obj_projection_hover_info.R
new file mode 100644
index 0000000..2765b31
--- /dev/null
+++ b/inst/shiny/v1.3/overview/obj_projection_hover_info.R
@@ -0,0 +1,20 @@
+##----------------------------------------------------------------------------##
+## Hover info of cells in projection.
+##----------------------------------------------------------------------------##
+overview_projection_hover_info <- reactive({
+ req(
+ hover_info_projections(),
+ overview_projection_cells_to_show()
+ )
+ # message('--> trigger "overview_projection_hover_info"')
+ if (
+ !is.null(preferences[["show_hover_info_in_projections"]]) &&
+ preferences[['show_hover_info_in_projections']] == TRUE
+ ) {
+ hover_info <- hover_info_projections()[overview_projection_cells_to_show()]
+ } else {
+ hover_info <- hover_info_projections()
+ }
+ # message(str(hover_info))
+ return(hover_info)
+})
diff --git a/inst/shiny/v1.3/overview/obj_projection_parameters_plot.R b/inst/shiny/v1.3/overview/obj_projection_parameters_plot.R
new file mode 100644
index 0000000..cffa244
--- /dev/null
+++ b/inst/shiny/v1.3/overview/obj_projection_parameters_plot.R
@@ -0,0 +1,47 @@
+##----------------------------------------------------------------------------##
+## Collect parameters for projection plot.
+##----------------------------------------------------------------------------##
+overview_projection_parameters_plot_raw <- reactive({
+ req(
+ input[["overview_projection_to_display"]],
+ input[["overview_projection_to_display"]] %in% availableProjections(),
+ input[["overview_projection_point_color"]],
+ input[["overview_projection_point_color"]] %in% colnames(getMetaData()),
+ input[["overview_projection_point_size"]],
+ input[["overview_projection_point_opacity"]],
+ !is.null(input[["overview_projection_point_border"]]),
+ input[["overview_projection_scale_x_manual_range"]],
+ input[["overview_projection_scale_y_manual_range"]],
+ !is.null(preferences[["use_webgl"]]),
+ !is.null(preferences[["show_hover_info_in_projections"]])
+ )
+ # message('--> trigger "overview_projection_parameters_plot"')
+ parameters <- list(
+ projection = input[["overview_projection_to_display"]],
+ n_dimensions = ncol(getProjection(input[["overview_projection_to_display"]])),
+ color_variable = input[["overview_projection_point_color"]],
+ point_size = input[["overview_projection_point_size"]],
+ point_opacity = input[["overview_projection_point_opacity"]],
+ draw_border = input[["overview_projection_point_border"]],
+ group_labels = input[["overview_projection_show_group_label"]],
+ x_range = input[["overview_projection_scale_x_manual_range"]],
+ y_range = input[["overview_projection_scale_y_manual_range"]],
+ webgl = preferences[["use_webgl"]],
+ hover_info = preferences[["show_hover_info_in_projections"]]
+ )
+ # message(str(parameters))
+ return(parameters)
+})
+
+overview_projection_parameters_plot <- debounce(overview_projection_parameters_plot_raw, 150)
+
+##
+overview_projection_parameters_other <- reactiveValues(
+ reset_axes = FALSE
+)
+
+##
+observeEvent(input[['overview_projection_to_display']], {
+ # message('--> set "overview: reset_axes"')
+ overview_projection_parameters_other[['reset_axes']] <- TRUE
+})
diff --git a/inst/shiny/v1.3/overview/obj_projection_selected_cells.R b/inst/shiny/v1.3/overview/obj_projection_selected_cells.R
new file mode 100644
index 0000000..1fd7f0a
--- /dev/null
+++ b/inst/shiny/v1.3/overview/obj_projection_selected_cells.R
@@ -0,0 +1,23 @@
+##----------------------------------------------------------------------------##
+## Reactive that holds IDs of selected cells (ID is built from position in
+## projection).
+##----------------------------------------------------------------------------##
+overview_projection_selected_cells <- reactive({
+ ## make sure plot parameters are set because it means that the plot can be
+ ## generated
+ req(overview_projection_data_to_plot())
+ ## check selection
+ ## ... selection has not been made or there is no cell in it
+ if (
+ is.null(plotly::event_data("plotly_selected", source = "overview_projection")) ||
+ length(plotly::event_data("plotly_selected", source = "overview_projection")) == 0
+ ) {
+ return(NULL)
+ ## ... selection has been made and at least 1 cell is in it
+ } else {
+ ## get number of selected cells
+ plotly::event_data("plotly_selected", source = "overview_projection") %>%
+ dplyr::mutate(identifier = paste0(x, '-', y)) %>%
+ return()
+ }
+})
diff --git a/inst/shiny/v1.3/overview/selected_cells_plot.R b/inst/shiny/v1.3/overview/out_details_selected_cells_plot.R
similarity index 56%
rename from inst/shiny/v1.3/overview/selected_cells_plot.R
rename to inst/shiny/v1.3/overview/out_details_selected_cells_plot.R
index 23d1a11..2a42b74 100644
--- a/inst/shiny/v1.3/overview/selected_cells_plot.R
+++ b/inst/shiny/v1.3/overview/out_details_selected_cells_plot.R
@@ -1,119 +1,68 @@
-##----------------------------------------------------------------------------##
-## Tab: Overview
-##
-## Plot of selected cells.
-##----------------------------------------------------------------------------##
-
-##----------------------------------------------------------------------------##
-## UI element for output.
-##----------------------------------------------------------------------------##
-
-output[["overview_selected_cells_plot_UI"]] <- renderUI({
- fluidRow(
- cerebroBox(
- title = tagList(
- boxTitle("Plot of selected cells"),
- cerebroInfoButton("overview_details_selected_cells_plot_info")
- ),
- tagList(
- selectInput(
- "overview_selected_cells_plot_select_variable",
- label = "Variable to compare:",
- choices = colnames(getMetaData())[! colnames(getMetaData()) %in% c("cell_barcode")]
- ),
- plotly::plotlyOutput("overview_details_selected_cells_plot")
- )
- )
- )
-})
-
##----------------------------------------------------------------------------##
## Plot for selected cells.
## - in sync with selected color variable
## - if categorical: number of cells in each group
## - if numerical: box/violin plot
##----------------------------------------------------------------------------##
-
output[["overview_details_selected_cells_plot"]] <- plotly::renderPlotly({
req(
input[["overview_projection_to_display"]],
+ input[["overview_projection_to_display"]] %in% availableProjections(),
input[["overview_selected_cells_plot_select_variable"]]
)
-
## extract cells to plot
cells_df <- cbind(
- getProjection(input[["overview_projection_to_display"]]),
- getMetaData()
- )
-
- ##
- ## ...
- if (
- is.null(plotly::event_data("plotly_selected", source = "overview_projection")) ||
- length(plotly::event_data("plotly_selected", source = "overview_projection")) == 0
- ) {
-
+ getProjection(input[["overview_projection_to_display"]]),
+ getMetaData()
+ )
+ ## check selection
+ ## ... selection has not been made or there is no cell in it
+ if ( is.null(overview_projection_selected_cells()) ) {
###
- cells_df <- cells_df %>% dplyr::mutate(group = 'not selected')
-
- ## ...
+ cells_df <- cells_df %>%
+ dplyr::mutate(group = 'not selected')
+ ## ... selection has been made and at least 1 cell is in it
} else {
-
- ##
- selected_cells <- plotly::event_data("plotly_selected", source = "overview_projection") %>%
- dplyr::mutate(identifier = paste0(x, '-', y))
-
##
cells_df <- cells_df %>%
dplyr::rename(X1 = 1, X2 = 2) %>%
dplyr::mutate(
identifier = paste0(X1, '-', X2),
- group = ifelse(identifier %in% selected_cells$identifier, 'selected', 'not selected'),
+ group = ifelse(identifier %in% overview_projection_selected_cells()$identifier, 'selected', 'not selected'),
group = factor(group, levels = c('selected', 'not selected'))
)
}
-
color_variable <- input[["overview_selected_cells_plot_select_variable"]]
-
## if the selected coloring variable is categorical, represent the selected
## cells in a bar chart
if (
is.factor(cells_df[[ color_variable ]]) ||
is.character(cells_df[[ color_variable ]])
) {
-
## filter table for selected cells
cells_df <- cells_df %>%
dplyr::filter(group == 'selected')
-
## prepare table, depending on whether at least a single cell is selected
## ... at least 1 cell is selected
if ( nrow(cells_df) > 0 ) {
-
## count the number of cells by selected meta data column
cells_df <- cells_df %>%
dplyr::group_by(dplyr::across(c(color_variable))) %>%
dplyr::tally() %>%
dplyr::ungroup()
-
## ... no cell is selected
} else {
-
## check whether the selected meta data column contains a registered
## grouping variable
## ... the column is a grouping variable
if ( color_variable %in% getGroups() ) {
-
## get levels for the grouping variable
group_levels <- getGroupLevels(color_variable)
-
## ... the column is not a known grouping variable
} else {
-
## get unique values on the meta data column
group_levels <- unique(getMetaData()[[color_variable]])
}
-
## create empty table to show
cells_df <- data.frame(
group = group_levels,
@@ -121,14 +70,11 @@ output[["overview_details_selected_cells_plot"]] <- plotly::renderPlotly({
) %>%
dplyr::rename(!!color_variable := group)
}
-
+ ## get colors for groups
+ colors_for_groups <- assignColorsToGroups(cells_df, color_variable)
## convert factor to character to avoid empty bars when selecting cells of
## certain groups
cells_df[[1]] <- as.character(cells_df[[1]])
-
- ## get colors for groups
- colors_for_groups <- assignColorsToGroups(cells_df, color_variable)
-
## make bar chart
plot <- plotly::plot_ly(
cells_df,
@@ -141,16 +87,12 @@ output[["overview_details_selected_cells_plot"]] <- plotly::renderPlotly({
showlegend = FALSE,
hoverinfo = "y"
)
-
y_axis_title <- "Number of cells"
-
## if the selected coloring variable is numeric/continuous
} else if ( is.numeric(cells_df[[ color_variable ]]) ) {
-
## remove unnecessary columns
cells_df <- cells_df %>%
dplyr::select(group, tidyselect::all_of(color_variable))
-
## create violin/box plot
plot <- plotly::plot_ly(
cells_df,
@@ -164,7 +106,10 @@ output[["overview_details_selected_cells_plot"]] <- plotly::renderPlotly({
visible = TRUE
),
color = ~cells_df[[1]],
- colors = setNames(c('#e74c3c','#7f8c8d'), c('selected', 'not selected')),
+ colors = setNames(
+ c('#e74c3c','#7f8c8d'),
+ c('selected', 'not selected')
+ ),
source = "subset",
showlegend = FALSE,
hoverinfo = "y",
@@ -172,10 +117,8 @@ output[["overview_details_selected_cells_plot"]] <- plotly::renderPlotly({
size = 5
)
)
-
y_axis_title <- colnames(cells_df)[2]
}
-
plot %>%
plotly::layout(
title = "",
@@ -186,7 +129,8 @@ output[["overview_details_selected_cells_plot"]] <- plotly::renderPlotly({
),
yaxis = list(
title = y_axis_title,
- hoverformat = ".0f",
+ tickformat = ",.0f",
+ hoverformat = ",.0f",
mirror = TRUE,
showline = TRUE
),
@@ -194,28 +138,3 @@ output[["overview_details_selected_cells_plot"]] <- plotly::renderPlotly({
hovermode = "compare"
)
})
-
-##----------------------------------------------------------------------------##
-## Info box that gets shown when pressing the "info" button.
-##----------------------------------------------------------------------------##
-
-observeEvent(input[["overview_details_selected_cells_plot_info"]], {
- showModal(
- modalDialog(
- overview_details_selected_cells_plot_info$text,
- title = overview_details_selected_cells_plot_info$title,
- easyClose = TRUE,
- footer = NULL,
- size = "l"
- )
- )
-})
-
-##----------------------------------------------------------------------------##
-## Text in info box.
-##----------------------------------------------------------------------------##
-
-overview_details_selected_cells_plot_info <- list(
- title = "Plot of selected cells",
- text = p("Depending on the variable selected to color cells in the dimensional reduction, this plot will show different things. If you select a categorical variable, e.g. 'sample' or 'cluster', you will get a bar plot showing which groups the cells selected with the box or lasso tool come from. Instead, if you select a continuous variable, e.g. the number of transcripts (nUMI), you will see a violin/box plot showing the distribution of that variable in the selected vs. non-selected cells.")
-)
diff --git a/inst/shiny/v1.3/overview/out_details_selected_cells_table.R b/inst/shiny/v1.3/overview/out_details_selected_cells_table.R
new file mode 100644
index 0000000..bc51725
--- /dev/null
+++ b/inst/shiny/v1.3/overview/out_details_selected_cells_table.R
@@ -0,0 +1,54 @@
+##----------------------------------------------------------------------------##
+## Table.
+##----------------------------------------------------------------------------##
+output[["overview_details_selected_cells_table"]] <- DT::renderDataTable({
+ ## don't proceed without these inputs
+ req(
+ input[["overview_projection_to_display"]],
+ input[["overview_projection_to_display"]] %in% availableProjections()
+ )
+ ## check selection
+ ## ... selection has not been made or there is no cell in it
+ if ( is.null(overview_projection_selected_cells()) ) {
+ ## prepare empty table
+ getMetaData() %>%
+ dplyr::slice(0) %>%
+ prepareEmptyTable()
+ ## ... selection has been made and at least 1 cell is in it
+ } else {
+ ## extract cells for table
+ cells_df <- cbind(
+ getProjection(input[["overview_projection_to_display"]]),
+ getMetaData()
+ ) %>%
+ as.data.frame()
+ ## filter out non-selected cells with X-Y identifier
+ cells_df <- cells_df %>%
+ dplyr::rename(X1 = 1, X2 = 2) %>%
+ dplyr::mutate(identifier = paste0(X1, '-', X2)) %>%
+ dplyr::filter(identifier %in% overview_projection_selected_cells()$identifier) %>%
+ dplyr::select(-c(X1, X2, identifier)) %>%
+ dplyr::select(cell_barcode, everything())
+ ## check how many cells are left after filtering
+ ## ... no cells are left
+ if ( nrow(cells_df) == 0 ) {
+ ## prepare empty table
+ getMetaData() %>%
+ dplyr::slice(0) %>%
+ prepareEmptyTable()
+ ## ... at least 1 cell is left
+ } else {
+ ## prepare proper table
+ prettifyTable(
+ cells_df,
+ filter = list(position = "top", clear = TRUE),
+ dom = "Brtlip",
+ show_buttons = TRUE,
+ number_formatting = input[["overview_details_selected_cells_table_number_formatting"]],
+ color_highlighting = input[["overview_details_selected_cells_table_color_highlighting"]],
+ hide_long_columns = TRUE,
+ download_file_name = "overview_details_of_selected_cells"
+ )
+ }
+ }
+})
diff --git a/inst/shiny/v1.3/overview/out_number_of_selected_cells.R b/inst/shiny/v1.3/overview/out_number_of_selected_cells.R
new file mode 100644
index 0000000..0a4f168
--- /dev/null
+++ b/inst/shiny/v1.3/overview/out_number_of_selected_cells.R
@@ -0,0 +1,19 @@
+##----------------------------------------------------------------------------##
+## Text showing the number of selected cells.
+##----------------------------------------------------------------------------##
+output[["overview_number_of_selected_cells"]] <- renderText({
+ ## check selection
+ ## ... selection has not been made or there is no cell in it
+ if ( is.null(overview_projection_selected_cells()) ) {
+ ## manually set counter to 0
+ number_of_selected_cells <- 0
+ ## ... selection has been made and at least 1 cell is in it
+ } else {
+ ## get number of selected cells
+ number_of_selected_cells <- overview_projection_selected_cells() %>%
+ nrow() %>%
+ formatC(format = "f", big.mark = ",", digits = 0)
+ }
+ ## prepare string to show
+ paste0("Number of selected cells: ", number_of_selected_cells)
+})
diff --git a/inst/shiny/v1.3/overview/out_projection.R b/inst/shiny/v1.3/overview/out_projection.R
new file mode 100644
index 0000000..20bb1ed
--- /dev/null
+++ b/inst/shiny/v1.3/overview/out_projection.R
@@ -0,0 +1,54 @@
+##----------------------------------------------------------------------------##
+## Plotly plot of the selected projection.
+##----------------------------------------------------------------------------##
+output[["overview_projection"]] <- plotly::renderPlotly({
+ plotly::plot_ly(type = 'scattergl', mode = 'markers', source = "overview_projection") %>%
+ plotly::layout(
+ xaxis = list(
+ autorange = TRUE,
+ mirror = TRUE,
+ showline = TRUE,
+ zeroline = FALSE
+ ),
+ yaxis = list(
+ autorange = TRUE,
+ mirror = TRUE,
+ showline = TRUE,
+ zeroline = FALSE
+ )
+ )
+})
+
+##----------------------------------------------------------------------------##
+## Info box that gets shown when pressing the "info" button.
+##----------------------------------------------------------------------------##
+observeEvent(input[["overview_projection_info"]], {
+ showModal(
+ modalDialog(
+ overview_projection_info[["text"]],
+ title = overview_projection_info[["title"]],
+ easyClose = TRUE,
+ footer = NULL,
+ size = "l"
+ )
+ )
+})
+
+##----------------------------------------------------------------------------##
+## Text in info box.
+##----------------------------------------------------------------------------##
+overview_projection_info <- list(
+ title = "Dimensional reduction",
+ text = HTML("
+ Interactive projection of cells into 2-dimensional space based on their expression profile.
+
+ - Both tSNE and UMAP are frequently used algorithms for dimensional reduction in single cell transcriptomics. While they generally allow to make similar conclusions, some differences exist between the two (please refer to Google and/or literature, such as Becht E. et al., Dimensionality reduction for visualizing single-cell data using UMAP. Nature Biotechnology, 2018, 37, 38-44).
+ - Cells can be colored by the sample they came from, the cluster they were assigned, the number of transcripts or expressed genes, percentage of mitochondrial and ribosomal gene expression, an apoptotic score (calculated based on the expression of few marker genes; more info in the 'Sample info' tab on the left), or cell cycle status (determined using the Seurat and Cyclone method).
+ - Confidence ellipses show the 95% confidence regions.
+ - Samples and clusters can be removed from the plot individually to highlight a contrast of interest.
+ - By default, the point size is set to 15 without any transparency but both these attributes can be changed using the sliders on the left. The point size can also be set to reflect the number of transcripts or expressed genes.
+ - The last two slider elements on the left can be used to resize the projection axes. This can be particularly useful when a projection contains a population of cell that is very far away from the rest and therefore creates a big empty space (which is not uncommon for UMAPs)
+
+ The plot is interactive (drag and zoom) but depending on the computer of the user and the number of cells displayed it can become very slow."
+ )
+)
diff --git a/inst/shiny/v1.3/overview/projection.R b/inst/shiny/v1.3/overview/projection.R
deleted file mode 100644
index 799435e..0000000
--- a/inst/shiny/v1.3/overview/projection.R
+++ /dev/null
@@ -1,765 +0,0 @@
-##----------------------------------------------------------------------------##
-## Tab: Overview
-##
-## Projection.
-##----------------------------------------------------------------------------##
-
-##----------------------------------------------------------------------------##
-## Layout of the UI elements.
-##----------------------------------------------------------------------------##
-output[["overview_projection_UI"]] <- renderUI({
- fluidRow(
- ## selections and parameters
- column(width = 3, offset = 0, style = "padding: 0px;",
- cerebroBox(
- title = tagList(
- "Main parameters",
- actionButton(
- inputId = "overview_projection_main_parameters_info",
- label = "info",
- icon = NULL,
- class = "btn-xs",
- title = "Show additional information for this panel.",
- style = "margin-left: 5px"
- )
- ),
- uiOutput("overview_projection_main_parameters_UI")
- ),
- cerebroBox(
- title = tagList(
- "Additional parameters",
- actionButton(
- inputId = "overview_projection_additional_parameters_info",
- label = "info",
- icon = NULL,
- class = "btn-xs",
- title = "Show additional information for this panel.",
- style = "margin-left: 5px"
- )
- ),
- uiOutput("overview_projection_additional_parameters_UI"),
- collapsed = TRUE
- ),
- cerebroBox(
- title = tagList(
- "Group filters",
- actionButton(
- inputId = "overview_projection_group_filters_info",
- label = "info",
- icon = NULL,
- class = "btn-xs",
- title = "Show additional information for this panel.",
- style = "margin-left: 5px"
- )
- ),
- uiOutput("overview_projection_group_filters_UI"),
- collapsed = TRUE
- )
- ),
- ## plot
- column(width = 9, offset = 0, style = "padding: 0px;",
- cerebroBox(
- title = tagList(
- boxTitle("Dimensional reduction"),
- actionButton(
- inputId = "overview_projection_info",
- label = "info",
- title = "Show additional information for this panel.",
- icon = NULL,
- class = "btn-xs",
- style = "margin-right: 3px"
- ),
- shinyFiles::shinySaveButton(
- "overview_projection_export",
- label = "export to PDF",
- title = "Export dimensional reduction to PDF file.",
- filetype = "pdf",
- viewtype = "icon",
- class = "btn-xs",
- style = "margin-right: 3px"
- ),
- shinyWidgets::dropdownButton(
- tags$div(
- style = "color: black !important;",
- uiOutput("overview_projection_scales_UI")
- ),
- circle = FALSE,
- icon = icon("cog"),
- inline = TRUE,
- size = "xs"
- )
- ),
- tagList(
- shinycssloaders::withSpinner(
- plotly::plotlyOutput(
- "overview_projection",
- width = "auto",
- height = "85vh"
- ),
- type = 8,
- hide.ui = FALSE
- ),
- tags$br(),
- htmlOutput("overview_number_of_selected_cells"),
- )
- )
- )
- )
-})
-
-##----------------------------------------------------------------------------##
-## UI elements to set main parameters for the projection.
-##----------------------------------------------------------------------------##
-
-output[["overview_projection_main_parameters_UI"]] <- renderUI({
-
- tagList(
- selectInput(
- "overview_projection_to_display",
- label = "Projection",
- choices = availableProjections()
- ),
- selectInput(
- "overview_point_color",
- label = "Color cells by",
- choices = colnames(getMetaData())[! colnames(getMetaData()) %in% c("cell_barcode")]
- )
- )
-})
-
-##----------------------------------------------------------------------------##
-## Info box that gets shown when pressing the "info" button.
-##----------------------------------------------------------------------------##
-
-observeEvent(input[["overview_projection_main_parameters_info"]], {
- showModal(
- modalDialog(
- overview_projection_main_parameters_info[["text"]],
- title = overview_projection_main_parameters_info[["title"]],
- easyClose = TRUE,
- footer = NULL,
- size = "l"
- )
- )
-})
-
-##----------------------------------------------------------------------------##
-## Text in info box.
-##----------------------------------------------------------------------------##
-
-overview_projection_main_parameters_info <- list(
- title = "Main parameters for projection",
- text = HTML("
- The elements in this panel allow you to control what and how results are displayed across the whole tab.
-
- - Projection: Select here which projection you want to see in the scatter plot on the right.
- - Color cells by: Select which variable, categorical or continuous, from the meta data should be used to color the cells.
-
- "
- )
-)
-
-##----------------------------------------------------------------------------##
-## UI elements to set additional parameters for the projection.
-##----------------------------------------------------------------------------##
-
-output[["overview_projection_additional_parameters_UI"]] <- renderUI({
- tagList(
- sliderInput(
- "overview_point_size",
- label = "Point size",
- min = scatter_plot_point_size[["min"]],
- max = scatter_plot_point_size[["max"]],
- step = scatter_plot_point_size[["step"]],
- value = scatter_plot_point_size[["default"]]
- ),
- sliderInput(
- "overview_point_opacity",
- label = "Point opacity",
- min = scatter_plot_point_opacity[["min"]],
- max = scatter_plot_point_opacity[["max"]],
- step = scatter_plot_point_opacity[["step"]],
- value = scatter_plot_point_opacity[["default"]]
- ),
- sliderInput(
- "overview_percentage_cells_to_show",
- label = "Show % of cells",
- min = scatter_plot_percentage_cells_to_show[["min"]],
- max = scatter_plot_percentage_cells_to_show[["max"]],
- step = scatter_plot_percentage_cells_to_show[["step"]],
- value = scatter_plot_percentage_cells_to_show[["default"]]
- )
- )
-})
-
-## make sure elements are loaded even though the box is collapsed
-outputOptions(
- output,
- "overview_projection_additional_parameters_UI",
- suspendWhenHidden = FALSE
-)
-
-##----------------------------------------------------------------------------##
-## Info box that gets shown when pressing the "info" button.
-##----------------------------------------------------------------------------##
-
-observeEvent(input[["overview_projection_additional_parameters_info"]], {
- showModal(
- modalDialog(
- overview_projection_additional_parameters_info[["text"]],
- title = overview_projection_additional_parameters_info[["title"]],
- easyClose = TRUE,
- footer = NULL,
- size = "l"
- )
- )
-})
-
-##----------------------------------------------------------------------------##
-## Text in info box.
-##----------------------------------------------------------------------------##
-# - Range of X/Y axis (located in dropdown menu above the projection): Set the X/Y axis limits. This is useful when you want to change the aspect ratio of the plot.
-
-overview_projection_additional_parameters_info <- list(
- title = "Additional parameters for projection",
- text = HTML("
- The elements in this panel allow you to control what and how results are displayed across the whole tab.
-
- - Point size: Controls how large the cells should be.
- - Point opacity: Controls the transparency of the cells.
- - Show % of cells: Using the slider, you can randomly remove a fraction of cells from the plot. This can be useful for large data sets and/or computers with limited resources.
-
- "
- )
-)
-
-##----------------------------------------------------------------------------##
-## UI elements to set group filters for the projection.
-##----------------------------------------------------------------------------##
-
-output[["overview_projection_group_filters_UI"]] <- renderUI({
- group_filters <- list()
- for ( i in getGroups() ) {
- group_filters[[i]] <- shinyWidgets::pickerInput(
- paste0("overview_projection_group_filter_", i),
- label = i,
- choices = getGroupLevels(i),
- selected = getGroupLevels(i),
- options = list("actions-box" = TRUE),
- multiple = TRUE
- )
- }
- group_filters
-})
-
-##----------------------------------------------------------------------------##
-## Info box that gets shown when pressing the "info" button.
-##----------------------------------------------------------------------------##
-
-observeEvent(input[["overview_projection_group_filters_info"]], {
- showModal(
- modalDialog(
- overview_projection_group_filters_info[["text"]],
- title = overview_projection_group_filters_info[["title"]],
- easyClose = TRUE,
- footer = NULL,
- size = "l"
- )
- )
-})
-
-##----------------------------------------------------------------------------##
-## Text in info box.
-##----------------------------------------------------------------------------##
-
-overview_projection_group_filters_info <- list(
- title = "Group filters for projection",
- text = HTML("
- The elements in this panel allow you to select which cells should be plotted based on the group(s) they belong to. For each grouping variable, you can activate or deactivate group levels. Only cells that are pass all filters (for each grouping variable) are shown in the projection.
- "
- )
-)
-
-## make sure elements are loaded even though the box is collapsed
-outputOptions(
- output,
- "overview_projection_group_filters_UI",
- suspendWhenHidden = FALSE
-)
-
-##----------------------------------------------------------------------------##
-## UI elements to select X and Y limits in projection.
-##----------------------------------------------------------------------------##
-
-output[["overview_projection_scales_UI"]] <- renderUI({
- projection_to_display <- if (
- is.null(input[["overview_projection_to_display"]]) ||
- is.na(input[["overview_projection_to_display"]])
- ) {
- availableProjections()[1]
- } else {
- input[["overview_projection_to_display"]]
- }
-
- XYranges <- getXYranges(getProjection(projection_to_display))
-
- tagList(
- sliderInput(
- "overview_scale_x_manual_range",
- label = "Range of X axis",
- min = XYranges$x$min,
- max = XYranges$x$max,
- value = c(XYranges$x$min, XYranges$x$max)
- ),
- sliderInput(
- "overview_scale_y_manual_range",
- label = "Range of Y axis",
- min = XYranges$y$min,
- max = XYranges$y$max,
- value = c(XYranges$y$min, XYranges$y$max)
- )
- )
-})
-
-## make sure elements are loaded even though the box is collapsed
-outputOptions(
- output,
- "overview_projection_scales_UI",
- suspendWhenHidden = FALSE
-)
-
-##----------------------------------------------------------------------------##
-## Plotly plot of the selected projection.
-##----------------------------------------------------------------------------##
-
-output[["overview_projection"]] <- plotly::renderPlotly({
-
- ## don't proceed without these inputs
- req(
- input[["overview_projection_to_display"]],
- input[["overview_percentage_cells_to_show"]],
- input[["overview_point_color"]],
- input[["overview_point_size"]],
- input[["overview_point_opacity"]],
- input[["overview_scale_x_manual_range"]],
- input[["overview_scale_y_manual_range"]]
- )
-
- projection_to_display <- input[["overview_projection_to_display"]]
-
- ## build data frame with data
- cells_df <- cbind(getProjection(projection_to_display), getMetaData())
-
- ## available group filters
- group_filters <- names(input)[grepl(names(input), pattern = 'overview_projection_group_filter_')]
-
- ## remove cells based on group filters
- for ( i in group_filters ) {
- group <- strsplit(i, split = 'overview_projection_group_filter_')[[1]][2]
- if ( group %in% colnames(cells_df) ) {
- cells_df <- cells_df[which(cells_df[[group]] %in% input[[i]] ),]
- }
- }
-
- ## randomly remove cells (if necessary)
- cells_df <- randomlySubsetCells(cells_df, input[["overview_percentage_cells_to_show"]])
-
- ## put rows in random order
- cells_df <- cells_df[ sample(1:nrow(cells_df)) , ]
-
- ## get colors for groups
- colors_for_groups <- assignColorsToGroups(cells_df, input[["overview_point_color"]])
-
- ## prepare hover info
- hover_info <- buildHoverInfoForProjections(cells_df)
-
- ## check if projection consists of 3 or 2 dimensions
- ## ... selected projection contains 3 dimensions
- if ( ncol(getProjection(projection_to_display)) == 3 ) {
-
- ## check if selected coloring variable is categorical or numeric
- ## ... selected coloring variable is numeric
- if ( is.numeric(cells_df[[ input[["overview_point_color"]] ]]) ) {
- plot <- plotly::plot_ly(
- cells_df,
- x = ~cells_df[,1],
- y = ~cells_df[,2],
- z = ~cells_df[,3],
- type = "scatter3d",
- mode = "markers",
- marker = list(
- colorbar = list(
- title = input[["overview_point_color"]]
- ),
- color = ~cells_df[[ input[["overview_point_color"]] ]],
- opacity = input[["overview_point_opacity"]],
- colorscale = "YlGnBu",
- reversescale = TRUE,
- line = list(
- color = "rgb(196,196,196)",
- width = 1
- ),
- size = input[["overview_point_size"]]
- ),
- hoverinfo = "text",
- text = ~hover_info,
- source = "overview_projection"
- )
-
- ## ... selected coloring variable is not numeric
- } else {
- plot <- plotly::plot_ly(
- cells_df,
- x = ~cells_df[,1],
- y = ~cells_df[,2],
- z = ~cells_df[,3],
- color = ~cells_df[[ input[["overview_point_color"]] ]],
- colors = colors_for_groups,
- type = "scatter3d",
- mode = "markers",
- marker = list(
- opacity = input[["overview_point_opacity"]],
- line = list(
- color = "rgb(196,196,196)",
- width = 1
- ),
- size = input[["overview_point_size"]]
- ),
- hoverinfo = "text",
- text = ~hover_info,
- source = "overview_projection"
- )
- }
-
- ## add layout to plot
- plot <- plot %>%
- plotly::layout(
- scene = list(
- xaxis = list(
- title = colnames(cells_df)[1],
- mirror = TRUE,
- showline = TRUE,
- zeroline = FALSE
- ),
- yaxis = list(
- title = colnames(cells_df)[2],
- mirror = TRUE,
- showline = TRUE,
- zeroline = FALSE
- ),
- zaxis = list(
- title = colnames(cells_df)[3],
- mirror = TRUE,
- showline = TRUE,
- zeroline = FALSE
- )
- ),
- hoverlabel = list(
- font = list(
- size = 11
- )
- )
- )
-
- ## ... selection projection consists of 2 dimensions
- } else if ( ncol(getProjection(projection_to_display)) == 2 ) {
-
- ## check if selected coloring variable is categorical or numeric
- ## ... selected coloring variable is numeric
- if ( is.numeric(cells_df[[ input[["overview_point_color"]] ]]) ) {
- plot <- plotly::plot_ly(
- cells_df,
- x = ~cells_df[,1],
- y = ~cells_df[,2],
- type = "scatter",
- mode = "markers",
- marker = list(
- colorbar = list(
- title = input[["overview_point_color"]]
- ),
- color = ~cells_df[[ input[["overview_point_color"]] ]],
- opacity = input[["overview_point_opacity"]],
- colorscale = "YlGnBu",
- reversescale = TRUE,
- line = list(
- color = "rgb(196,196,196)",
- width = 1
- ),
- size = input[["overview_point_size"]]
- ),
- hoverinfo = "text",
- text = ~hover_info,
- source = "overview_projection"
- )
-
- ## ... selected coloring variable is not numeric
- } else {
- plot <- plotly::plot_ly(
- cells_df,
- x = ~cells_df[,1],
- y = ~cells_df[,2],
- color = ~cells_df[[ input[["overview_point_color"]] ]],
- colors = colors_for_groups,
- type = "scatter",
- mode = "markers",
- marker = list(
- opacity = input[["overview_point_opacity"]],
- line = list(
- color = "rgb(196,196,196)",
- width = 1
- ),
- size = input[["overview_point_size"]]
- ),
- hoverinfo = "text",
- text = ~hover_info,
- source = "overview_projection"
- )
- }
-
- ## add layout to plot
- plot <- plot %>%
- plotly::layout(
- xaxis = list(
- title = colnames(cells_df)[1],
- mirror = TRUE,
- showline = TRUE,
- zeroline = FALSE,
- range = input[["overview_scale_x_manual_range"]]
- ),
- yaxis = list(
- title = colnames(cells_df)[2],
- mirror = TRUE,
- showline = TRUE,
- zeroline = FALSE,
- range = input[["overview_scale_y_manual_range"]]
- ),
- hoverlabel = list(font = list(size = 11))
- )
-
- ## return plot either with WebGL or without, depending on setting
- if ( preferences[["use_webgl"]] == TRUE ) {
- plot %>% plotly::toWebGL()
- } else {
- plot
- }
- }
-})
-
-##----------------------------------------------------------------------------##
-## Text showing the number of selected cells.
-##----------------------------------------------------------------------------##
-
-output[["overview_number_of_selected_cells"]] <- renderText({
-
- ## don't proceed without these inputs
- req(
- input[["overview_projection_to_display"]]
- )
-
- ## check selection
- ## ... selection has not been made or there is not cell in it
- if (
- is.null(plotly::event_data("plotly_selected", source = "overview_projection")) ||
- length(plotly::event_data("plotly_selected", source = "overview_projection")) == 0
- ) {
-
- ## manually set counter to 0
- number_of_selected_cells <- 0
-
- ## ... selection has been made and at least 1 cell is in it
- } else {
-
- ## get number of selected cells
- number_of_selected_cells <- formatC(nrow(plotly::event_data("plotly_selected", source = "overview_projection")), format = "f", big.mark = ",", digits = 0)
- }
-
- ## prepare string to show
- paste0("Number of selected cells: ", number_of_selected_cells)
-})
-
-##----------------------------------------------------------------------------##
-## Info box that gets shown when pressing the "info" button.
-##----------------------------------------------------------------------------##
-
-observeEvent(input[["overview_projection_info"]], {
- showModal(
- modalDialog(
- overview_projection_info[["text"]],
- title = overview_projection_info[["title"]],
- easyClose = TRUE,
- footer = NULL,
- size = "l"
- )
- )
-})
-
-##----------------------------------------------------------------------------##
-## Text in info box.
-##----------------------------------------------------------------------------##
-
-overview_projection_info <- list(
- title = "Dimensional reduction",
- text = HTML("
- Interactive projection of cells into 2-dimensional space based on their expression profile.
-
- - Both tSNE and UMAP are frequently used algorithms for dimensional reduction in single cell transcriptomics. While they generally allow to make similar conclusions, some differences exist between the two (please refer to Google and/or literature, such as Becht E. et al., Dimensionality reduction for visualizing single-cell data using UMAP. Nature Biotechnology, 2018, 37, 38-44).
- - Cells can be colored by the sample they came from, the cluster they were assigned, the number of transcripts or expressed genes, percentage of mitochondrial and ribosomal gene expression, an apoptotic score (calculated based on the expression of few marker genes; more info in the 'Sample info' tab on the left), or cell cycle status (determined using the Seurat and Cyclone method).
- - Confidence ellipses show the 95% confidence regions.
- - Samples and clusters can be removed from the plot individually to highlight a contrast of interest.
- - By default, the point size is set to 15 without any transparency but both these attributes can be changed using the sliders on the left. The point size can also be set to reflect the number of transcripts or expressed genes.
- - The last two slider elements on the left can be used to resize the projection axes. This can be particularly useful when a projection contains a population of cell that is very far away from the rest and therefore creates a big empty space (which is not uncommon for UMAPs)
-
- The plot is interactive (drag and zoom) but depending on the computer of the user and the number of cells displayed it can become very slow."
- )
-)
-
-##----------------------------------------------------------------------------##
-## Export projection plot to PDF when pressing the "export to PDF" button.
-##----------------------------------------------------------------------------##
-
-observeEvent(input[["overview_projection_export"]], {
-
- ## don't proceed without these inputs
- req(
- input[["overview_projection_to_display"]],
- input[["overview_percentage_cells_to_show"]],
- input[["overview_point_color"]],
- input[["overview_point_size"]],
- input[["overview_point_opacity"]],
- input[["overview_scale_x_manual_range"]],
- input[["overview_scale_y_manual_range"]]
- )
-
- ## open dialog to select where plot should be saved and how the file should
- ## be named
- shinyFiles::shinyFileSave(
- input,
- id = "overview_projection_export",
- roots = available_storage_volumes,
- session = session,
- restrictions = system.file(package = "base")
- )
-
- ## retrieve info from dialog
- save_file_input <- shinyFiles::parseSavePath(available_storage_volumes, input[["overview_projection_export"]])
-
- ## only proceed if a path has been provided
- if ( nrow(save_file_input) > 0 ) {
-
- ## extract specified file path
- save_file_path <- as.character(save_file_input$datapath[1])
-
- ## ggplot2 functions are necessary to create the plot
- require("ggplot2")
-
- ## get selected projection
- projection_to_display <- input[["overview_projection_to_display"]]
-
- ## merge cell positions in projection and meta data
- cells_df <- cbind(getProjection(projection_to_display), getMetaData())
-
- ## randomly remove cells (if necessary)
- cells_df <- randomlySubsetCells(cells_df, input[["overview_percentage_cells_to_show"]])
-
- ## put rows in random order
- cells_df <- cells_df[ sample(1:nrow(cells_df)) , ]
-
- ## get X and Y scale limits
- xlim <- c(
- input[["overview_scale_x_manual_range"]][1],
- input[["overview_scale_x_manual_range"]][2]
- )
- ylim <- c(
- input[["overview_scale_y_manual_range"]][1],
- input[["overview_scale_y_manual_range"]][2]
- )
-
- ## check if selection projection consists of 2 or 3 dimensions
- ## ... selection projection consists of 3 dimensions
- if ( ncol(getProjection(projection_to_display)) == 3 ) {
-
- ## give error message
- shinyWidgets::sendSweetAlert(
- session = session,
- title = "Sorry!",
- text = "It's currently not possible to create PDF plots from 3D dimensional reductions. Please use the PNG export button in the panel or a 2D dimensional reduction instead.",
- type = "error"
- )
-
- ## ... selection projection consists of 2 dimensions
- } else if ( ncol(getProjection(projection_to_display)) == 2 ) {
-
- ## start building the plot
- plot <- ggplot(
- cells_df,
- aes_q(
- x = as.name(colnames(cells_df)[1]),
- y = as.name(colnames(cells_df)[2]),
- fill = as.name(input[["overview_point_color"]])
- )
- ) +
- geom_point(
- shape = 21,
- size = input[["overview_point_size"]]/3,
- stroke = 0.2,
- color = "#c4c4c4",
- alpha = input[["overview_point_opacity"]]
- ) +
- lims(x = xlim, y = ylim) +
- theme_bw()
-
- ## depending on type of cell coloring, add different color scale
- ## ... categorical
- if (
- is.factor(cells_df[[ input[["overview_point_color"]] ]]) ||
- is.character(cells_df[[ input[["overview_point_color"]] ]])
- ) {
-
- ## get colors for groups
- colors_for_groups <- assignColorsToGroups(cells_df, input[["overview_point_color"]])
-
- ## add color assignments
- plot <- plot + scale_fill_manual(values = colors_for_groups)
-
- ## ... not categorical (probably numerical)
- } else {
-
- ## add continuous color scale
- plot <- plot +
- scale_fill_distiller(
- palette = "YlGnBu",
- direction = 1,
- guide = guide_colorbar(frame.colour = "black", ticks.colour = "black")
- )
- }
-
- ## save plot
- pdf(NULL)
- ggsave(save_file_path, plot, height = 8, width = 11)
-
- ## check if file was succesfully saved
- ## ... successful
- if ( file.exists(save_file_path) ) {
-
- ## give positive message
- shinyWidgets::sendSweetAlert(
- session = session,
- title = "Success!",
- text = paste0("Plot saved successfully as: ", save_file_path),
- type = "success"
- )
-
- ## ... failed
- } else {
-
- ## give negative message
- shinyWidgets::sendSweetAlert(
- session = session,
- title = "Error!",
- text = "Sorry, it seems something went wrong...",
- type = "error"
- )
- }
- }
- }
-})
diff --git a/inst/shiny/v1.3/overview/server.R b/inst/shiny/v1.3/overview/server.R
index b0ab8fa..5ecf7c4 100644
--- a/inst/shiny/v1.3/overview/server.R
+++ b/inst/shiny/v1.3/overview/server.R
@@ -1,7 +1,12 @@
##----------------------------------------------------------------------------##
## Tab: Overview
##----------------------------------------------------------------------------##
+files_to_load <- list.files(
+ paste0(Cerebro.options[["cerebro_root"]], "/shiny/v1.3/overview"),
+ pattern = "func_|obj_|UI_|out_|event_",
+ full.names = TRUE
+)
-source(paste0(Cerebro.options[["cerebro_root"]], "/shiny/v1.3/overview/projection.R"), local = TRUE)
-source(paste0(Cerebro.options[["cerebro_root"]], "/shiny/v1.3/overview/selected_cells_plot.R"), local = TRUE)
-source(paste0(Cerebro.options[["cerebro_root"]], "/shiny/v1.3/overview/selected_cells_table.R"), local = TRUE)
+for ( i in files_to_load ) {
+ source(i, local = TRUE)
+}
diff --git a/inst/shiny/v1.3/plotting_functions.R b/inst/shiny/v1.3/plotting_functions.R
index 77f5611..feb6383 100644
--- a/inst/shiny/v1.3/plotting_functions.R
+++ b/inst/shiny/v1.3/plotting_functions.R
@@ -9,7 +9,6 @@ plotlyViolin <- function(
y_title,
mode
) {
-
if ( mode == "percent" ) {
y_range <- c(0,1)
y_tickformat <- ",.0%"
@@ -19,7 +18,6 @@ plotlyViolin <- function(
y_tickformat <- ",.0f"
y_hoverformat <- ",.0f"
}
-
##
plot <- table %>%
plotly::plot_ly(
@@ -74,36 +72,28 @@ plotlyBarChart <- function(
colors,
percent
) {
-
## TODO: safety checks?
-
##
if ( percent == FALSE ) {
-
y_title <- "Number of cells"
y_range <- NULL
y_tickformat <- ",.0f"
y_hoverformat <- ",.0f"
-
hover_info <- glue::glue(
"{table[[ second_grouping_variable ]]}: ",
"{formatC(table[['count']], big.mark = ',')}"
)
-
##
} else if ( percent == TRUE ) {
-
y_title <- "Percent of cells"
y_range <- c(0,1)
y_tickformat <- ",.0%"
y_hoverformat <- ".1%"
-
hover_info <- glue::glue(
"{table[[ second_grouping_variable ]]}: ",
"{format(round(table[['count']]*100, 1), nsmall = 1)}%"
)
}
-
## generate plot
plot <- table %>%
plotly::plot_ly(
@@ -147,17 +137,13 @@ plotlySankeyPlot <- function(
second_grouping_variable,
colors_for_groups
) {
-
## transform factor levels to integers (necessary for plotly)
table[["source"]] <- as.numeric(table[[1]]) - 1
table[["target"]] <- as.numeric(table[[2]]) - 1 + length(unique(table[[1]]))
-
## combine all factor levels in a single vector
all_groups <- c(levels(table[[1]]), levels(table[[2]]))
-
## match color codes to group levels (from both groups)
colors_for_groups_all <- colors_for_groups[names(colors_for_groups) %in% all_groups]
-
## prepare plot
plot <- plotly::plot_ly(
type = "sankey",
@@ -193,23 +179,6 @@ plotlySankeyPlot <- function(
)
)
)
-
##
return(plot)
}
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/inst/shiny/v1.3/shiny_server.R b/inst/shiny/v1.3/shiny_server.R
index 9315e94..c184427 100644
--- a/inst/shiny/v1.3/shiny_server.R
+++ b/inst/shiny/v1.3/shiny_server.R
@@ -13,29 +13,47 @@ server <- function(input, output, session) {
##--------------------------------------------------------------------------##
## Central parameters.
##--------------------------------------------------------------------------##
- scatter_plot_point_size <- list(
- min = 1,
- max = 20,
- step = 1,
- default = 5
- )
-
- scatter_plot_point_opacity <- list(
- min = 0.1,
- max = 1.0,
- step = 0.1,
- default = 1.0
- )
-
- scatter_plot_percentage_cells_to_show <- list(
- min = 10,
- max = 100,
- step = 10,
- default = 100
- )
-
preferences <- reactiveValues(
- use_webgl = TRUE
+ scatter_plot_point_size = list(
+ min = 1,
+ max = 20,
+ step = 1,
+ default = ifelse(
+ exists('Cerebro.options') &&
+ !is.null(Cerebro.options[['projections_default_point_size']]),
+ Cerebro.options[['projections_default_point_size']],
+ 2
+ )
+ ),
+ scatter_plot_point_opacity = list(
+ min = 0.1,
+ max = 1.0,
+ step = 0.1,
+ default = ifelse(
+ exists('Cerebro.options') &&
+ !is.null(Cerebro.options[['projections_default_point_opacity']]),
+ Cerebro.options[['projections_default_point_opacity']],
+ 1.0
+ )
+ ),
+ scatter_plot_percentage_cells_to_show = list(
+ min = 10,
+ max = 100,
+ step = 10,
+ default = ifelse(
+ exists('Cerebro.options') &&
+ !is.null(Cerebro.options[['projections_default_percentage_cells_to_show']]),
+ Cerebro.options[['projections_default_percentage_cells_to_show']],
+ 100
+ )
+ ),
+ use_webgl = TRUE,
+ show_hover_info_in_projections = ifelse(
+ exists('Cerebro.options') &&
+ !is.null(Cerebro.options[['projections_show_hover_info']]),
+ Cerebro.options[['projections_show_hover_info']],
+ TRUE
+ )
)
## paths for storing plots
@@ -53,77 +71,119 @@ server <- function(input, output, session) {
## listen to selected 'input_file', initialize before UI element is loaded
observeEvent(input[['input_file']], ignoreNULL = FALSE, {
-
+ path_to_load <- ''
## grab path from 'input_file' if one is specified
if (
!is.null(input[["input_file"]]) &&
!is.na(input[["input_file"]]) &&
file.exists(input[["input_file"]]$datapath)
) {
- new_path <- input[["input_file"]]$datapath
-
- ## take path from 'Cerebro.options' if it is set
+ path_to_load <- input[["input_file"]]$datapath
+ ## take path or object from 'Cerebro.options' if it is set and points to an
+ ## existing file or object
} else if (
exists('Cerebro.options') &&
- !is.null(Cerebro.options[["crb_file_to_load"]]) &&
- file.exists(Cerebro.options[["crb_file_to_load"]])
+ !is.null(Cerebro.options[["crb_file_to_load"]])
) {
- new_path <- .GlobalEnv$Cerebro.options$crb_file_to_load
-
- ## if none of the above apply, get path of example data set
- } else {
- new_path <- system.file("extdata/v1.3/example.crb", package = "cerebroApp")
+ file_to_load <- Cerebro.options[["crb_file_to_load"]]
+ if (file.exists(file_to_load) || exists(file_to_load)) {
+ path_to_load <- .GlobalEnv$Cerebro.options$crb_file_to_load
+ }
+ }
+ ## assign path to example file if none of the above apply
+ if (path_to_load=='') {
+ path_to_load <- system.file("extdata/v1.3/example.crb", package = "cerebroApp")
}
-
## set reactive value to new file path
- data_to_load$path <- new_path
+ data_to_load$path <- path_to_load
})
## create reactive value holding the current data set
data_set <- reactive({
-
- ## log message
- print(glue::glue("[{Sys.time()}] File to load: {data_to_load$path}"))
-
- ## read the file
- data <- readRDS(data_to_load$path)
-
+ dataset_to_load <- data_to_load$path
+ if (exists(dataset_to_load)) {
+ print(glue::glue("[{Sys.time()}] Load from variable: {dataset_to_load}"))
+ data <- get(dataset_to_load)
+ } else {
+ ## log message
+ print(glue::glue("[{Sys.time()}] File to load: {dataset_to_load}"))
+ ## read the file
+ data <- readRDS(dataset_to_load)
+ }
## log message
message(data$print())
-
## check if 'expression' slot exists and print log message with its format
## if it does
if ( !is.null(data$expression) ) {
print(glue::glue("[{Sys.time()}] Format of expression data: {class(data$expression)}"))
}
-
## return loaded data
return(data)
})
+ # list of available trajectories
+ available_trajectories <- reactive({
+ req(!is.null(data_set()))
+ ## collect available trajectories across all methods and create selectable
+ ## options
+ available_trajectories <- c()
+ available_trajectory_method <- getMethodsForTrajectories()
+ ## check if at least 1 trajectory method exists
+ if ( length(available_trajectory_method) > 0 ) {
+ ## cycle through trajectory methods
+ for ( i in seq_along(available_trajectory_method) ) {
+ ## get current method and names of trajectories for this method
+ current_method <- available_trajectory_method[i]
+ available_trajectories_for_this_method <- getNamesOfTrajectories(current_method)
+ ## check if at least 1 trajectory is available for this method
+ if ( length(available_trajectories_for_this_method) > 0 ) {
+ ## cycle through trajectories for this method
+ for ( j in seq_along(available_trajectories_for_this_method) ) {
+ ## create selectable combination of method and trajectory name and add
+ ## it to the available trajectories
+ current_trajectory <- available_trajectories_for_this_method[j]
+ available_trajectories <- c(
+ available_trajectories,
+ glue::glue("{current_method} // {current_trajectory}")
+ )
+ }
+ }
+ }
+ }
+ # message(str(available_trajectories))
+ return(available_trajectories)
+ })
+
+ # hover info for projection
+ hover_info_projections <- reactive({
+ # message('--> trigger "hover_info_projections"')
+ if (
+ !is.null(preferences[["show_hover_info_in_projections"]]) &&
+ preferences[['show_hover_info_in_projections']] == TRUE
+ ) {
+ cells_df <- getMetaData()
+ hover_info <- buildHoverInfoForProjections(cells_df)
+ hover_info <- setNames(hover_info, cells_df$cell_barcode)
+ } else {
+ hover_info <- 'none'
+ }
+ # message(str(hover_info))
+ return(hover_info)
+ })
+
##--------------------------------------------------------------------------##
## Show "Trajectory" tab if there are trajectories in the data set.
##--------------------------------------------------------------------------##
## the tab item needs to be in the `output`
output[["sidebar_item_trajectory"]] <- renderMenu({
-
- ## require a data set to be loaded
- req(
- !is.null(data_set())
- )
-
+ req(!is.null(data_set()))
menuItem("Trajectory", tabName = "trajectory", icon = icon("random"))
})
## this reactive value checks whether the tab should be shown or not
show_trajectory_tab <- reactive({
-
- ## require a data set to be loaded
- req(
- !is.null(data_set())
- )
-
+ req(!is.null(data_set()))
## if at least one trajectory is present, return TRUE, otherwise FALSE
if (
!is.null(getMethodsForTrajectories()) &&
@@ -150,23 +210,15 @@ server <- function(input, output, session) {
## the tab item needs to be in the `output`
output[["sidebar_item_extra_material"]] <- renderMenu({
-
## require a data set to be loaded
- req(
- !is.null(data_set())
- )
-
+ req(!is.null(data_set()))
menuItem("Extra material", tabName = "extra_material", icon = icon("gift"))
})
## this reactive value checks whether the tab should be shown or not
show_extra_material_tab <- reactive({
-
## require a data set to be loaded
- req(
- !is.null(data_set())
- )
-
+ req(!is.null(data_set()))
## if at least one piece of extra material is present, return TRUE,
## otherwise FALSE
if (
@@ -178,7 +230,6 @@ server <- function(input, output, session) {
return(FALSE)
}
})
-
## listen to reactive value defined above and toggle visibility of extra
## material tab accordingly
observe({
diff --git a/inst/shiny/v1.3/trajectory/projection.R b/inst/shiny/v1.3/trajectory/projection.R
index 9ffdf47..0f0c08f 100644
--- a/inst/shiny/v1.3/trajectory/projection.R
+++ b/inst/shiny/v1.3/trajectory/projection.R
@@ -159,26 +159,26 @@ output[["trajectory_projection_additional_parameters_UI"]] <- renderUI({
sliderInput(
"trajectory_point_size",
label = "Point size",
- min = scatter_plot_point_size[["min"]],
- max = scatter_plot_point_size[["max"]],
- step = scatter_plot_point_size[["step"]],
- value = scatter_plot_point_size[["default"]]
+ min = preferences[["scatter_plot_point_size"]][["min"]],
+ max = preferences[["scatter_plot_point_size"]][["max"]],
+ step = preferences[["scatter_plot_point_size"]][["step"]],
+ value = preferences[["scatter_plot_point_size"]][["default"]]
),
sliderInput(
"trajectory_point_opacity",
label = "Point opacity",
- min = scatter_plot_point_opacity[["min"]],
- max = scatter_plot_point_opacity[["max"]],
- step = scatter_plot_point_opacity[["step"]],
- value = scatter_plot_point_opacity[["default"]]
+ min = preferences[["scatter_plot_point_opacity"]][["min"]],
+ max = preferences[["scatter_plot_point_opacity"]][["max"]],
+ step = preferences[["scatter_plot_point_opacity"]][["step"]],
+ value = preferences[["scatter_plot_point_opacity"]][["default"]]
),
sliderInput(
"trajectory_percentage_cells_to_show",
label = "Show % of cells",
- min = scatter_plot_percentage_cells_to_show[["min"]],
- max = scatter_plot_percentage_cells_to_show[["max"]],
- step = scatter_plot_percentage_cells_to_show[["step"]],
- value = scatter_plot_percentage_cells_to_show[["default"]]
+ min = preferences[["scatter_plot_percentage_cells_to_show"]][["min"]],
+ max = preferences[["scatter_plot_percentage_cells_to_show"]][["max"]],
+ step = preferences[["scatter_plot_percentage_cells_to_show"]][["step"]],
+ value = preferences[["scatter_plot_percentage_cells_to_show"]][["default"]]
)
)
})
@@ -483,7 +483,7 @@ output[["trajectory_number_of_selected_cells"]] <- renderText({
)
## check selection
- ## ... selection has not been made or there is not cell in it
+ ## ... selection has not been made or there is no cell in it
if (
is.null(plotly::event_data("plotly_selected", source = "trajectory_projection")) ||
length(plotly::event_data("plotly_selected", source = "trajectory_projection")) == 0
diff --git a/inst/shiny/v1.3/trajectory/selected_cells_table.R b/inst/shiny/v1.3/trajectory/selected_cells_table.R
index 1cb3178..de802b0 100644
--- a/inst/shiny/v1.3/trajectory/selected_cells_table.R
+++ b/inst/shiny/v1.3/trajectory/selected_cells_table.R
@@ -46,7 +46,7 @@ output[["trajectory_selected_cells_table_UI"]] <- renderUI({
## Table.
##----------------------------------------------------------------------------##
-output[["trajectory_details_selected_cells_table"]] <- DT::renderDataTable(server = FALSE, {
+output[["trajectory_details_selected_cells_table"]] <- DT::renderDataTable({
## don't do anything before these inputs are selected
req(
@@ -65,7 +65,7 @@ output[["trajectory_details_selected_cells_table"]] <- DT::renderDataTable(serve
)
## check selection
- ## ... selection has not been made or there is not cell in it
+ ## ... selection has not been made or there is no cell in it
if (
is.null(plotly::event_data("plotly_selected", source = "trajectory_projection")) ||
length(plotly::event_data("plotly_selected", source = "trajectory_projection")) == 0
diff --git a/inst/shiny/v1.3/utility_functions.R b/inst/shiny/v1.3/utility_functions.R
index 5f372c5..9da0a1d 100644
--- a/inst/shiny/v1.3/utility_functions.R
+++ b/inst/shiny/v1.3/utility_functions.R
@@ -23,7 +23,7 @@ findColumnsPercentage <- function(df) {
any(is.na(df[[i]])) == FALSE &&
is.numeric(df[[i]]) &&
min(df[[i]], na.rm = TRUE) >= 0 &&
- max(df[[i]], na.rm = TRUE)
+ max(df[[i]], na.rm = TRUE) <= 100
) {
columns_indices <- c(columns_indices, i)
}
@@ -40,7 +40,7 @@ findColumnsPValues <- function(df) {
any(is.na(df[[i]])) == FALSE &&
is.numeric(df[[i]]) &&
min(df[[i]], na.rm = TRUE) >= 0 &&
- max(df[[i]], na.rm = TRUE)
+ max(df[[i]], na.rm = TRUE) <= 1
) {
columns_indices <- c(columns_indices, i)
}
@@ -127,6 +127,17 @@ prettifyTable <- function(
columns_percent <- c(columns_percent, columns_percentage)
}
+ ## check whether percentage values were given on a 0-100 scale and convert
+ ## them to 0-1 if so
+ if (number_formatting == TRUE && length(columns_percent) > 0) {
+ for (col in columns_percent) {
+ col_name <- colnames(table)[col]
+ if (max(table[,col_name] > 1)) {
+ table[,col] <- table[,col] / 100
+ }
+ }
+ }
+
## add manually specified columns to hide
if ( is.null(columns_hide) == FALSE ) {
columns_hide <- columns_hide - 1
@@ -217,6 +228,15 @@ prettifyTable <- function(
textAlign = 'right'
)
+ # show cellular barcodes in monospace font
+ if ('cell_barcode' %in% colnames(table_original)) {
+ table <- table %>%
+ DT::formatStyle(
+ columns = which(colnames(table_original)=='cell_barcode'),
+ target="cell", fontFamily="courier"
+ )
+ }
+
## if automatic number formatting is on...
## - remove decimals from integers
## - show 3 significant decimals for p-values
@@ -641,38 +661,19 @@ assignColorsToGroups <- function(table, grouping_variable) {
## Build hover info for projections.
##----------------------------------------------------------------------------##
buildHoverInfoForProjections <- function(table) {
-
- # ## put together cell ID, number of transcripts and number of expressed genes
- # hover_info <- glue::glue(
- # "Cell: {table[[ 'cell_barcode' ]]}
- # Transcripts: {formatC(table[[ 'nUMI' ]], format = 'f', big.mark = ',', digits = 0)}
- # Expressed genes: {formatC(table[[ 'nGene' ]], format = 'f', big.mark = ',', digits = 0)}"
- # )
-
- # ## add info for known grouping variables
- # for ( group in getGroups() ) {
- # hover_info <- glue::glue(
- # "{hover_info}
- # {group}: {table[[ group ]]}"
- # )
- # }
-
## put together cell ID, number of transcripts and number of expressed genes
hover_info <- glue::glue(
- "Cell: {table[[ 'cell_barcode' ]]}
- Transcripts: {table[[ 'nUMI' ]]}
- Expressed genes: {table[[ 'nGene' ]]}"
+ "Cell: {table[[ 'cell_barcode' ]]}
",
+ "Transcripts: {formatC(table[[ 'nUMI' ]], format = 'f', big.mark = ',', digits = 0)}
",
+ "Expressed genes: {formatC(table[[ 'nGene' ]], format = 'f', big.mark = ',', digits = 0)}"
)
-
## add info for known grouping variables
for ( group in getGroups() ) {
hover_info <- glue::glue(
- "{hover_info}
- {group}: {table[[ group ]]}"
+ "{hover_info}
",
+ "{group}: {table[[ group ]]}"
)
}
-
- ##
return(hover_info)
}
@@ -680,26 +681,19 @@ buildHoverInfoForProjections <- function(table) {
## Randomly subset cells in data frame, if necessary.
##----------------------------------------------------------------------------##
randomlySubsetCells <- function(table, percentage) {
-
## check if subsetting is necessary
## ... percentage is less than 100
if ( percentage < 100 ) {
-
## calculate how many cells should be left after subsetting
size_of_subset <- ceiling(percentage / 100 * nrow(table))
-
## get IDs of all cells
cell_ids <- rownames(table)
-
## subset cell IDs
subset_of_cell_ids <- cell_ids[ sample(seq_along(cell_ids), size_of_subset) ]
-
## subset table and return
return(table[subset_of_cell_ids,])
-
## ... percentage is 100 -> no subsetting needed
} else {
-
## return original table
return(table)
}
@@ -711,15 +705,14 @@ randomlySubsetCells <- function(table, percentage) {
getXYranges <- function(table) {
ranges <- list(
x = list(
- min = table[,1] %>% min() %>% "*"(ifelse(.<0, 1.1, 0.9)) %>% round(),
- max = table[,1] %>% max() %>% "*"(ifelse(.<0, 0.9, 1.1)) %>% round()
+ min = table[,1] %>% min(na.rm=TRUE) %>% "*"(ifelse(.<0, 1.1, 0.9)) %>% round(),
+ max = table[,1] %>% max(na.rm=TRUE) %>% "*"(ifelse(.<0, 0.9, 1.1)) %>% round()
),
y = list(
- min = table[,2] %>% min() %>% "*"(ifelse(.<0, 1.1, 0.9)) %>% round(),
- max = table[,2] %>% max() %>% "*"(ifelse(.<0, 0.9, 1.1)) %>% round()
+ min = table[,2] %>% min(na.rm=TRUE) %>% "*"(ifelse(.<0, 1.1, 0.9)) %>% round(),
+ max = table[,2] %>% max(na.rm=TRUE) %>% "*"(ifelse(.<0, 0.9, 1.1)) %>% round()
)
)
-
return(ranges)
}
@@ -768,6 +761,61 @@ getGenesForGeneSet <- function(gene_set) {
sort()
}
+##----------------------------------------------------------------------------##
+## Function to calculate center of groups in projections/trajectories.
+##----------------------------------------------------------------------------##
+centerOfGroups <- function(coordinates, df, n_dimensions, group) {
+ ## check number of dimenions in projection
+ ## ... 2 dimensions
+ if ( n_dimensions == 2 ) {
+ ## calculate center for groups and return
+ tidyr::tibble(
+ x = coordinates[[1]],
+ y = coordinates[[2]],
+ group = df[[ group ]]
+ ) %>%
+ dplyr::group_by(group) %>%
+ dplyr::summarise(
+ x_median = median(x),
+ y_median = median(y),
+ .groups = 'drop_last'
+ ) %>%
+ dplyr::ungroup() %>%
+ return()
+ ## ... 3 dimensions
+ } else if ( n_dimensions == 3 && is.numeric(coordinates[,3]) ) {
+ ## calculate center for groups and return
+ tidyr::tibble(
+ x = coordinates[[1]],
+ y = coordinates[[2]],
+ z = coordinates[[3]],
+ group = df[[ group ]]
+ ) %>%
+ dplyr::group_by(group) %>%
+ dplyr::summarise(
+ x_median = median(x),
+ y_median = median(y),
+ z_median = median(z),
+ .groups = 'drop_last'
+ ) %>%
+ dplyr::ungroup() %>%
+ return()
+ }
+}
+
+##----------------------------------------------------------------------------##
+## Set order of rows in data frame.
+##----------------------------------------------------------------------------##
+setRowOrder <- function(df, order) {
+ if ( order == 'Random' ) {
+ return(df[ sample(1:nrow(df)) , ])
+ } else if ( order == "Highest expression on top" ) {
+ return(dplyr::arrange(df, level))
+ } else {
+ return(df)
+ }
+}
+
##----------------------------------------------------------------------------##
## Functions to interact with data set.
##
@@ -910,7 +958,7 @@ getTrajectory <- function(method, name) {
}
getExtraMaterialCategories <- function() {
if ( 'Cerebro_v1.3' %in% class(data_set()) ) {
- return(data_set()$getExtraMaterialCategories())
+ return(data_set()$getExtraMaterialCategories())
}
}
checkForExtraTables <- function() {
diff --git a/man/dot-send_enrichr_query.Rd b/man/dot-send_enrichr_query.Rd
index dc429b9..c01229c 100644
--- a/man/dot-send_enrichr_query.Rd
+++ b/man/dot-send_enrichr_query.Rd
@@ -1,5 +1,5 @@
% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/send_enrichr_query.R
+% Please edit documentation in R/send_enrichr_query.r
\name{.send_enrichr_query}
\alias{.send_enrichr_query}
\title{Gene enrichment using Enrichr.}
@@ -13,7 +13,7 @@ score between 0 and 1 in the other.}
\item{databases}{Databases to search.}
\item{URL_API}{URL to send requests to (Enrichr API).
-See http://amp.pharm.mssm.edu/Enrichr/ for available databases.}
+See https://maayanlab.cloud/Enrichr/#stats for available databases.}
}
\value{
Returns a data frame of enrichment terms, p-values, ...
diff --git a/man/getEnrichedPathways.Rd b/man/getEnrichedPathways.Rd
index baa5d76..258af15 100644
--- a/man/getEnrichedPathways.Rd
+++ b/man/getEnrichedPathways.Rd
@@ -12,7 +12,7 @@ getEnrichedPathways(
"Panther_2016", "Human_Gene_Atlas", "Mouse_Gene_Atlas"),
adj_p_cutoff = 0.05,
max_terms = 100,
- URL_API = "http://amp.pharm.mssm.edu/Enrichr/enrich"
+ URL_API = "http://maayanlab.cloud/Enrichr"
)
}
\arguments{
@@ -35,7 +35,7 @@ defaults to 0.05,}
\item{URL_API}{URL to send requests to (Enrichr API). Allows to overwrite
default URL with an alternative taken from the Enrichr website in case the
original is out-of-service; defaults to
-'http://amp.pharm.mssm.edu/Enrichr/enrich'.}
+'http://maayanlab.cloud/Enrichr'.}
}
\value{
Seurat object with Enrichr results for all provided grouping variables,
@@ -54,7 +54,7 @@ pbmc <- getEnrichedPathways(
databases = c('GO_Biological_Process_2018','GO_Cellular_Component_2018'),
adj_p_cutoff = 0.01,
max_terms = 100,
- URL_API = 'http://amp.pharm.mssm.edu/Enrichr/enrich'
+ URL_API = 'http://maayanlab.cloud/Enrichr'
)
}
diff --git a/man/launchCerebroV1.3.Rd b/man/launchCerebroV1.3.Rd
index 30510fb..6b8f8b8 100644
--- a/man/launchCerebroV1.3.Rd
+++ b/man/launchCerebroV1.3.Rd
@@ -9,6 +9,10 @@ launchCerebroV1.3(
maxFileSize = 800,
crb_file_to_load = NULL,
welcome_message = NULL,
+ projections_default_point_size = 5,
+ projections_default_point_opacity = 1,
+ projections_default_percentage_cells_to_show = 100,
+ projections_show_hover_info = TRUE,
...
)
}
@@ -29,6 +33,18 @@ Cerebro. Useful when using/hosting Cerebro in \code{closed} mode. Defaults to
in the "Load data" tab. Can contain HTML formatting, e.g.
\code{'Hi!
'}. Defaults to \code{NULL}.}
+\item{projections_default_point_size}{Default point size in projections. This
+value can be changed in the UI; defaults to 5.}
+
+\item{projections_default_point_opacity}{Default point opacity in
+projections. This value can be changed in the UI; defaults to 1.0.}
+
+\item{projections_default_percentage_cells_to_show}{Default percentage of
+cells to show in projections. This value can be changed in the UI; defaults
+to 100.}
+
+\item{projections_show_hover_info}{Show hover infos in projections. This}
+
\item{...}{Further parameters that are used by \code{shiny::runApp}, e.g.
\code{host} or \code{port}.}
}
diff --git a/other_documents/loading_cerebro_with_loaded_data_set.md b/other_documents/loading_cerebro_with_loaded_data_set.md
new file mode 100644
index 0000000..98a452e
--- /dev/null
+++ b/other_documents/loading_cerebro_with_loaded_data_set.md
@@ -0,0 +1,37 @@
+# Launching Cerebro with a loaded data set
+
+```r
+## load packages -------------------------------------------------------------##
+library(dplyr)
+library(DT)
+library(plotly)
+library(shiny)
+library(shinydashboard)
+library(shinyWidgets)
+
+## load data set -------------------------------------------------------------##
+my_data_set <<- readRDS("extdata/v1.3/example.crb")
+
+## set parameters ------------------------------------------------------------##
+Cerebro.options <<- list(
+ "mode" = "closed",
+ "crb_file_to_load" = "my_data_set",
+ "cerebro_root" = "."
+)
+
+shiny_options <- list(
+ maxRequestSize = 800 * 1024^2,
+ port = 1337
+)
+
+## load server and UI functions ----------------------------------------------##
+source(glue::glue("{Cerebro.options$cerebro_root}/shiny/v1.3/shiny_UI.R"))
+source(glue::glue("{Cerebro.options$cerebro_root}/shiny/v1.3/shiny_server.R"))
+
+## launch app ----------------------------------------------------------------##
+shiny::shinyApp(
+ ui = ui,
+ server = server,
+ options = shiny_options
+)
+```