#'
#'
cluster_classification.tab <- function() {
bquote({
menuItem(text='Cluster classification', icon=icon('object-group'), startExpanded=TRUE,
menuSubItem(text='FindMarkers results', tabName='findmarkers_results_tab', icon=under_construction_icon()),
menuItem(text='Gene modules', startExpanded=TRUE, icon=icon('layer-group'),
menuSubItem(text='Score in clusters', tabName='gene_module_score_in_clusters_tab', icon=menuSubItem_icon()),
menuSubItem(text='Scores in a cluster', tabName='gene_module_scores_in_a_cluster_tab', icon=menuSubItem_icon())) %>%
modify_stop_propagation()) %>%
modify_stop_propagation() -> menu_item
list(tabItem(tabName='findmarkers_results_tab',
h1('Feature markers of clusters'),
fluidRow(dataset_info_text_box.ui(id=NS('findmarkers_results_tab', 'project_name'), width=12)),
fluidRow(boxPlus(title='Results table', closable=FALSE, width=12, status='primary'), DT::dataTableOutput(outputId=NS('findmarkers_results_tab', 'table')) %>% withSpinner())),
tabItem(tabName='gene_module_score_in_clusters_tab',
h1('Gene module score in clusters'),
fluidRow(dataset_info_text_box.ui(id=NS('gene_module_score_in_clusters_tab', 'project_name'), width=12)),
column(width=7,
boxPlus(title='Gene module score', closable=FALSE, width=12, height='75vh', status='primary',
feature_ridges.plot(id=NS('gene_module_score_in_clusters_tab', 'scores_plot')))),
column(width=5,
boxPlus(title='Map', closable=FALSE, width=12, height='35vh', status='primary',
dimension_reduction.plot(id=NS('gene_module_score_in_clusters_tab', 'map'))),
boxPlus(title='Genes', closable=FALSE, width=12, height='35vh', status='primary',
genes_in_modules.table(id=NS('gene_module_score_in_clusters_tab', 'modules_table'))))),
tabItem(tabName='gene_module_scores_in_a_cluster_tab',
h1('Gene modules'),
fluidRow(dataset_info_text_box.ui(id=NS('gene_module_scores_in_a_cluster_tab', 'project_name'), width=12)),
column(width=7,
boxPlus(title='Gene module score', closable=FALSE, width=12, height='75vh', status='primary',
feature_ridges.plot(id=NS('gene_module_scores_in_a_cluster_tab', 'scores_plot')))),
column(width=5,
boxPlus(title='Map', closable=FALSE, width=12, height='35vh', status='primary',
dimension_reduction.plot(id=NS('gene_module_scores_in_a_cluster_tab', 'map'))),
boxPlus(title='Genes', closable=FALSE, width=12, height='35vh', status='primary',
genes_in_modules.table(id=NS('gene_module_scores_in_a_cluster_tab', 'modules_table')))))) -> content
menus %<>% append(list(menu_item))
contents %<>% append(content)})
}
#'
#' @import esquisse
#'
findmarkers_results_tab.server <- function(input, output, session, server_input, server_output, server_session, seurat) {
# build the sidebar ui
observeEvent(eventExpr=server_input$left_sidebar, handlerExpr={
tab <- 'findmarkers_results_tab'
if(server_input$left_sidebar==tab) {
if(nrow(seurat$FindMarkersResults$table)==0) {
error_alert(title='FindMarkers results', text='This Seurat object does not have any FindMarkers results.')
go_to_config(session=server_session)
return(NULL)
}
# tab %<>% str_c('-')
renderUI({tagList(filterDF_UI(id=NS(tab, 'filter_parameters')))}) -> server_output$right_sidebar.data_opts
renderUI({tagList()}) -> server_output$right_sidebar.plotting_opts
sendSweetAlert(session=session, type='warning',
title='Notice', btn_labels='OK',
text='For some reason you have to reload the Seurat object from the config tab in the right sidebar before the table will render. This will be fixed later.',
closeOnClickOutside=TRUE, showCloseButton=FALSE)
}})
# call the modules for this tab
callModule(module=dataset_info_text_box.project_name, id='project_name', seurat=seurat)
# handle the data.frame filtering
## call the data.frame filtering filtering module
callModule(session=session, module=filterDF, id='filter_parameters',
picker=TRUE, drop_ids=FALSE,
data_name=reactive(seurat$formatted_project_name),
data_table=reactive(seurat$FindMarkersResults$table),
data_vars=reactive(seurat$FindMarkersResults$vars)) -> results_filter
DT::renderDataTable({
DT::datatable(data=results_filter$data_filtered(),
rownames=FALSE,
options=list(columnDefs=list(list(className='dt-right', targets=c(1,6))),
ordering=FALSE,
dom='litp',
pageLength=20,
lengthMenu=list(c(10, 20, 50, 100, -1), c(10, 20, 50, 100,'All'))),
style='bootstrap4',
class='stripe') %>%
formatRound(columns=c('Cluster detection', 'Map detection'), digits=2) %>%
formatRound(columns=c('Avg. logFC'), digits=3)}) -> output$table
}
#'
#'
gene_module_score_in_clusters_tab.server <- function(input, output, session, server_input, server_output, server_session, seurat) {
# build the sidebar ui
observeEvent(eventExpr=server_input$left_sidebar, handlerExpr={
tab <- 'gene_module_score_in_clusters_tab'
if(server_input$left_sidebar==tab) {
tab %<>% str_c('-')
renderUI({tagList(cluster_picker.ui(id=tab, seurat=seurat, resolution=TRUE, picker=TRUE, label_switch=FALSE),
feature_picker.ui(id=tab, seurat=seurat, choices=list(`Gene modules`='gene_modules'), selected='gene_modules', gene_modules_opts=list(multiple=FALSE), include_feature_type=FALSE, include_values_range=FALSE),
dimension_reduction.ui(id=tab, seurat=seurat))}) -> server_output$right_sidebar.data_opts
renderUI({tagList()}) -> server_output$right_sidebar.plotting_opts}})
# call the modules for this tab
dimension_reduction <- callModule(module=dimension_reduction.server, id='', seurat=seurat)
cluster_resolution <- callModule(module=cluster_picker.server, id='', seurat=seurat)
feature_picker <- callModule(module=feature_picker.server, id='', seurat=seurat)
colour_picker <- list(low='linen', mid='white', high='darkviolet', background=rgb(255, 255, 255, 255, max=255))
callModule(module=dataset_info_text_box.project_name, id='project_name', seurat=seurat)
callModule(module=feature_ridge_by_idents.server, id='scores_plot', picked_feature=feature_picker, picked_clusters=cluster_resolution)
callModule(module=dimension_reduction.show_selected_clusters.server, id='map', dimension_reduction=dimension_reduction, point_size=list(size=0.6), cluster_resolution=cluster_resolution, picked_colours=colour_picker)
callModule(module=genes_in_modules.server, id='modules_table', seurat=seurat, picked_feature=feature_picker)
}
#'
#'
gene_module_scores_in_a_cluster_tab.server <- function(input, output, session, server_input, server_output, server_session, seurat) {
# build the sidebar ui
observeEvent(eventExpr=server_input$left_sidebar, handlerExpr={
tab <- 'gene_module_scores_in_a_cluster_tab'
if(server_input$left_sidebar==tab) {
tab %<>% str_c('-')
renderUI({tagList(cluster_picker.ui(id=tab, seurat=seurat, resolution=TRUE, picker=TRUE, label_switch=FALSE, multi_picker=FALSE),
feature_picker.ui(id=tab, seurat=seurat, choices=list(`Gene modules`='gene_modules'), selected='gene_modules', gene_modules_opts=list(multiple=TRUE), include_feature_type=FALSE, include_values_range=FALSE),
dimension_reduction.ui(id=tab, seurat=seurat))}) -> server_output$right_sidebar.data_opts
renderUI({tagList()}) -> server_output$right_sidebar.plotting_opts}})
# call the modules for this tab
dimension_reduction <- callModule(module=dimension_reduction.server, id='', seurat=seurat)
cluster_resolution <- callModule(module=cluster_picker.server, id='', seurat=seurat)
feature_picker <- callModule(module=feature_picker.server, id='', seurat=seurat)
colour_picker <- list(low='linen', mid='white', high='darkviolet', background=rgb(255, 255, 255, 255, max=255))
callModule(module=dataset_info_text_box.project_name, id='project_name', seurat=seurat)
callModule(module=feature_ridges_by_ident.server, id='scores_plot', picked_feature=feature_picker, picked_clusters=cluster_resolution)
callModule(module=dimension_reduction.show_selected_clusters.server, id='map', dimension_reduction=dimension_reduction, point_size=list(size=0.6), cluster_resolution=cluster_resolution, picked_colours=colour_picker)
callModule(module=genes_in_modules.server, id='modules_table', seurat=seurat, picked_feature=feature_picker)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.