From 34ec584635065da577f8a59ac8de8c0a5677c21b Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Wed, 7 Oct 2020 14:12:40 +0200 Subject: [PATCH 01/39] Add global option to show hover info in projections, which is set to TRUE at app launch and can be changed in the 'About' tab; add tooltip to the hover info and WebGL checkboxes in the 'About' tab. --- inst/shiny/v1.3/about/server.R | 47 ++++++++++++++++++++++++---------- inst/shiny/v1.3/shiny_server.R | 3 ++- 2 files changed, 36 insertions(+), 14 deletions(-) diff --git a/inst/shiny/v1.3/about/server.R b/inst/shiny/v1.3/about/server.R index 3bef0aa..c150478 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
@@ -40,21 +41,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 = TRUE + ) + ) ) }) +## 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 +95,7 @@ output[["logo_Cerebro"]] <- renderImage({ deleteFile = FALSE ) +## output[["about_footer"]] <- renderText({ paste0( '
@@ -79,11 +108,3 @@ output[["about_footer"]] <- renderText({ ' ) }) - - - - - - - - diff --git a/inst/shiny/v1.3/shiny_server.R b/inst/shiny/v1.3/shiny_server.R index 9315e94..bf14f18 100644 --- a/inst/shiny/v1.3/shiny_server.R +++ b/inst/shiny/v1.3/shiny_server.R @@ -35,7 +35,8 @@ server <- function(input, output, session) { ) preferences <- reactiveValues( - use_webgl = TRUE + use_webgl = TRUE, + show_hover_info_in_projections = TRUE ) ## paths for storing plots From 9c4a2f5927357ffd07521cb07b9ab8a44fc03c1e Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Wed, 7 Oct 2020 14:13:22 +0200 Subject: [PATCH 02/39] Add utility function to calculate center of groups in projection plots. --- inst/shiny/v1.3/utility_functions.R | 48 +++++++++++++++++++++++++++++ 1 file changed, 48 insertions(+) diff --git a/inst/shiny/v1.3/utility_functions.R b/inst/shiny/v1.3/utility_functions.R index 5f372c5..846bb03 100644 --- a/inst/shiny/v1.3/utility_functions.R +++ b/inst/shiny/v1.3/utility_functions.R @@ -768,6 +768,54 @@ getGenesForGeneSet <- function(gene_set) { sort() } +##----------------------------------------------------------------------------## +## Function to calculate center of groups in projections/trajectories. +## +## +##----------------------------------------------------------------------------## +centerOfGroups <- function(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 = df[,1], + y = df[,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 ) { + + ## calculate center for groups and return + tidyr::tibble( + x = df[,1], + y = df[,2], + z = df[,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() + } +} + ##----------------------------------------------------------------------------## ## Functions to interact with data set. ## From 6a28e5a9e94ac67bf11e1015c864fa7485f310cf Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Thu, 31 Dec 2020 00:01:03 +0100 Subject: [PATCH 03/39] Fix typo in comments and remove empty space at end of file. --- inst/shiny/v1.3/plotting_functions.R | 16 ---------------- inst/shiny/v1.3/trajectory/projection.R | 2 +- .../shiny/v1.3/trajectory/selected_cells_table.R | 2 +- 3 files changed, 2 insertions(+), 18 deletions(-) diff --git a/inst/shiny/v1.3/plotting_functions.R b/inst/shiny/v1.3/plotting_functions.R index 77f5611..d09f713 100644 --- a/inst/shiny/v1.3/plotting_functions.R +++ b/inst/shiny/v1.3/plotting_functions.R @@ -197,19 +197,3 @@ plotlySankeyPlot <- function( ## return(plot) } - - - - - - - - - - - - - - - - diff --git a/inst/shiny/v1.3/trajectory/projection.R b/inst/shiny/v1.3/trajectory/projection.R index 9ffdf47..1e600e7 100644 --- a/inst/shiny/v1.3/trajectory/projection.R +++ b/inst/shiny/v1.3/trajectory/projection.R @@ -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..5d59d19 100644 --- a/inst/shiny/v1.3/trajectory/selected_cells_table.R +++ b/inst/shiny/v1.3/trajectory/selected_cells_table.R @@ -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 From 81a7412b35d88247131042a4a2af3f723b621617 Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Thu, 31 Dec 2020 00:01:43 +0100 Subject: [PATCH 04/39] Add ".Rproj.user" folder to ".gitignore". --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 7612fc4..8a7a936 100755 --- a/.gitignore +++ b/.gitignore @@ -5,3 +5,4 @@ cerebroApp_*.tar.gz vignettes/*.crb docs tests +.Rproj.user From e613dbdef3ae5ee81ce01a23a61b852990e51281 Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Thu, 31 Dec 2020 00:02:13 +0100 Subject: [PATCH 05/39] Add function to set order of rows in data frame. --- inst/shiny/v1.3/utility_functions.R | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/inst/shiny/v1.3/utility_functions.R b/inst/shiny/v1.3/utility_functions.R index 846bb03..658687a 100644 --- a/inst/shiny/v1.3/utility_functions.R +++ b/inst/shiny/v1.3/utility_functions.R @@ -816,6 +816,19 @@ centerOfGroups <- function(df, n_dimensions, group) { } } +##----------------------------------------------------------------------------## +## 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. ## From e0e7ad2a351f929a27ba899571575845575fafa1 Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Thu, 31 Dec 2020 00:16:51 +0100 Subject: [PATCH 06/39] Refactor code for "Overview" tab. - Create reactive object that collects parameters for projection and update UI elements when it changes. - Add checkbox to enable/disable showing center of group labels in projection plot. - Add checkbox to enable/disable showing border around cells in projection plot. - Make internal parameter and element names more coherent. --- inst/shiny/v1.3/overview/projection.R | 630 +++++++++++++----- .../shiny/v1.3/overview/selected_cells_plot.R | 34 +- .../v1.3/overview/selected_cells_table.R | 17 +- 3 files changed, 467 insertions(+), 214 deletions(-) diff --git a/inst/shiny/v1.3/overview/projection.R b/inst/shiny/v1.3/overview/projection.R index 799435e..23436bf 100644 --- a/inst/shiny/v1.3/overview/projection.R +++ b/inst/shiny/v1.3/overview/projection.R @@ -81,6 +81,8 @@ output[["overview_projection_UI"]] <- renderUI({ 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, @@ -120,7 +122,7 @@ output[["overview_projection_main_parameters_UI"]] <- renderUI({ choices = availableProjections() ), selectInput( - "overview_point_color", + "overview_projection_point_color", label = "Color cells by", choices = colnames(getMetaData())[! colnames(getMetaData()) %in% c("cell_barcode")] ) @@ -166,7 +168,7 @@ overview_projection_main_parameters_info <- list( output[["overview_projection_additional_parameters_UI"]] <- renderUI({ tagList( sliderInput( - "overview_point_size", + "overview_projection_point_size", label = "Point size", min = scatter_plot_point_size[["min"]], max = scatter_plot_point_size[["max"]], @@ -174,7 +176,7 @@ output[["overview_projection_additional_parameters_UI"]] <- renderUI({ value = scatter_plot_point_size[["default"]] ), sliderInput( - "overview_point_opacity", + "overview_projection_point_opacity", label = "Point opacity", min = scatter_plot_point_opacity[["min"]], max = scatter_plot_point_opacity[["max"]], @@ -182,7 +184,7 @@ output[["overview_projection_additional_parameters_UI"]] <- renderUI({ value = scatter_plot_point_opacity[["default"]] ), sliderInput( - "overview_percentage_cells_to_show", + "overview_projection_percentage_cells_to_show", label = "Show % of cells", min = scatter_plot_percentage_cells_to_show[["min"]], max = scatter_plot_percentage_cells_to_show[["max"]], @@ -238,20 +240,32 @@ overview_projection_additional_parameters_info <- list( ##----------------------------------------------------------------------------## 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), + options = list( + "actions-box" = TRUE + ), multiple = TRUE ) } + 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. ##----------------------------------------------------------------------------## @@ -280,10 +294,48 @@ overview_projection_group_filters_info <- list( ) ) +##----------------------------------------------------------------------------## +## 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 = "Show group labels in projection", + value = TRUE + ) + } +}) + ## make sure elements are loaded even though the box is collapsed outputOptions( output, - "overview_projection_group_filters_UI", + "overview_projection_show_group_label_UI", + suspendWhenHidden = FALSE +) + +##----------------------------------------------------------------------------## +## 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 ) @@ -292,27 +344,31 @@ outputOptions( ##----------------------------------------------------------------------------## output[["overview_projection_scales_UI"]] <- renderUI({ - projection_to_display <- if ( + + ## + if ( is.null(input[["overview_projection_to_display"]]) || is.na(input[["overview_projection_to_display"]]) ) { - availableProjections()[1] + projection_to_display <- availableProjections()[1] } else { - input[["overview_projection_to_display"]] + projection_to_display <- input[["overview_projection_to_display"]] } + ## XYranges <- getXYranges(getProjection(projection_to_display)) + ## tagList( sliderInput( - "overview_scale_x_manual_range", + "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_scale_y_manual_range", + "overview_projection_scale_y_manual_range", label = "Range of Y axis", min = XYranges$y$min, max = XYranges$y$max, @@ -328,6 +384,57 @@ outputOptions( suspendWhenHidden = FALSE ) +##----------------------------------------------------------------------------## +## Collect parameters for projection plot. +##----------------------------------------------------------------------------## + +overview_projection_inputs <- reactive({ + + ## require input UI elements + req( + input[["overview_projection_to_display"]], + input[["overview_projection_point_color"]], + input[["overview_projection_point_size"]], + input[["overview_projection_point_opacity"]], + input[["overview_projection_percentage_cells_to_show"]], + !is.null(input[["overview_projection_show_group_label"]]), + !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"]]) + ) + + ## require group filters UI elements and at least 1 group level to be selected + for ( i in getGroups() ) { + req(input[[paste0("overview_projection_group_filter_", i)]]) + } + + ## collect parameters + parameters <- list( + projection = 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"]], + pct_cells = input[["overview_projection_percentage_cells_to_show"]], + group_labels = input[["overview_projection_show_group_label"]], + draw_border = input[["overview_projection_point_border"]], + x_range = input[["overview_projection_scale_x_manual_range"]], + y_range = input[["overview_projection_scale_y_manual_range"]], + group_filters = list(), + webgl = preferences[["use_webgl"]], + hover_info = preferences[["show_hover_info_in_projections"]] + ) + + ## store group filters + for ( i in getGroups() ) { + parameters[['group_filters']][[ i ]] <- input[[paste0("overview_projection_group_filter_", i)]] + } + + ## return parameters + return(parameters) +}) + ##----------------------------------------------------------------------------## ## Plotly plot of the selected projection. ##----------------------------------------------------------------------------## @@ -336,42 +443,60 @@ 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"]] + overview_projection_inputs() ) - projection_to_display <- input[["overview_projection_to_display"]] + ## save selected UMAP and coloring variable + projection_to_display <- overview_projection_inputs()[["projection"]] + variable_to_color_cells <- overview_projection_inputs()[["color_variable"]] ## 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]] ),] + 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% overview_projection_inputs()[["group_filters"]][[ i ]] ),] } } ## randomly remove cells (if necessary) - cells_df <- randomlySubsetCells(cells_df, input[["overview_percentage_cells_to_show"]]) + cells_df <- randomlySubsetCells(cells_df, overview_projection_inputs()[["pct_cells"]]) ## 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"]]) + colors_for_groups <- assignColorsToGroups(cells_df, variable_to_color_cells) + + ## check if border around cells should be drawn and set parameters if so + if ( overview_projection_inputs()[["draw_border"]] == TRUE ) { + line <- list( + color = "rgb(196,196,196)", + width = 1 + ) + } else { + line <- NULL + } - ## prepare hover info - hover_info <- buildHoverInfoForProjections(cells_df) + ## prepare hover info according to settings + ## ... hover info should be shown + if ( overview_projection_inputs()[["hover_info"]] == TRUE ) { + + hover_info <- buildHoverInfoForProjections(cells_df) + + parameter_hoverinfo <- "text" + parameter_text <- ~hover_info + + ## ... no hover info to be shown + } else { + + parameter_hoverinfo <- "skip" + parameter_text <- NULL + } ## check if projection consists of 3 or 2 dimensions ## ... selected projection contains 3 dimensions @@ -379,7 +504,7 @@ output[["overview_projection"]] <- plotly::renderPlotly({ ## check if selected coloring variable is categorical or numeric ## ... selected coloring variable is numeric - if ( is.numeric(cells_df[[ input[["overview_point_color"]] ]]) ) { + if ( is.numeric(cells_df[[ variable_to_color_cells ]]) ) { plot <- plotly::plot_ly( cells_df, x = ~cells_df[,1], @@ -389,20 +514,17 @@ output[["overview_projection"]] <- plotly::renderPlotly({ mode = "markers", marker = list( colorbar = list( - title = input[["overview_point_color"]] + title = variable_to_color_cells ), - color = ~cells_df[[ input[["overview_point_color"]] ]], - opacity = input[["overview_point_opacity"]], + color = ~cells_df[[ variable_to_color_cells ]], + opacity = overview_projection_inputs()[["point_opacity"]], colorscale = "YlGnBu", reversescale = TRUE, - line = list( - color = "rgb(196,196,196)", - width = 1 - ), - size = input[["overview_point_size"]] + line = line, + size = overview_projection_inputs()[["point_size"]] ), - hoverinfo = "text", - text = ~hover_info, + hoverinfo = parameter_hoverinfo, + text = parameter_text, source = "overview_projection" ) @@ -413,22 +535,46 @@ output[["overview_projection"]] <- plotly::renderPlotly({ x = ~cells_df[,1], y = ~cells_df[,2], z = ~cells_df[,3], - color = ~cells_df[[ input[["overview_point_color"]] ]], + color = ~cells_df[[ variable_to_color_cells ]], 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"]] + opacity = overview_projection_inputs()[["point_opacity"]], + line = line, + size = overview_projection_inputs()[["point_size"]] ), - hoverinfo = "text", - text = ~hover_info, + hoverinfo = parameter_hoverinfo, + text = parameter_text, source = "overview_projection" ) + + ## check if group labels should be plotted and, if so, add them + if ( overview_projection_inputs()[["group_labels"]] == TRUE ) { + + ## calculate group level centers + group_labels <- centerOfGroups(cells_df, 3, variable_to_color_cells) + + ## add group level labels at center of respective groups + plot <- plot %>% + plotly::add_trace( + data = group_labels, + x = ~x_median, + y = ~y_median, + z = ~z_median, + type = 'scatter3d', + mode = 'text', + name = "Labels", + text = ~group, + textposition = 'middle center', + textfont = list( + color = '#000000', + size = 16 + ), + hoverinfo = "skip", + inherit = FALSE + ) + } } ## add layout to plot @@ -457,7 +603,8 @@ output[["overview_projection"]] <- plotly::renderPlotly({ hoverlabel = list( font = list( size = 11 - ) + ), + align = "left" ) ) @@ -466,7 +613,7 @@ output[["overview_projection"]] <- plotly::renderPlotly({ ## check if selected coloring variable is categorical or numeric ## ... selected coloring variable is numeric - if ( is.numeric(cells_df[[ input[["overview_point_color"]] ]]) ) { + if ( is.numeric(cells_df[[ variable_to_color_cells ]]) ) { plot <- plotly::plot_ly( cells_df, x = ~cells_df[,1], @@ -475,45 +622,66 @@ output[["overview_projection"]] <- plotly::renderPlotly({ mode = "markers", marker = list( colorbar = list( - title = input[["overview_point_color"]] + title = variable_to_color_cells ), - color = ~cells_df[[ input[["overview_point_color"]] ]], - opacity = input[["overview_point_opacity"]], + color = ~cells_df[[ variable_to_color_cells ]], + opacity = overview_projection_inputs()[["point_opacity"]], colorscale = "YlGnBu", reversescale = TRUE, - line = list( - color = "rgb(196,196,196)", - width = 1 - ), - size = input[["overview_point_size"]] + line = line, + size = overview_projection_inputs()[["point_size"]] ), - hoverinfo = "text", - text = ~hover_info, + hoverinfo = parameter_hoverinfo, + text = parameter_text, 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"]] ]], + color = ~cells_df[[ variable_to_color_cells ]], 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"]] + opacity = overview_projection_inputs()[["point_opacity"]], + line = line, + size = overview_projection_inputs()[["point_size"]] ), - hoverinfo = "text", - text = ~hover_info, + hoverinfo = parameter_hoverinfo, + text = parameter_text, source = "overview_projection" ) + + ## check if group labels should be plotted and, if so, add them + if ( overview_projection_inputs()[["group_labels"]] == TRUE ) { + + ## calculate group level centers + group_labels <- centerOfGroups(cells_df, 2, variable_to_color_cells) + + ## add group level labels at center of respective groups + plot <- plot %>% + plotly::add_trace( + data = group_labels, + x = ~x_median, + y = ~y_median, + type = 'scatter', + mode = 'text', + name = "Labels", + text = ~group, + textposition = 'middle center', + textfont = list( + color = '#000000', + size = 16 + ), + hoverinfo = "skip", + inherit = FALSE + ) + } } ## add layout to plot @@ -524,20 +692,25 @@ output[["overview_projection"]] <- plotly::renderPlotly({ mirror = TRUE, showline = TRUE, zeroline = FALSE, - range = input[["overview_scale_x_manual_range"]] + range = overview_projection_inputs()[["x_range"]] ), yaxis = list( title = colnames(cells_df)[2], mirror = TRUE, showline = TRUE, zeroline = FALSE, - range = input[["overview_scale_y_manual_range"]] + range = overview_projection_inputs()[["y_range"]] ), - hoverlabel = list(font = list(size = 11)) + hoverlabel = list( + font = list( + size = 11 + ), + align = "left" + ) ) ## return plot either with WebGL or without, depending on setting - if ( preferences[["use_webgl"]] == TRUE ) { + if ( overview_projection_inputs()[["webgl"]] == TRUE ) { plot %>% plotly::toWebGL() } else { plot @@ -546,23 +719,47 @@ output[["overview_projection"]] <- plotly::renderPlotly({ }) ##----------------------------------------------------------------------------## -## Text showing the number of selected cells. +## Reactive that holds IDs of selected cells (ID is built from position in +## projection). ##----------------------------------------------------------------------------## -output[["overview_number_of_selected_cells"]] <- renderText({ +overview_projection_selected_cells <- reactive({ - ## don't proceed without these inputs + ## make sure plot parameters are set because it means that the plot can be + ## generated req( - input[["overview_projection_to_display"]] + overview_projection_inputs() ) ## 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 = "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() + } +}) + +##----------------------------------------------------------------------------## +## 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 @@ -570,7 +767,9 @@ output[["overview_number_of_selected_cells"]] <- renderText({ } 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) + number_of_selected_cells <- overview_projection_selected_cells() %>% + nrow() %>% + formatC(format = "f", big.mark = ",", digits = 0) } ## prepare string to show @@ -619,17 +818,15 @@ overview_projection_info <- list( observeEvent(input[["overview_projection_export"]], { - ## don't proceed without these inputs + ## make sure plot parameters are set because it means that the plot can be + ## generated 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"]] + overview_projection_inputs() ) + ## + parameters <- overview_projection_inputs() + ## open dialog to select where plot should be saved and how the file should ## be named shinyFiles::shinyFileSave( @@ -644,122 +841,187 @@ observeEvent(input[["overview_projection_export"]], { 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 ) { + req( + nrow(save_file_input) > 0 + ) - ## extract specified file path - save_file_path <- as.character(save_file_input$datapath[1]) + ## extract specified file path + save_file_path <- as.character(save_file_input$datapath[1]) - ## ggplot2 functions are necessary to create the plot - require("ggplot2") + ## ggplot2 functions are necessary to create the plot + require("ggplot2") - ## get selected projection - projection_to_display <- input[["overview_projection_to_display"]] + ## get selected projection + projection_to_display <- parameters[["projection"]] + variable_to_color_cells <- parameters[["color_variable"]] + + ## check if selection projection consists of 2 or 3 dimensions + ## ... selection projection consists of 2 dimensions + if ( ncol(getProjection(projection_to_display)) == 2 ) { ## 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"]]) + cells_df <- randomlySubsetCells(cells_df, parameters[["pct_cells"]]) ## 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 ) { + ## + if ( parameters[["draw_border"]] == TRUE ) { + stroke <- 0.2 + } else { + stroke <- 0 + } - ## 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 + ## 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(variable_to_color_cells) + ) + ) + + geom_point( + shape = 21, + size = parameters[["point_size"]]/3, + stroke = stroke, + color = "#c4c4c4", + alpha = parameters[["point_opacity"]] + ) + + lims( + x = parameters[["x_range"]], + y = 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 ]]) + ) { + + ## get colors for groups + colors_for_groups <- assignColorsToGroups(cells_df, variable_to_color_cells) + + ## add color assignments + plot <- plot + scale_fill_manual(values = colors_for_groups) + + ## check if group labels should be plotted and, if so, add them + if ( parameters[["group_labels"]] == TRUE ) { + + ## calculate group level centers + group_labels <- centerOfGroups(cells_df, 2, variable_to_color_cells) + + ## add group level labels at center of respective groups plot <- plot + - scale_fill_distiller( - palette = "YlGnBu", - direction = 1, - guide = guide_colorbar(frame.colour = "black", ticks.colour = "black") + 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 ) } - ## 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) ) { + ## ... not categorical (probably numerical) + } else { - ## give positive message - shinyWidgets::sendSweetAlert( - session = session, - title = "Success!", - text = paste0("Plot saved successfully as: ", save_file_path), - type = "success" + ## add continuous color scale + plot <- plot + + scale_fill_distiller( + palette = "YlGnBu", + direction = 1, + guide = guide_colorbar(frame.colour = "black", ticks.colour = "black") ) + } - ## ... failed - } else { + ## save plot + pdf(NULL) + ggsave(save_file_path, plot, height = 8, width = 11) - ## give negative message - shinyWidgets::sendSweetAlert( - session = session, - title = "Error!", - text = "Sorry, it seems something went wrong...", - type = "error" - ) - } + ## 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 ( 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" + ) } }) + +##----------------------------------------------------------------------------## +## 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/selected_cells_plot.R b/inst/shiny/v1.3/overview/selected_cells_plot.R index 23d1a11..d4cbe49 100644 --- a/inst/shiny/v1.3/overview/selected_cells_plot.R +++ b/inst/shiny/v1.3/overview/selected_cells_plot.R @@ -35,40 +35,35 @@ output[["overview_selected_cells_plot_UI"]] <- renderUI({ ##----------------------------------------------------------------------------## output[["overview_details_selected_cells_plot"]] <- plotly::renderPlotly({ + req( - input[["overview_projection_to_display"]], + overview_projection_inputs()[["projection"]], input[["overview_selected_cells_plot_select_variable"]] ) ## extract cells to plot cells_df <- cbind( - getProjection(input[["overview_projection_to_display"]]), - getMetaData() - ) + getProjection(overview_projection_inputs()[["projection"]]), + getMetaData() + ) - ## - ## ... - if ( - is.null(plotly::event_data("plotly_selected", source = "overview_projection")) || - length(plotly::event_data("plotly_selected", source = "overview_projection")) == 0 - ) { + ## 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')) ) } @@ -164,7 +159,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", diff --git a/inst/shiny/v1.3/overview/selected_cells_table.R b/inst/shiny/v1.3/overview/selected_cells_table.R index 6886f25..f78948e 100644 --- a/inst/shiny/v1.3/overview/selected_cells_table.R +++ b/inst/shiny/v1.3/overview/selected_cells_table.R @@ -44,15 +44,12 @@ output[["overview_details_selected_cells_table"]] <- DT::renderDataTable(server ## don't proceed without these inputs req( - input[["overview_projection_to_display"]] + overview_projection_inputs() ) ## 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 - ) { + ## ... selection has not been made or there is no cell in it + if ( is.null(overview_projection_selected_cells()) ) { ## prepare empty table getMetaData() %>% @@ -62,13 +59,9 @@ output[["overview_details_selected_cells_table"]] <- DT::renderDataTable(server ## ... 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"]]), + getProjection(overview_projection_inputs()[["projection"]]), getMetaData() ) %>% as.data.frame() @@ -77,7 +70,7 @@ output[["overview_details_selected_cells_table"]] <- DT::renderDataTable(server cells_df <- cells_df %>% dplyr::rename(X1 = 1, X2 = 2) %>% dplyr::mutate(identifier = paste0(X1, '-', X2)) %>% - dplyr::filter(identifier %in% selected_cells$identifier) %>% + dplyr::filter(identifier %in% overview_projection_selected_cells()$identifier) %>% dplyr::select(-c(X1, X2, identifier)) %>% dplyr::select(cell_barcode, everything()) From b261e184f2c8a82ddbece8933660566118e0a915 Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Sat, 9 Jan 2021 18:52:11 +0100 Subject: [PATCH 07/39] Add .Rproj files to .gitignore. --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 8a7a936..9870a2e 100755 --- a/.gitignore +++ b/.gitignore @@ -6,3 +6,4 @@ vignettes/*.crb docs tests .Rproj.user +*.Rproj From 10619804c0ced9690eb186f49c1b1b65052f990f Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Sat, 9 Jan 2021 19:05:04 +0100 Subject: [PATCH 08/39] Intermediate commit. --- inst/shiny/v1.3/overview/projection.R | 593 +++++++----------- inst/shiny/v1.3/overview/projection_update.js | 224 +++++++ .../shiny/v1.3/overview/selected_cells_plot.R | 4 +- .../v1.3/overview/selected_cells_table.R | 6 +- inst/shiny/v1.3/utility_functions.R | 14 +- 5 files changed, 471 insertions(+), 370 deletions(-) create mode 100644 inst/shiny/v1.3/overview/projection_update.js diff --git a/inst/shiny/v1.3/overview/projection.R b/inst/shiny/v1.3/overview/projection.R index 23436bf..7305205 100644 --- a/inst/shiny/v1.3/overview/projection.R +++ b/inst/shiny/v1.3/overview/projection.R @@ -112,7 +112,6 @@ output[["overview_projection_UI"]] <- renderUI({ ##----------------------------------------------------------------------------## ## UI elements to set main parameters for the projection. ##----------------------------------------------------------------------------## - output[["overview_projection_main_parameters_UI"]] <- renderUI({ tagList( @@ -132,7 +131,6 @@ output[["overview_projection_main_parameters_UI"]] <- renderUI({ ##----------------------------------------------------------------------------## ## Info box that gets shown when pressing the "info" button. ##----------------------------------------------------------------------------## - observeEvent(input[["overview_projection_main_parameters_info"]], { showModal( modalDialog( @@ -148,7 +146,6 @@ observeEvent(input[["overview_projection_main_parameters_info"]], { ##----------------------------------------------------------------------------## ## Text in info box. ##----------------------------------------------------------------------------## - overview_projection_main_parameters_info <- list( title = "Main parameters for projection", text = HTML(" @@ -164,7 +161,6 @@ overview_projection_main_parameters_info <- list( ##----------------------------------------------------------------------------## ## UI elements to set additional parameters for the projection. ##----------------------------------------------------------------------------## - output[["overview_projection_additional_parameters_UI"]] <- renderUI({ tagList( sliderInput( @@ -204,7 +200,6 @@ outputOptions( ##----------------------------------------------------------------------------## ## Info box that gets shown when pressing the "info" button. ##----------------------------------------------------------------------------## - observeEvent(input[["overview_projection_additional_parameters_info"]], { showModal( modalDialog( @@ -221,7 +216,6 @@ observeEvent(input[["overview_projection_additional_parameters_info"]], { ## 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(" @@ -238,7 +232,6 @@ overview_projection_additional_parameters_info <- list( ##----------------------------------------------------------------------------## ## UI elements to set group filters for the projection. ##----------------------------------------------------------------------------## - output[["overview_projection_group_filters_UI"]] <- renderUI({ group_filters <- list() @@ -269,7 +262,6 @@ outputOptions( ##----------------------------------------------------------------------------## ## Info box that gets shown when pressing the "info" button. ##----------------------------------------------------------------------------## - observeEvent(input[["overview_projection_group_filters_info"]], { showModal( modalDialog( @@ -285,7 +277,6 @@ observeEvent(input[["overview_projection_group_filters_info"]], { ##----------------------------------------------------------------------------## ## Text in info box. ##----------------------------------------------------------------------------## - overview_projection_group_filters_info <- list( title = "Group filters for projection", text = HTML(" @@ -297,7 +288,6 @@ overview_projection_group_filters_info <- list( ##----------------------------------------------------------------------------## ## UI elements with switch to show group labels in projection. ##----------------------------------------------------------------------------## - output[["overview_projection_show_group_label_UI"]] <- renderUI({ req( @@ -307,7 +297,7 @@ output[["overview_projection_show_group_label_UI"]] <- renderUI({ if ( input[["overview_projection_point_color"]] %in% getGroups() ) { shinyWidgets::awesomeCheckbox( inputId = "overview_projection_show_group_label", - label = "Show group labels in projection", + label = "Plot group labels in exported PDF", value = TRUE ) } @@ -323,7 +313,6 @@ outputOptions( ##----------------------------------------------------------------------------## ## UI elements with switch to draw border around cells. ##----------------------------------------------------------------------------## - output[["overview_projection_point_border_UI"]] <- renderUI({ shinyWidgets::awesomeCheckbox( inputId = "overview_projection_point_border", @@ -342,7 +331,6 @@ outputOptions( ##----------------------------------------------------------------------------## ## UI elements to select X and Y limits in projection. ##----------------------------------------------------------------------------## - output[["overview_projection_scales_UI"]] <- renderUI({ ## @@ -387,362 +375,304 @@ outputOptions( ##----------------------------------------------------------------------------## ## Collect parameters for projection plot. ##----------------------------------------------------------------------------## - -overview_projection_inputs <- reactive({ - +overview_projection_parameters_plot_raw <- reactive({ ## require input UI elements req( input[["overview_projection_to_display"]], input[["overview_projection_point_color"]], input[["overview_projection_point_size"]], input[["overview_projection_point_opacity"]], - input[["overview_projection_percentage_cells_to_show"]], - !is.null(input[["overview_projection_show_group_label"]]), !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"]]) ) - - ## require group filters UI elements and at least 1 group level to be selected - for ( i in getGroups() ) { - req(input[[paste0("overview_projection_group_filter_", i)]]) - } - ## collect parameters 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"]], - pct_cells = input[["overview_projection_percentage_cells_to_show"]], - group_labels = input[["overview_projection_show_group_label"]], 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"]], - group_filters = list(), webgl = preferences[["use_webgl"]], hover_info = preferences[["show_hover_info_in_projections"]] ) - - ## store group filters - for ( i in getGroups() ) { - parameters[['group_filters']][[ i ]] <- input[[paste0("overview_projection_group_filter_", i)]] - } - ## return parameters return(parameters) }) +overview_projection_parameters_plot <- debounce(overview_projection_parameters_plot_raw, 1) + ##----------------------------------------------------------------------------## -## Plotly plot of the selected projection. +## Color assignments. ##----------------------------------------------------------------------------## - -output[["overview_projection"]] <- plotly::renderPlotly({ - - ## don't proceed without these inputs +overview_projection_color_assignments <- reactive({ req( - overview_projection_inputs() + overview_projection_data(), + overview_projection_parameters_plot() + ) + return( + assignColorsToGroups( + overview_projection_data(), + overview_projection_parameters_plot()['color_variable'] + ) ) +}) - ## save selected UMAP and coloring variable - projection_to_display <- overview_projection_inputs()[["projection"]] - variable_to_color_cells <- overview_projection_inputs()[["color_variable"]] +##----------------------------------------------------------------------------## +## Input parameters for filtering cells. +##----------------------------------------------------------------------------## +overview_projection_parameters_cell_filtering_raw <- reactive({ + req( + input[["overview_projection_to_display"]], + input[["overview_projection_percentage_cells_to_show"]] + ) + ## require group filters UI elements and at least 1 group level to be selected + for ( i in getGroups() ) { + req(input[[paste0("overview_projection_group_filter_", i)]]) + } + parameters <- list( + projection = input[["overview_projection_to_display"]], + pct_cells = input[["overview_projection_percentage_cells_to_show"]], + group_filters = list() + ) + ## store group filters + for ( i in getGroups() ) { + parameters[['group_filters']][[ i ]] <- input[[paste0("overview_projection_group_filter_", i)]] + } + return(parameters) +}) - ## build data frame with data - cells_df <- cbind(getProjection(projection_to_display), getMetaData()) +overview_projection_parameters_cell_filtering <- debounce(overview_projection_parameters_cell_filtering_raw, 1) +##----------------------------------------------------------------------------## +## Cell meta data and position in projection. +##----------------------------------------------------------------------------## +overview_projection_data <- reactive({ + req(overview_projection_parameters_cell_filtering()) + parameters <- overview_projection_parameters_cell_filtering() + cells_df <- cbind(getProjection(parameters[["projection"]]), getMetaData()) ## remove cells based on group filters 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% overview_projection_inputs()[["group_filters"]][[ i ]] ),] + cells_df <- cells_df[which(cells_df[[i]] %in% parameters[["group_filters"]][[ i ]] ),] } } - ## randomly remove cells (if necessary) - cells_df <- randomlySubsetCells(cells_df, overview_projection_inputs()[["pct_cells"]]) - + cells_df <- randomlySubsetCells(cells_df, parameters[["pct_cells"]]) ## put rows in random order cells_df <- cells_df[ sample(1:nrow(cells_df)) , ] + return(cells_df) +}) - ## get colors for groups - colors_for_groups <- assignColorsToGroups(cells_df, variable_to_color_cells) - - ## check if border around cells should be drawn and set parameters if so - if ( overview_projection_inputs()[["draw_border"]] == TRUE ) { - line <- list( - color = "rgb(196,196,196)", - width = 1 - ) - } else { - line <- NULL - } - - ## prepare hover info according to settings - ## ... hover info should be shown - if ( overview_projection_inputs()[["hover_info"]] == TRUE ) { - - hover_info <- buildHoverInfoForProjections(cells_df) +##----------------------------------------------------------------------------## +## Hover info. +##----------------------------------------------------------------------------## +overview_projection_hover_info <- reactive({ + req(overview_projection_data()) + cells_df <- overview_projection_data() + hover_info <- buildHoverInfoForProjections(cells_df) + hover_info <- setNames(hover_info, cells_df$cell_barcode) + return(hover_info) +}) - parameter_hoverinfo <- "text" - parameter_text <- ~hover_info +##----------------------------------------------------------------------------## +## Plotly plot of the selected projection. +##----------------------------------------------------------------------------## +output[["overview_projection"]] <- plotly::renderPlotly({ + plot_ly(type = 'scattergl', mode = 'markers', source = "overview_projection") +}) - ## ... no hover info to be shown +## +overview_projection_data_to_plot <- reactive({ + req( + overview_projection_data(), + overview_projection_parameters_plot(), + reactive_colors(), + overview_projection_hover_info() + ) + if ( is.numeric(overview_projection_parameters_plot()[['color_variable']]) ) { + color_assignments <- NA } else { - - parameter_hoverinfo <- "skip" - parameter_text <- NULL + color_assignments <- assignColorsToGroups( + overview_projection_data(), + overview_projection_parameters_plot()[['color_variable']] + ) } + list( + cells_df = overview_projection_data(), + plot_parameters = overview_projection_parameters_plot(), + color_assignments = color_assignments, + hover_info = overview_projection_hover_info() + ) +}) - ## 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[[ variable_to_color_cells ]]) ) { - 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 = variable_to_color_cells - ), - color = ~cells_df[[ variable_to_color_cells ]], - opacity = overview_projection_inputs()[["point_opacity"]], - colorscale = "YlGnBu", - reversescale = TRUE, - line = line, - size = overview_projection_inputs()[["point_size"]] - ), - hoverinfo = parameter_hoverinfo, - text = parameter_text, - 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[[ variable_to_color_cells ]], - colors = colors_for_groups, - type = "scatter3d", - mode = "markers", - marker = list( - opacity = overview_projection_inputs()[["point_opacity"]], - line = line, - size = overview_projection_inputs()[["point_size"]] - ), - hoverinfo = parameter_hoverinfo, - text = parameter_text, - source = "overview_projection" - ) - - ## check if group labels should be plotted and, if so, add them - if ( overview_projection_inputs()[["group_labels"]] == TRUE ) { - - ## calculate group level centers - group_labels <- centerOfGroups(cells_df, 3, variable_to_color_cells) +## +observeEvent(overview_projection_data_to_plot(), { + req(overview_projection_data_to_plot()) + overview_projection_update_plot(overview_projection_data_to_plot()) +}) - ## add group level labels at center of respective groups - plot <- plot %>% - plotly::add_trace( - data = group_labels, - x = ~x_median, - y = ~y_median, - z = ~z_median, - type = 'scatter3d', - mode = 'text', - name = "Labels", - text = ~group, - textposition = 'middle center', - textfont = list( - color = '#000000', - size = 16 - ), - hoverinfo = "skip", - inherit = FALSE - ) - } +## function to be executed to update figure +overview_projection_update_plot <- function(input) { + cells_df <- input[['cells_df']] + plot_parameters <- input[['plot_parameters']] + color_assignments <- input[['color_assignments']] + hover_info <- input[['hover_info']] + color_input <- cells_df[[ plot_parameters[['color_variable']] ]] + if ( is.numeric(color_input) ) { + output_meta <- list( + color_type = 'continuous', + traces = plot_parameters[['color_variable']], + color_variable = plot_parameters[['color_variable']] + ) + output_data <- list( + x = cells_df[[1]], + y = cells_df[[2]], + color = color_input, + point_size = plot_parameters[["point_size"]], + point_opacity = plot_parameters[["point_opacity"]], + point_line = list() + ) + if ( plot_parameters[["draw_border"]] ) { + output_data[['point_line']] <- list( + color = "rgb(196,196,196)", + width = 1 + ) } - - ## 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 - ), - align = "left" - ) + output_hover <- list( + hoverinfo = ifelse(plot_parameters[["hover_info"]], 'text', 'skip'), + text = ifelse(plot_parameters[["hover_info"]], unname(hover_info), 'test') + ) + if ( plot_parameters[['n_dimensions']] == 2 ) { + shinyjs::js$updatePlot2DContinuous( + output_meta, + output_data, + output_hover ) - - ## ... 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[[ variable_to_color_cells ]]) ) { - plot <- plotly::plot_ly( - cells_df, - x = ~cells_df[,1], - y = ~cells_df[,2], - type = "scatter", - mode = "markers", - marker = list( - colorbar = list( - title = variable_to_color_cells - ), - color = ~cells_df[[ variable_to_color_cells ]], - opacity = overview_projection_inputs()[["point_opacity"]], - colorscale = "YlGnBu", - reversescale = TRUE, - line = line, - size = overview_projection_inputs()[["point_size"]] - ), - hoverinfo = parameter_hoverinfo, - text = parameter_text, - source = "overview_projection" + } else if ( plot_parameters[['n_dimensions']] == 3 ) { + output_data[['z']] <- cells_df[[3]] + shinyjs::js$updatePlot3DContinuous( + output_meta, + output_data, + output_hover ) - - ## ... selected coloring variable is not numeric - } else { - - plot <- plotly::plot_ly( - cells_df, - x = ~cells_df[,1], - y = ~cells_df[,2], - color = ~cells_df[[ variable_to_color_cells ]], - colors = colors_for_groups, - type = "scatter", - mode = "markers", - marker = list( - opacity = overview_projection_inputs()[["point_opacity"]], - line = line, - size = overview_projection_inputs()[["point_size"]] - ), - hoverinfo = parameter_hoverinfo, - text = parameter_text, - source = "overview_projection" + } + } else { + output_meta <- list( + color_type = 'categorical', + traces = list(), + color_variable = plot_parameters[['color_variable']] + ) + 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() + ) + if ( plot_parameters[["draw_border"]] ) { + output_data[['point_line']] <- list( + color = "rgb(196,196,196)", + width = 1 ) - - ## check if group labels should be plotted and, if so, add them - if ( overview_projection_inputs()[["group_labels"]] == TRUE ) { - - ## calculate group level centers - group_labels <- centerOfGroups(cells_df, 2, variable_to_color_cells) - - ## add group level labels at center of respective groups - plot <- plot %>% - plotly::add_trace( - data = group_labels, - x = ~x_median, - y = ~y_median, - type = 'scatter', - mode = 'text', - name = "Labels", - text = ~group, - textposition = 'middle center', - textfont = list( - color = '#000000', - size = 16 - ), - hoverinfo = "skip", - inherit = FALSE + } + output_hover <- list( + hoverinfo = ifelse(plot_parameters[["hover_info"]], 'text', 'skip'), + text = ifelse(plot_parameters[["hover_info"]], list(), 'test') + ) + 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]] <- cells_df[[1]][cells_to_extract] + output_data[['y']][[i]] <- cells_df[[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 } - } - - ## add layout to plot - plot <- plot %>% - plotly::layout( - xaxis = list( - title = colnames(cells_df)[1], - mirror = TRUE, - showline = TRUE, - zeroline = FALSE, - range = overview_projection_inputs()[["x_range"]] - ), - yaxis = list( - title = colnames(cells_df)[2], - mirror = TRUE, - showline = TRUE, - zeroline = FALSE, - range = overview_projection_inputs()[["y_range"]] - ), - hoverlabel = list( - font = list( - size = 11 - ), - align = "left" - ) + group_centers_df <- centerOfGroups(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]] <- cells_df[[1]][cells_to_extract] + output_data[['y']][[i]] <- cells_df[[2]][cells_to_extract] + output_data[['z']][[i]] <- cells_df[[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(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 ) - - ## return plot either with WebGL or without, depending on setting - if ( overview_projection_inputs()[["webgl"]] == TRUE ) { - plot %>% plotly::toWebGL() - } else { - plot } } -}) +} ##----------------------------------------------------------------------------## ## 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_inputs() + 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)) %>% @@ -753,25 +683,19 @@ overview_projection_selected_cells <- reactive({ ##----------------------------------------------------------------------------## ## 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) }) @@ -779,7 +703,6 @@ output[["overview_number_of_selected_cells"]] <- renderText({ ##----------------------------------------------------------------------------## ## Info box that gets shown when pressing the "info" button. ##----------------------------------------------------------------------------## - observeEvent(input[["overview_projection_info"]], { showModal( modalDialog( @@ -795,7 +718,6 @@ observeEvent(input[["overview_projection_info"]], { ##----------------------------------------------------------------------------## ## Text in info box. ##----------------------------------------------------------------------------## - overview_projection_info <- list( title = "Dimensional reduction", text = HTML(" @@ -815,18 +737,15 @@ overview_projection_info <- list( ##----------------------------------------------------------------------------## ## Export projection plot to PDF when pressing the "export to PDF" button. ##----------------------------------------------------------------------------## - observeEvent(input[["overview_projection_export"]], { - ## make sure plot parameters are set because it means that the plot can be ## generated - req( - overview_projection_inputs() - ) - + req(overview_projection_data_to_plot()) ## - parameters <- overview_projection_inputs() - + cells_df <- overview_projection_data_to_plot()[['cells_df']] + plot_parameters <- overview_projection_data_to_plot()[['plot_parameters']] + color_assignments <- overview_projection_data_to_plot()[['color_assignments']] + hover_info <- overview_projection_data_to_plot()[['hover_info']] ## open dialog to select where plot should be saved and how the file should ## be named shinyFiles::shinyFileSave( @@ -836,45 +755,22 @@ observeEvent(input[["overview_projection_export"]], { 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 - ) - + req(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 <- parameters[["projection"]] - variable_to_color_cells <- parameters[["color_variable"]] - + projection_to_display <- plot_parameters[["projection"]] + 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 ( ncol(getProjection(projection_to_display)) == 2 ) { - - ## 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, parameters[["pct_cells"]]) - - ## put rows in random order - cells_df <- cells_df[ sample(1:nrow(cells_df)) , ] - + if ( plot_parameters[['n_dimensions']] == 2 ) { ## - if ( parameters[["draw_border"]] == TRUE ) { - stroke <- 0.2 - } else { - stroke <- 0 - } - + stroke <- ifelse(plot_parameters[["draw_border"]], 0.2, 0) ## start building the plot plot <- ggplot( cells_df, @@ -886,36 +782,28 @@ observeEvent(input[["overview_projection_export"]], { ) + geom_point( shape = 21, - size = parameters[["point_size"]]/3, + size = plot_parameters[["point_size"]]/3, stroke = stroke, color = "#c4c4c4", - alpha = parameters[["point_opacity"]] + alpha = plot_parameters[["point_opacity"]] ) + lims( - x = parameters[["x_range"]], - y = parameters[["y_range"]] + 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 ]]) ) { - - ## get colors for groups - colors_for_groups <- assignColorsToGroups(cells_df, variable_to_color_cells) - ## add color assignments - plot <- plot + scale_fill_manual(values = colors_for_groups) - + plot <- plot + scale_fill_manual(values = color_assignments) ## check if group labels should be plotted and, if so, add them - if ( parameters[["group_labels"]] == TRUE ) { - + if ( plot_parameters[["group_labels"]] == TRUE ) { ## calculate group level centers group_labels <- centerOfGroups(cells_df, 2, variable_to_color_cells) - ## add group level labels at center of respective groups plot <- plot + geom_label( @@ -930,10 +818,8 @@ observeEvent(input[["overview_projection_export"]], { show.legend = FALSE ) } - ## ... not categorical (probably numerical) } else { - ## add continuous color scale plot <- plot + scale_fill_distiller( @@ -942,15 +828,12 @@ observeEvent(input[["overview_projection_export"]], { 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, @@ -958,10 +841,8 @@ observeEvent(input[["overview_projection_export"]], { text = paste0("Plot saved successfully as: ", save_file_path), type = "success" ) - ## ... failed } else { - ## give negative message shinyWidgets::sendSweetAlert( session = session, @@ -970,10 +851,8 @@ observeEvent(input[["overview_projection_export"]], { type = "error" ) } - ## ... selection projection consists of 3 dimensions - } else if ( ncol(getProjection(projection_to_display)) == 3 ) { - + } else if ( plot_parameters[['n_dimensions']] == 3 ) { ## give error message shinyWidgets::sendSweetAlert( session = session, diff --git a/inst/shiny/v1.3/overview/projection_update.js b/inst/shiny/v1.3/overview/projection_update.js new file mode 100644 index 0000000..88131a4 --- /dev/null +++ b/inst/shiny/v1.3/overview/projection_update.js @@ -0,0 +1,224 @@ +const layout = { + uirevision: 'true', + hovermode: 'closest', + margin: { + l: 50, + r: 50, + b: 50, + t: 50, + pad: 4 + }, + xaxis: { + autorange: true, + mirror: true, + showline: true, + zeroline: false + }, + yaxis: { + autorange: true, + mirror: true, + showline: true, + zeroline: false + }, + zaxis: { + autorange: true, + mirror: true, + showline: true, + zeroline: false + }, + hoverlabel: { + font: { + size: 11 + }, + align: 'left' + } +}; + +const defaultParams = { + meta: { + color_type: '', + traces: [], + color_variable: '' + }, + data: { + x: [], + y: [], + z: [], + color: [], + size: '', + opacity: '', + line: {} + }, + hover: { + hoverinfo: '', + text: [] + }, + group_centers: { + group: [], + x: [], + y: [], + z: [] + } +} + +shinyjs.updatePlot2DContinuous = function(params) { + params = shinyjs.getParams(params, defaultParams); + 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 + } + ); + Plotly.react('overview_projection', data, layout); +} + +shinyjs.updatePlot3DContinuous = function(params) { + params = shinyjs.getParams(params, defaultParams); + 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, layout); +} + + +shinyjs.updatePlot2DCategorical = function(params) { + params = shinyjs.getParams(params, defaultParams); + 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 + } + ); + } + Plotly.react('overview_projection', data, layout); +} + + +shinyjs.updatePlot3DCategorical = function(params) { + params = shinyjs.getParams(params, defaultParams); + 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, layout); +} + diff --git a/inst/shiny/v1.3/overview/selected_cells_plot.R b/inst/shiny/v1.3/overview/selected_cells_plot.R index d4cbe49..52104ae 100644 --- a/inst/shiny/v1.3/overview/selected_cells_plot.R +++ b/inst/shiny/v1.3/overview/selected_cells_plot.R @@ -37,13 +37,13 @@ output[["overview_selected_cells_plot_UI"]] <- renderUI({ output[["overview_details_selected_cells_plot"]] <- plotly::renderPlotly({ req( - overview_projection_inputs()[["projection"]], + overview_projection_parameters_plot()[["projection"]], input[["overview_selected_cells_plot_select_variable"]] ) ## extract cells to plot cells_df <- cbind( - getProjection(overview_projection_inputs()[["projection"]]), + getProjection(overview_projection_parameters_plot()[["projection"]]), getMetaData() ) diff --git a/inst/shiny/v1.3/overview/selected_cells_table.R b/inst/shiny/v1.3/overview/selected_cells_table.R index f78948e..1eab1f3 100644 --- a/inst/shiny/v1.3/overview/selected_cells_table.R +++ b/inst/shiny/v1.3/overview/selected_cells_table.R @@ -44,7 +44,7 @@ output[["overview_details_selected_cells_table"]] <- DT::renderDataTable(server ## don't proceed without these inputs req( - overview_projection_inputs() + overview_projection_parameters_plot() ) ## check selection @@ -61,9 +61,9 @@ output[["overview_details_selected_cells_table"]] <- DT::renderDataTable(server ## extract cells for table cells_df <- cbind( - getProjection(overview_projection_inputs()[["projection"]]), + getProjection(overview_projection_parameters_plot()[["projection"]]), getMetaData() - ) %>% + ) %>% as.data.frame() ## filter out non-selected cells with X-Y identifier diff --git a/inst/shiny/v1.3/utility_functions.R b/inst/shiny/v1.3/utility_functions.R index 658687a..c8f5145 100644 --- a/inst/shiny/v1.3/utility_functions.R +++ b/inst/shiny/v1.3/utility_functions.R @@ -659,16 +659,16 @@ buildHoverInfoForProjections <- function(table) { ## 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 ]]}" ) } @@ -770,8 +770,6 @@ getGenesForGeneSet <- function(gene_set) { ##----------------------------------------------------------------------------## ## Function to calculate center of groups in projections/trajectories. -## -## ##----------------------------------------------------------------------------## centerOfGroups <- function(df, n_dimensions, group) { @@ -971,7 +969,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() { From 91acfb6df8525b20c0f278ff93add13b90379a55 Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Sat, 9 Jan 2021 19:15:28 +0100 Subject: [PATCH 09/39] Load JS script to update projection. --- inst/shiny/v1.3/overview/UI.R | 2 ++ inst/shiny/v1.3/overview/projection.R | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/inst/shiny/v1.3/overview/UI.R b/inst/shiny/v1.3/overview/UI.R index 2410ca0..430c3bb 100644 --- a/inst/shiny/v1.3/overview/UI.R +++ b/inst/shiny/v1.3/overview/UI.R @@ -14,6 +14,8 @@ tab_overview <- tabItem( } " ), + shinyjs::useShinyjs(), + shinyjs::extendShinyjs(script = paste0(Cerebro.options[["cerebro_root"]], "/shiny/v1.3/overview/projection_update.js")), uiOutput("overview_projection_UI"), uiOutput("overview_selected_cells_plot_UI"), uiOutput("overview_selected_cells_table_UI") diff --git a/inst/shiny/v1.3/overview/projection.R b/inst/shiny/v1.3/overview/projection.R index 7305205..1d7e40a 100644 --- a/inst/shiny/v1.3/overview/projection.R +++ b/inst/shiny/v1.3/overview/projection.R @@ -297,7 +297,7 @@ output[["overview_projection_show_group_label_UI"]] <- renderUI({ if ( input[["overview_projection_point_color"]] %in% getGroups() ) { shinyWidgets::awesomeCheckbox( inputId = "overview_projection_show_group_label", - label = "Plot group labels in exported PDF", + label = "Show group labels in projection", value = TRUE ) } From 14afada38309ad210f2ed34229fbcf40f8c19975 Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Sat, 9 Jan 2021 19:23:58 +0100 Subject: [PATCH 10/39] Update label for group label button. --- inst/shiny/v1.3/overview/projection.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/inst/shiny/v1.3/overview/projection.R b/inst/shiny/v1.3/overview/projection.R index 1d7e40a..7305205 100644 --- a/inst/shiny/v1.3/overview/projection.R +++ b/inst/shiny/v1.3/overview/projection.R @@ -297,7 +297,7 @@ output[["overview_projection_show_group_label_UI"]] <- renderUI({ if ( input[["overview_projection_point_color"]] %in% getGroups() ) { shinyWidgets::awesomeCheckbox( inputId = "overview_projection_show_group_label", - label = "Show group labels in projection", + label = "Plot group labels in exported PDF", value = TRUE ) } From 4ece92b5f65de8e4a1501c06ea335a4833c217d4 Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Sat, 9 Jan 2021 23:50:08 +0100 Subject: [PATCH 11/39] Implement manual ranges for X and Y axes. --- inst/shiny/v1.3/overview/projection.R | 8 +++++-- inst/shiny/v1.3/overview/projection_update.js | 24 +++++++++++++++---- 2 files changed, 25 insertions(+), 7 deletions(-) diff --git a/inst/shiny/v1.3/overview/projection.R b/inst/shiny/v1.3/overview/projection.R index 7305205..f7b833b 100644 --- a/inst/shiny/v1.3/overview/projection.R +++ b/inst/shiny/v1.3/overview/projection.R @@ -539,7 +539,9 @@ overview_projection_update_plot <- function(input) { color = color_input, point_size = plot_parameters[["point_size"]], point_opacity = plot_parameters[["point_opacity"]], - point_line = list() + point_line = list(), + x_range = plot_parameters[["x_range"]], + y_range = plot_parameters[["y_range"]] ) if ( plot_parameters[["draw_border"]] ) { output_data[['point_line']] <- list( @@ -578,7 +580,9 @@ overview_projection_update_plot <- function(input) { color = list(), point_size = plot_parameters[["point_size"]], point_opacity = plot_parameters[["point_opacity"]], - point_line = list() + point_line = list(), + x_range = plot_parameters[["x_range"]], + y_range = plot_parameters[["y_range"]] ) if ( plot_parameters[["draw_border"]] ) { output_data[['point_line']] <- list( diff --git a/inst/shiny/v1.3/overview/projection_update.js b/inst/shiny/v1.3/overview/projection_update.js index 88131a4..3818af4 100644 --- a/inst/shiny/v1.3/overview/projection_update.js +++ b/inst/shiny/v1.3/overview/projection_update.js @@ -12,13 +12,15 @@ const layout = { autorange: true, mirror: true, showline: true, - zeroline: false + zeroline: false, + range: [] }, yaxis: { autorange: true, mirror: true, showline: true, - zeroline: false + zeroline: false, + range: [] }, zaxis: { autorange: true, @@ -47,7 +49,9 @@ const defaultParams = { color: [], size: '', opacity: '', - line: {} + line: {}, + x_range: [], + y_range: [] }, hover: { hoverinfo: '', @@ -88,7 +92,12 @@ shinyjs.updatePlot2DContinuous = function(params) { showlegend: false } ); - Plotly.react('overview_projection', data, layout); + let layout_here = Object.assign(layout); + 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); } shinyjs.updatePlot3DContinuous = function(params) { @@ -168,7 +177,12 @@ shinyjs.updatePlot2DCategorical = function(params) { } ); } - Plotly.react('overview_projection', data, layout); + let layout_here = Object.assign(layout); + 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); } From 07987d9cc1635221aa2dc2d70fabe87090f3c459 Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Sat, 9 Jan 2021 23:50:30 +0100 Subject: [PATCH 12/39] Fix hover info for continuous data. --- inst/shiny/v1.3/overview/projection.R | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/inst/shiny/v1.3/overview/projection.R b/inst/shiny/v1.3/overview/projection.R index f7b833b..8aaee7e 100644 --- a/inst/shiny/v1.3/overview/projection.R +++ b/inst/shiny/v1.3/overview/projection.R @@ -551,8 +551,11 @@ overview_projection_update_plot <- function(input) { } output_hover <- list( hoverinfo = ifelse(plot_parameters[["hover_info"]], 'text', 'skip'), - text = ifelse(plot_parameters[["hover_info"]], unname(hover_info), 'test') + text = 'empty' ) + if ( plot_parameters[["hover_info"]] ) { + output_hover[['text']] <- unname(hover_info) + } if ( plot_parameters[['n_dimensions']] == 2 ) { shinyjs::js$updatePlot2DContinuous( output_meta, From 0fad0f5983cf75f9c0d23afdea86a8b223eb66fa Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Sun, 10 Jan 2021 00:10:54 +0100 Subject: [PATCH 13/39] Make code more compact by removing empty lines. --- inst/shiny/v1.3/overview/UI.R | 1 - .../shiny/v1.3/overview/selected_cells_plot.R | 30 ------------------- .../v1.3/overview/selected_cells_table.R | 18 +---------- inst/shiny/v1.3/overview/server.R | 1 - 4 files changed, 1 insertion(+), 49 deletions(-) diff --git a/inst/shiny/v1.3/overview/UI.R b/inst/shiny/v1.3/overview/UI.R index 430c3bb..0179d7a 100644 --- a/inst/shiny/v1.3/overview/UI.R +++ b/inst/shiny/v1.3/overview/UI.R @@ -1,7 +1,6 @@ ##----------------------------------------------------------------------------## ## Tab: Overview ##----------------------------------------------------------------------------## - tab_overview <- tabItem( tabName = "overview", ## necessary to ensure alignment of table headers and content diff --git a/inst/shiny/v1.3/overview/selected_cells_plot.R b/inst/shiny/v1.3/overview/selected_cells_plot.R index 52104ae..34f5b1d 100644 --- a/inst/shiny/v1.3/overview/selected_cells_plot.R +++ b/inst/shiny/v1.3/overview/selected_cells_plot.R @@ -7,7 +7,6 @@ ##----------------------------------------------------------------------------## ## UI element for output. ##----------------------------------------------------------------------------## - output[["overview_selected_cells_plot_UI"]] <- renderUI({ fluidRow( cerebroBox( @@ -33,31 +32,24 @@ output[["overview_selected_cells_plot_UI"]] <- renderUI({ ## - if categorical: number of cells in each group ## - if numerical: box/violin plot ##----------------------------------------------------------------------------## - output[["overview_details_selected_cells_plot"]] <- plotly::renderPlotly({ - req( overview_projection_parameters_plot()[["projection"]], input[["overview_selected_cells_plot_select_variable"]] ) - ## extract cells to plot cells_df <- cbind( getProjection(overview_projection_parameters_plot()[["projection"]]), 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') - ## ... selection has been made and at least 1 cell is in it } else { - ## cells_df <- cells_df %>% dplyr::rename(X1 = 1, X2 = 2) %>% @@ -67,48 +59,37 @@ output[["overview_details_selected_cells_plot"]] <- plotly::renderPlotly({ 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, @@ -116,14 +97,11 @@ output[["overview_details_selected_cells_plot"]] <- plotly::renderPlotly({ ) %>% dplyr::rename(!!color_variable := group) } - ## 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, @@ -136,16 +114,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, @@ -170,10 +144,8 @@ output[["overview_details_selected_cells_plot"]] <- plotly::renderPlotly({ size = 5 ) ) - y_axis_title <- colnames(cells_df)[2] } - plot %>% plotly::layout( title = "", @@ -196,7 +168,6 @@ output[["overview_details_selected_cells_plot"]] <- plotly::renderPlotly({ ##----------------------------------------------------------------------------## ## Info box that gets shown when pressing the "info" button. ##----------------------------------------------------------------------------## - observeEvent(input[["overview_details_selected_cells_plot_info"]], { showModal( modalDialog( @@ -212,7 +183,6 @@ observeEvent(input[["overview_details_selected_cells_plot_info"]], { ##----------------------------------------------------------------------------## ## 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/selected_cells_table.R index 1eab1f3..4a43eb2 100644 --- a/inst/shiny/v1.3/overview/selected_cells_table.R +++ b/inst/shiny/v1.3/overview/selected_cells_table.R @@ -7,7 +7,6 @@ ##----------------------------------------------------------------------------## ## UI element for output. ##----------------------------------------------------------------------------## - output[["overview_selected_cells_table_UI"]] <- renderUI({ fluidRow( cerebroBox( @@ -39,33 +38,24 @@ 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( - overview_projection_parameters_plot() - ) - + req(overview_projection_parameters_plot()) ## 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(overview_projection_parameters_plot()[["projection"]]), getMetaData() ) %>% as.data.frame() - ## filter out non-selected cells with X-Y identifier cells_df <- cells_df %>% dplyr::rename(X1 = 1, X2 = 2) %>% @@ -73,19 +63,15 @@ output[["overview_details_selected_cells_table"]] <- DT::renderDataTable(server 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, @@ -104,7 +90,6 @@ output[["overview_details_selected_cells_table"]] <- DT::renderDataTable(server ##----------------------------------------------------------------------------## ## Info box that gets shown when pressing the "info" button. ##----------------------------------------------------------------------------## - observeEvent(input[["overview_details_selected_cells_table_info"]], { showModal( modalDialog( @@ -120,7 +105,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/server.R b/inst/shiny/v1.3/overview/server.R index b0ab8fa..934377d 100644 --- a/inst/shiny/v1.3/overview/server.R +++ b/inst/shiny/v1.3/overview/server.R @@ -1,7 +1,6 @@ ##----------------------------------------------------------------------------## ## Tab: Overview ##----------------------------------------------------------------------------## - 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) From 097fe0fca9058292e8917e0d3233550463bc9292 Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Sun, 10 Jan 2021 00:51:50 +0100 Subject: [PATCH 14/39] Split code into different files and group them by type of object. --- inst/shiny/v1.3/overview/UI.R | 2 +- inst/shiny/v1.3/overview/projection.R | 913 ------------------ inst/shiny/v1.3/overview/projection_update.js | 238 ----- .../shiny/v1.3/overview/selected_cells_plot.R | 189 ---- .../v1.3/overview/selected_cells_table.R | 122 --- inst/shiny/v1.3/overview/server.R | 13 +- 6 files changed, 11 insertions(+), 1466 deletions(-) delete mode 100644 inst/shiny/v1.3/overview/projection.R delete mode 100644 inst/shiny/v1.3/overview/projection_update.js delete mode 100644 inst/shiny/v1.3/overview/selected_cells_plot.R delete mode 100644 inst/shiny/v1.3/overview/selected_cells_table.R diff --git a/inst/shiny/v1.3/overview/UI.R b/inst/shiny/v1.3/overview/UI.R index 0179d7a..e31efb0 100644 --- a/inst/shiny/v1.3/overview/UI.R +++ b/inst/shiny/v1.3/overview/UI.R @@ -14,7 +14,7 @@ tab_overview <- tabItem( " ), shinyjs::useShinyjs(), - shinyjs::extendShinyjs(script = paste0(Cerebro.options[["cerebro_root"]], "/shiny/v1.3/overview/projection_update.js")), + shinyjs::extendShinyjs(script = paste0(Cerebro.options[["cerebro_root"]], "/shiny/v1.3/overview/js_overview_projection_update_plot.js")), uiOutput("overview_projection_UI"), uiOutput("overview_selected_cells_plot_UI"), uiOutput("overview_selected_cells_table_UI") diff --git a/inst/shiny/v1.3/overview/projection.R b/inst/shiny/v1.3/overview/projection.R deleted file mode 100644 index 8aaee7e..0000000 --- a/inst/shiny/v1.3/overview/projection.R +++ /dev/null @@ -1,913 +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_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"), - ) - ) - ) - ) -}) - -##----------------------------------------------------------------------------## -## 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.
    • -
    - " - ) -) - -##----------------------------------------------------------------------------## -## 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 = 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_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( - "overview_projection_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 -}) - -## 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. - " - ) -) - -##----------------------------------------------------------------------------## -## 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 -) - -##----------------------------------------------------------------------------## -## 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 -) - -##----------------------------------------------------------------------------## -## 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"]]) - ) { - 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 -) - -##----------------------------------------------------------------------------## -## Collect parameters for projection plot. -##----------------------------------------------------------------------------## -overview_projection_parameters_plot_raw <- reactive({ - ## require input UI elements - req( - input[["overview_projection_to_display"]], - input[["overview_projection_point_color"]], - 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"]]) - ) - ## collect parameters - 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"]] - ) - ## return parameters - return(parameters) -}) - -overview_projection_parameters_plot <- debounce(overview_projection_parameters_plot_raw, 1) - -##----------------------------------------------------------------------------## -## Color assignments. -##----------------------------------------------------------------------------## -overview_projection_color_assignments <- reactive({ - req( - overview_projection_data(), - overview_projection_parameters_plot() - ) - return( - assignColorsToGroups( - overview_projection_data(), - overview_projection_parameters_plot()['color_variable'] - ) - ) -}) - -##----------------------------------------------------------------------------## -## Input parameters for filtering cells. -##----------------------------------------------------------------------------## -overview_projection_parameters_cell_filtering_raw <- reactive({ - req( - input[["overview_projection_to_display"]], - input[["overview_projection_percentage_cells_to_show"]] - ) - ## require group filters UI elements and at least 1 group level to be selected - for ( i in getGroups() ) { - req(input[[paste0("overview_projection_group_filter_", i)]]) - } - parameters <- list( - projection = input[["overview_projection_to_display"]], - pct_cells = input[["overview_projection_percentage_cells_to_show"]], - group_filters = list() - ) - ## store group filters - for ( i in getGroups() ) { - parameters[['group_filters']][[ i ]] <- input[[paste0("overview_projection_group_filter_", i)]] - } - return(parameters) -}) - -overview_projection_parameters_cell_filtering <- debounce(overview_projection_parameters_cell_filtering_raw, 1) - -##----------------------------------------------------------------------------## -## Cell meta data and position in projection. -##----------------------------------------------------------------------------## -overview_projection_data <- reactive({ - req(overview_projection_parameters_cell_filtering()) - parameters <- overview_projection_parameters_cell_filtering() - cells_df <- cbind(getProjection(parameters[["projection"]]), getMetaData()) - ## remove cells based on group filters - 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% parameters[["group_filters"]][[ i ]] ),] - } - } - ## randomly remove cells (if necessary) - cells_df <- randomlySubsetCells(cells_df, parameters[["pct_cells"]]) - ## put rows in random order - cells_df <- cells_df[ sample(1:nrow(cells_df)) , ] - return(cells_df) -}) - -##----------------------------------------------------------------------------## -## Hover info. -##----------------------------------------------------------------------------## -overview_projection_hover_info <- reactive({ - req(overview_projection_data()) - cells_df <- overview_projection_data() - hover_info <- buildHoverInfoForProjections(cells_df) - hover_info <- setNames(hover_info, cells_df$cell_barcode) - return(hover_info) -}) - -##----------------------------------------------------------------------------## -## Plotly plot of the selected projection. -##----------------------------------------------------------------------------## -output[["overview_projection"]] <- plotly::renderPlotly({ - plot_ly(type = 'scattergl', mode = 'markers', source = "overview_projection") -}) - -## -overview_projection_data_to_plot <- reactive({ - req( - overview_projection_data(), - overview_projection_parameters_plot(), - reactive_colors(), - overview_projection_hover_info() - ) - 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']] - ) - } - list( - cells_df = overview_projection_data(), - plot_parameters = overview_projection_parameters_plot(), - color_assignments = color_assignments, - hover_info = overview_projection_hover_info() - ) -}) - -## -observeEvent(overview_projection_data_to_plot(), { - req(overview_projection_data_to_plot()) - overview_projection_update_plot(overview_projection_data_to_plot()) -}) - -## function to be executed to update figure -overview_projection_update_plot <- function(input) { - cells_df <- input[['cells_df']] - plot_parameters <- input[['plot_parameters']] - color_assignments <- input[['color_assignments']] - hover_info <- input[['hover_info']] - color_input <- cells_df[[ plot_parameters[['color_variable']] ]] - if ( is.numeric(color_input) ) { - output_meta <- list( - color_type = 'continuous', - traces = plot_parameters[['color_variable']], - color_variable = plot_parameters[['color_variable']] - ) - output_data <- list( - x = cells_df[[1]], - y = cells_df[[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"]] - ) - if ( plot_parameters[["draw_border"]] ) { - output_data[['point_line']] <- list( - color = "rgb(196,196,196)", - width = 1 - ) - } - output_hover <- list( - hoverinfo = ifelse(plot_parameters[["hover_info"]], 'text', 'skip'), - text = 'empty' - ) - if ( plot_parameters[["hover_info"]] ) { - output_hover[['text']] <- unname(hover_info) - } - 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']] <- cells_df[[3]] - shinyjs::js$updatePlot3DContinuous( - output_meta, - output_data, - output_hover - ) - } - } else { - output_meta <- list( - color_type = 'categorical', - traces = list(), - color_variable = plot_parameters[['color_variable']] - ) - 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"]] - ) - if ( plot_parameters[["draw_border"]] ) { - output_data[['point_line']] <- list( - color = "rgb(196,196,196)", - width = 1 - ) - } - output_hover <- list( - hoverinfo = ifelse(plot_parameters[["hover_info"]], 'text', 'skip'), - text = ifelse(plot_parameters[["hover_info"]], list(), 'test') - ) - 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]] <- cells_df[[1]][cells_to_extract] - output_data[['y']][[i]] <- cells_df[[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(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]] <- cells_df[[1]][cells_to_extract] - output_data[['y']][[i]] <- cells_df[[2]][cells_to_extract] - output_data[['z']][[i]] <- cells_df[[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(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 - ) - } - } -} - -##----------------------------------------------------------------------------## -## 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() - } -}) - -##----------------------------------------------------------------------------## -## 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) -}) - -##----------------------------------------------------------------------------## -## 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"]], { - ## make sure plot parameters are set because it means that the plot can be - ## generated - req(overview_projection_data_to_plot()) - ## - cells_df <- overview_projection_data_to_plot()[['cells_df']] - plot_parameters <- overview_projection_data_to_plot()[['plot_parameters']] - color_assignments <- overview_projection_data_to_plot()[['color_assignments']] - hover_info <- overview_projection_data_to_plot()[['hover_info']] - ## 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) - ## 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 <- plot_parameters[["projection"]] - 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( - cells_df, - aes_q( - x = as.name(colnames(cells_df)[1]), - y = as.name(colnames(cells_df)[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(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" - ) - } -}) - -##----------------------------------------------------------------------------## -## 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/projection_update.js b/inst/shiny/v1.3/overview/projection_update.js deleted file mode 100644 index 3818af4..0000000 --- a/inst/shiny/v1.3/overview/projection_update.js +++ /dev/null @@ -1,238 +0,0 @@ -const layout = { - 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: [] - }, - zaxis: { - autorange: true, - mirror: true, - showline: true, - zeroline: false - }, - hoverlabel: { - font: { - size: 11 - }, - align: 'left' - } -}; - -const defaultParams = { - meta: { - color_type: '', - traces: [], - color_variable: '' - }, - data: { - x: [], - y: [], - z: [], - color: [], - size: '', - opacity: '', - line: {}, - x_range: [], - y_range: [] - }, - hover: { - hoverinfo: '', - text: [] - }, - group_centers: { - group: [], - x: [], - y: [], - z: [] - } -} - -shinyjs.updatePlot2DContinuous = function(params) { - params = shinyjs.getParams(params, defaultParams); - 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 - } - ); - let layout_here = Object.assign(layout); - 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); -} - -shinyjs.updatePlot3DContinuous = function(params) { - params = shinyjs.getParams(params, defaultParams); - 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, layout); -} - - -shinyjs.updatePlot2DCategorical = function(params) { - params = shinyjs.getParams(params, defaultParams); - 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 - } - ); - } - let layout_here = Object.assign(layout); - 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); -} - - -shinyjs.updatePlot3DCategorical = function(params) { - params = shinyjs.getParams(params, defaultParams); - 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, layout); -} - diff --git a/inst/shiny/v1.3/overview/selected_cells_plot.R b/inst/shiny/v1.3/overview/selected_cells_plot.R deleted file mode 100644 index 34f5b1d..0000000 --- a/inst/shiny/v1.3/overview/selected_cells_plot.R +++ /dev/null @@ -1,189 +0,0 @@ -##----------------------------------------------------------------------------## -## 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( - overview_projection_parameters_plot()[["projection"]], - input[["overview_selected_cells_plot_select_variable"]] - ) - ## extract cells to plot - cells_df <- cbind( - getProjection(overview_projection_parameters_plot()[["projection"]]), - 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') - ## ... selection has been made and at least 1 cell is in it - } else { - ## - cells_df <- cells_df %>% - dplyr::rename(X1 = 1, X2 = 2) %>% - dplyr::mutate( - identifier = paste0(X1, '-', X2), - 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, - n = 0 - ) %>% - dplyr::rename(!!color_variable := group) - } - ## 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, - x = ~cells_df[[1]], - y = ~cells_df[[2]], - type = "bar", - color = ~cells_df[[1]], - colors = colors_for_groups, - source = "subset", - 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, - x = ~cells_df[[ 'group' ]], - y = ~cells_df[[ color_variable ]], - type = "violin", - box = list( - visible = TRUE - ), - meanline = list( - visible = TRUE - ), - color = ~cells_df[[1]], - colors = setNames( - c('#e74c3c','#7f8c8d'), - c('selected', 'not selected') - ), - source = "subset", - showlegend = FALSE, - hoverinfo = "y", - marker = list( - size = 5 - ) - ) - y_axis_title <- colnames(cells_df)[2] - } - plot %>% - plotly::layout( - title = "", - xaxis = list( - title = "", - mirror = TRUE, - showline = TRUE - ), - yaxis = list( - title = y_axis_title, - hoverformat = ".0f", - mirror = TRUE, - showline = TRUE - ), - dragmode = "select", - 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/selected_cells_table.R b/inst/shiny/v1.3/overview/selected_cells_table.R deleted file mode 100644 index 4a43eb2..0000000 --- a/inst/shiny/v1.3/overview/selected_cells_table.R +++ /dev/null @@ -1,122 +0,0 @@ -##----------------------------------------------------------------------------## -## Tab: Overview -## -## Table of selected cells. -##----------------------------------------------------------------------------## - -##----------------------------------------------------------------------------## -## UI element for output. -##----------------------------------------------------------------------------## -output[["overview_selected_cells_table_UI"]] <- renderUI({ - fluidRow( - cerebroBox( - title = tagList( - boxTitle("Table of selected cells"), - cerebroInfoButton("overview_details_selected_cells_table_info") - ), - tagList( - shinyWidgets::materialSwitch( - inputId = "overview_details_selected_cells_table_number_formatting", - label = "Automatically format numbers:", - value = TRUE, - status = "primary", - inline = TRUE - ), - shinyWidgets::materialSwitch( - inputId = "overview_details_selected_cells_table_color_highlighting", - label = "Highlight values with colors:", - value = TRUE, - status = "primary", - inline = TRUE - ), - DT::dataTableOutput("overview_details_selected_cells_table") - ) - ) - ) -}) - -##----------------------------------------------------------------------------## -## Table. -##----------------------------------------------------------------------------## -output[["overview_details_selected_cells_table"]] <- DT::renderDataTable(server = FALSE, { - ## don't proceed without these inputs - req(overview_projection_parameters_plot()) - ## 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(overview_projection_parameters_plot()[["projection"]]), - 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" - ) - } - } -}) - -##----------------------------------------------------------------------------## -## Info box that gets shown when pressing the "info" button. -##----------------------------------------------------------------------------## -observeEvent(input[["overview_details_selected_cells_table_info"]], { - showModal( - modalDialog( - overview_details_selected_cells_table_info$text, - title = overview_details_selected_cells_table_info$title, - easyClose = TRUE, - footer = NULL, - size = "l" - ) - ) -}) - -##----------------------------------------------------------------------------## -## Text in info box. -##----------------------------------------------------------------------------## -overview_details_selected_cells_table_info <- list( - title = "Details of selected cells", - text = HTML(" - Table containing meta data (some columns may be hidden, check the 'Column visibility' button) for cells selected in the plot using the box or lasso selection tool. If you want the table to contain all cells in the data set, you must select all cells in the plot. The table can be saved to disk in CSV or Excel format for further analysis. -

    Options

    - Automatically format numbers
    - When activated, columns in the table that contain different types of numeric values will be formatted based on what they seem to be. The algorithm will look for integers (no decimal values), percentages, p-values, log-fold changes and apply different formatting schemes to each of them. Importantly, this process does that always work perfectly. If it fails and hinders working with the table, automatic formatting can be deactivated.
    - This feature does not work on columns that contain 'NA' values.
    - Highlight values with colors
    - Similar to the automatic formatting option, when activated, Cerebro will look for known columns in the table (those that contain grouping variables), try to interpret column content, and use colors and other stylistic elements to facilitate quick interpretation of the values. If you prefer the table without colors and/or the identification does not work properly, you can simply deactivate this feature.
    - This feature does not work on columns that contain 'NA' values.
    -
    - Columns can be re-ordered by dragging their respective header." - ) -) diff --git a/inst/shiny/v1.3/overview/server.R b/inst/shiny/v1.3/overview/server.R index 934377d..87ef05f 100644 --- a/inst/shiny/v1.3/overview/server.R +++ b/inst/shiny/v1.3/overview/server.R @@ -1,6 +1,13 @@ ##----------------------------------------------------------------------------## ## Tab: Overview ##----------------------------------------------------------------------------## -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) + +files_to_load <- list.files( + paste0(Cerebro.options[["cerebro_root"]], "/shiny/v1.3/overview"), + pattern = "func_|obj_|UI_|out_|event_", + full.names = TRUE +) + +for ( i in files_to_load ) { + source(i, local = TRUE) +} From c1abf68429f5c22a7933bdf93be893de9a690a4b Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Sun, 10 Jan 2021 00:57:26 +0100 Subject: [PATCH 15/39] Split code into different files and group them by type of object. --- .../v1.3/overview/UI_overview_projection.R | 104 ++++++++ ...verview_projection_additional_parameters.R | 70 ++++++ .../UI_overview_projection_group_filters.R | 94 +++++++ .../UI_overview_projection_main_parameters.R | 46 ++++ .../UI_overview_projection_point_border.R | 17 ++ .../overview/UI_overview_projection_scales.R | 40 +++ .../UI_overview_projection_show_group_label.R | 20 ++ .../UI_overview_selected_cells_plot.R | 44 ++++ .../UI_overview_selected_cells_table.R | 64 +++++ .../event_overview_projection_export_plot.R | 128 ++++++++++ .../event_overview_projection_update_plot.R | 5 + .../func_overview_projection_update_plot.R | 140 +++++++++++ .../js_overview_projection_update_plot.js | 238 ++++++++++++++++++ ...bj_overview_projection_color_assignments.R | 15 ++ .../overview/obj_overview_projection_data.R | 21 ++ .../obj_overview_projection_data_to_plot.R | 23 ++ .../obj_overview_projection_hover_info.R | 10 + ...iew_projection_parameters_cell_filtering.R | 25 ++ .../obj_overview_projection_parameters_plot.R | 32 +++ .../obj_overview_projection_selected_cells.R | 23 ++ ...out_overview_details_selected_cells_plot.R | 138 ++++++++++ ...ut_overview_details_selected_cells_table.R | 51 ++++ .../out_overview_number_of_selected_cells.R | 19 ++ .../v1.3/overview/out_overview_projection.R | 40 +++ 24 files changed, 1407 insertions(+) create mode 100644 inst/shiny/v1.3/overview/UI_overview_projection.R create mode 100644 inst/shiny/v1.3/overview/UI_overview_projection_additional_parameters.R create mode 100644 inst/shiny/v1.3/overview/UI_overview_projection_group_filters.R create mode 100644 inst/shiny/v1.3/overview/UI_overview_projection_main_parameters.R create mode 100644 inst/shiny/v1.3/overview/UI_overview_projection_point_border.R create mode 100644 inst/shiny/v1.3/overview/UI_overview_projection_scales.R create mode 100644 inst/shiny/v1.3/overview/UI_overview_projection_show_group_label.R create mode 100644 inst/shiny/v1.3/overview/UI_overview_selected_cells_plot.R create mode 100644 inst/shiny/v1.3/overview/UI_overview_selected_cells_table.R create mode 100644 inst/shiny/v1.3/overview/event_overview_projection_export_plot.R create mode 100644 inst/shiny/v1.3/overview/event_overview_projection_update_plot.R create mode 100644 inst/shiny/v1.3/overview/func_overview_projection_update_plot.R create mode 100644 inst/shiny/v1.3/overview/js_overview_projection_update_plot.js create mode 100644 inst/shiny/v1.3/overview/obj_overview_projection_color_assignments.R create mode 100644 inst/shiny/v1.3/overview/obj_overview_projection_data.R create mode 100644 inst/shiny/v1.3/overview/obj_overview_projection_data_to_plot.R create mode 100644 inst/shiny/v1.3/overview/obj_overview_projection_hover_info.R create mode 100644 inst/shiny/v1.3/overview/obj_overview_projection_parameters_cell_filtering.R create mode 100644 inst/shiny/v1.3/overview/obj_overview_projection_parameters_plot.R create mode 100644 inst/shiny/v1.3/overview/obj_overview_projection_selected_cells.R create mode 100644 inst/shiny/v1.3/overview/out_overview_details_selected_cells_plot.R create mode 100644 inst/shiny/v1.3/overview/out_overview_details_selected_cells_table.R create mode 100644 inst/shiny/v1.3/overview/out_overview_number_of_selected_cells.R create mode 100644 inst/shiny/v1.3/overview/out_overview_projection.R diff --git a/inst/shiny/v1.3/overview/UI_overview_projection.R b/inst/shiny/v1.3/overview/UI_overview_projection.R new file mode 100644 index 0000000..0499050 --- /dev/null +++ b/inst/shiny/v1.3/overview/UI_overview_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_overview_projection_additional_parameters.R b/inst/shiny/v1.3/overview/UI_overview_projection_additional_parameters.R new file mode 100644 index 0000000..46feb82 --- /dev/null +++ b/inst/shiny/v1.3/overview/UI_overview_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 = 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_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( + "overview_projection_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.
    • +
    + " + ) +) diff --git a/inst/shiny/v1.3/overview/UI_overview_projection_group_filters.R b/inst/shiny/v1.3/overview/UI_overview_projection_group_filters.R new file mode 100644 index 0000000..c638f7c --- /dev/null +++ b/inst/shiny/v1.3/overview/UI_overview_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_overview_projection_main_parameters.R b/inst/shiny/v1.3/overview/UI_overview_projection_main_parameters.R new file mode 100644 index 0000000..d485122 --- /dev/null +++ b/inst/shiny/v1.3/overview/UI_overview_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_overview_projection_point_border.R b/inst/shiny/v1.3/overview/UI_overview_projection_point_border.R new file mode 100644 index 0000000..e5972fc --- /dev/null +++ b/inst/shiny/v1.3/overview/UI_overview_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_overview_projection_scales.R b/inst/shiny/v1.3/overview/UI_overview_projection_scales.R new file mode 100644 index 0000000..7e8e80f --- /dev/null +++ b/inst/shiny/v1.3/overview/UI_overview_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"]]) + ) { + 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_overview_projection_show_group_label.R b/inst/shiny/v1.3/overview/UI_overview_projection_show_group_label.R new file mode 100644 index 0000000..1845d5c --- /dev/null +++ b/inst/shiny/v1.3/overview/UI_overview_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_overview_selected_cells_plot.R b/inst/shiny/v1.3/overview/UI_overview_selected_cells_plot.R new file mode 100644 index 0000000..2efaeb6 --- /dev/null +++ b/inst/shiny/v1.3/overview/UI_overview_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/UI_overview_selected_cells_table.R b/inst/shiny/v1.3/overview/UI_overview_selected_cells_table.R new file mode 100644 index 0000000..d6a50cf --- /dev/null +++ b/inst/shiny/v1.3/overview/UI_overview_selected_cells_table.R @@ -0,0 +1,64 @@ +##----------------------------------------------------------------------------## +## UI element for output. +##----------------------------------------------------------------------------## +output[["overview_selected_cells_table_UI"]] <- renderUI({ + fluidRow( + cerebroBox( + title = tagList( + boxTitle("Table of selected cells"), + cerebroInfoButton("overview_details_selected_cells_table_info") + ), + tagList( + shinyWidgets::materialSwitch( + inputId = "overview_details_selected_cells_table_number_formatting", + label = "Automatically format numbers:", + value = TRUE, + status = "primary", + inline = TRUE + ), + shinyWidgets::materialSwitch( + inputId = "overview_details_selected_cells_table_color_highlighting", + label = "Highlight values with colors:", + value = TRUE, + status = "primary", + inline = TRUE + ), + DT::dataTableOutput("overview_details_selected_cells_table") + ) + ) + ) +}) + +##----------------------------------------------------------------------------## +## Info box that gets shown when pressing the "info" button. +##----------------------------------------------------------------------------## +observeEvent(input[["overview_details_selected_cells_table_info"]], { + showModal( + modalDialog( + overview_details_selected_cells_table_info$text, + title = overview_details_selected_cells_table_info$title, + easyClose = TRUE, + footer = NULL, + size = "l" + ) + ) +}) + +##----------------------------------------------------------------------------## +## Text in info box. +##----------------------------------------------------------------------------## +overview_details_selected_cells_table_info <- list( + title = "Details of selected cells", + text = HTML(" + Table containing meta data (some columns may be hidden, check the 'Column visibility' button) for cells selected in the plot using the box or lasso selection tool. If you want the table to contain all cells in the data set, you must select all cells in the plot. The table can be saved to disk in CSV or Excel format for further analysis. +

    Options

    + Automatically format numbers
    + When activated, columns in the table that contain different types of numeric values will be formatted based on what they seem to be. The algorithm will look for integers (no decimal values), percentages, p-values, log-fold changes and apply different formatting schemes to each of them. Importantly, this process does that always work perfectly. If it fails and hinders working with the table, automatic formatting can be deactivated.
    + This feature does not work on columns that contain 'NA' values.
    + Highlight values with colors
    + Similar to the automatic formatting option, when activated, Cerebro will look for known columns in the table (those that contain grouping variables), try to interpret column content, and use colors and other stylistic elements to facilitate quick interpretation of the values. If you prefer the table without colors and/or the identification does not work properly, you can simply deactivate this feature.
    + This feature does not work on columns that contain 'NA' values.
    +
    + Columns can be re-ordered by dragging their respective header." + ) +) diff --git a/inst/shiny/v1.3/overview/event_overview_projection_export_plot.R b/inst/shiny/v1.3/overview/event_overview_projection_export_plot.R new file mode 100644 index 0000000..7f10230 --- /dev/null +++ b/inst/shiny/v1.3/overview/event_overview_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"]], { + ## make sure plot parameters are set because it means that the plot can be + ## generated + req(overview_projection_data_to_plot()) + ## + cells_df <- overview_projection_data_to_plot()[['cells_df']] + plot_parameters <- overview_projection_data_to_plot()[['plot_parameters']] + color_assignments <- overview_projection_data_to_plot()[['color_assignments']] + hover_info <- overview_projection_data_to_plot()[['hover_info']] + ## 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) + ## 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 <- plot_parameters[["projection"]] + 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( + cells_df, + aes_q( + x = as.name(colnames(cells_df)[1]), + y = as.name(colnames(cells_df)[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(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_overview_projection_update_plot.R b/inst/shiny/v1.3/overview/event_overview_projection_update_plot.R new file mode 100644 index 0000000..3688a72 --- /dev/null +++ b/inst/shiny/v1.3/overview/event_overview_projection_update_plot.R @@ -0,0 +1,5 @@ +## +observeEvent(overview_projection_data_to_plot(), { + req(overview_projection_data_to_plot()) + overview_projection_update_plot(overview_projection_data_to_plot()) +}) diff --git a/inst/shiny/v1.3/overview/func_overview_projection_update_plot.R b/inst/shiny/v1.3/overview/func_overview_projection_update_plot.R new file mode 100644 index 0000000..9fc9dbd --- /dev/null +++ b/inst/shiny/v1.3/overview/func_overview_projection_update_plot.R @@ -0,0 +1,140 @@ +## function to be executed to update figure +overview_projection_update_plot <- function(input) { + cells_df <- input[['cells_df']] + plot_parameters <- input[['plot_parameters']] + color_assignments <- input[['color_assignments']] + hover_info <- input[['hover_info']] + color_input <- cells_df[[ plot_parameters[['color_variable']] ]] + if ( is.numeric(color_input) ) { + output_meta <- list( + color_type = 'continuous', + traces = plot_parameters[['color_variable']], + color_variable = plot_parameters[['color_variable']] + ) + output_data <- list( + x = cells_df[[1]], + y = cells_df[[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"]] + ) + if ( plot_parameters[["draw_border"]] ) { + output_data[['point_line']] <- list( + color = "rgb(196,196,196)", + width = 1 + ) + } + output_hover <- list( + hoverinfo = ifelse(plot_parameters[["hover_info"]], 'text', 'skip'), + text = 'empty' + ) + if ( plot_parameters[["hover_info"]] ) { + output_hover[['text']] <- unname(hover_info) + } + 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']] <- cells_df[[3]] + shinyjs::js$updatePlot3DContinuous( + output_meta, + output_data, + output_hover + ) + } + } else { + output_meta <- list( + color_type = 'categorical', + traces = list(), + color_variable = plot_parameters[['color_variable']] + ) + 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"]] + ) + if ( plot_parameters[["draw_border"]] ) { + output_data[['point_line']] <- list( + color = "rgb(196,196,196)", + width = 1 + ) + } + output_hover <- list( + hoverinfo = ifelse(plot_parameters[["hover_info"]], 'text', 'skip'), + text = ifelse(plot_parameters[["hover_info"]], list(), 'test') + ) + 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]] <- cells_df[[1]][cells_to_extract] + output_data[['y']][[i]] <- cells_df[[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(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]] <- cells_df[[1]][cells_to_extract] + output_data[['y']][[i]] <- cells_df[[2]][cells_to_extract] + output_data[['z']][[i]] <- cells_df[[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(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_overview_projection_update_plot.js b/inst/shiny/v1.3/overview/js_overview_projection_update_plot.js new file mode 100644 index 0000000..3818af4 --- /dev/null +++ b/inst/shiny/v1.3/overview/js_overview_projection_update_plot.js @@ -0,0 +1,238 @@ +const layout = { + 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: [] + }, + zaxis: { + autorange: true, + mirror: true, + showline: true, + zeroline: false + }, + hoverlabel: { + font: { + size: 11 + }, + align: 'left' + } +}; + +const defaultParams = { + meta: { + color_type: '', + traces: [], + color_variable: '' + }, + data: { + x: [], + y: [], + z: [], + color: [], + size: '', + opacity: '', + line: {}, + x_range: [], + y_range: [] + }, + hover: { + hoverinfo: '', + text: [] + }, + group_centers: { + group: [], + x: [], + y: [], + z: [] + } +} + +shinyjs.updatePlot2DContinuous = function(params) { + params = shinyjs.getParams(params, defaultParams); + 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 + } + ); + let layout_here = Object.assign(layout); + 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); +} + +shinyjs.updatePlot3DContinuous = function(params) { + params = shinyjs.getParams(params, defaultParams); + 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, layout); +} + + +shinyjs.updatePlot2DCategorical = function(params) { + params = shinyjs.getParams(params, defaultParams); + 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 + } + ); + } + let layout_here = Object.assign(layout); + 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); +} + + +shinyjs.updatePlot3DCategorical = function(params) { + params = shinyjs.getParams(params, defaultParams); + 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, layout); +} + diff --git a/inst/shiny/v1.3/overview/obj_overview_projection_color_assignments.R b/inst/shiny/v1.3/overview/obj_overview_projection_color_assignments.R new file mode 100644 index 0000000..9f281e2 --- /dev/null +++ b/inst/shiny/v1.3/overview/obj_overview_projection_color_assignments.R @@ -0,0 +1,15 @@ +##----------------------------------------------------------------------------## +## Color assignments. +##----------------------------------------------------------------------------## +overview_projection_color_assignments <- reactive({ + req( + overview_projection_data(), + overview_projection_parameters_plot() + ) + return( + assignColorsToGroups( + overview_projection_data(), + overview_projection_parameters_plot()[['color_variable']] + ) + ) +}) diff --git a/inst/shiny/v1.3/overview/obj_overview_projection_data.R b/inst/shiny/v1.3/overview/obj_overview_projection_data.R new file mode 100644 index 0000000..04c7648 --- /dev/null +++ b/inst/shiny/v1.3/overview/obj_overview_projection_data.R @@ -0,0 +1,21 @@ +##----------------------------------------------------------------------------## +## Cell meta data and position in projection. +##----------------------------------------------------------------------------## +overview_projection_data <- reactive({ + req(overview_projection_parameters_cell_filtering()) + parameters <- overview_projection_parameters_cell_filtering() + cells_df <- cbind(getProjection(parameters[["projection"]]), getMetaData()) + ## remove cells based on group filters + 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% parameters[["group_filters"]][[ i ]] ),] + } + } + ## randomly remove cells (if necessary) + cells_df <- randomlySubsetCells(cells_df, parameters[["pct_cells"]]) + ## put rows in random order + cells_df <- cells_df[ sample(1:nrow(cells_df)) , ] + return(cells_df) +}) diff --git a/inst/shiny/v1.3/overview/obj_overview_projection_data_to_plot.R b/inst/shiny/v1.3/overview/obj_overview_projection_data_to_plot.R new file mode 100644 index 0000000..2cc4ca9 --- /dev/null +++ b/inst/shiny/v1.3/overview/obj_overview_projection_data_to_plot.R @@ -0,0 +1,23 @@ +## +overview_projection_data_to_plot <- reactive({ + req( + overview_projection_data(), + overview_projection_parameters_plot(), + reactive_colors(), + overview_projection_hover_info() + ) + 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']] + ) + } + list( + cells_df = overview_projection_data(), + plot_parameters = overview_projection_parameters_plot(), + color_assignments = color_assignments, + hover_info = overview_projection_hover_info() + ) +}) diff --git a/inst/shiny/v1.3/overview/obj_overview_projection_hover_info.R b/inst/shiny/v1.3/overview/obj_overview_projection_hover_info.R new file mode 100644 index 0000000..81db543 --- /dev/null +++ b/inst/shiny/v1.3/overview/obj_overview_projection_hover_info.R @@ -0,0 +1,10 @@ +##----------------------------------------------------------------------------## +## Hover info. +##----------------------------------------------------------------------------## +overview_projection_hover_info <- reactive({ + req(overview_projection_data()) + cells_df <- overview_projection_data() + hover_info <- buildHoverInfoForProjections(cells_df) + hover_info <- setNames(hover_info, cells_df$cell_barcode) + return(hover_info) +}) diff --git a/inst/shiny/v1.3/overview/obj_overview_projection_parameters_cell_filtering.R b/inst/shiny/v1.3/overview/obj_overview_projection_parameters_cell_filtering.R new file mode 100644 index 0000000..35a8c5a --- /dev/null +++ b/inst/shiny/v1.3/overview/obj_overview_projection_parameters_cell_filtering.R @@ -0,0 +1,25 @@ +##----------------------------------------------------------------------------## +## Input parameters for filtering cells. +##----------------------------------------------------------------------------## +overview_projection_parameters_cell_filtering_raw <- reactive({ + req( + input[["overview_projection_to_display"]], + input[["overview_projection_percentage_cells_to_show"]] + ) + ## require group filters UI elements and at least 1 group level to be selected + for ( i in getGroups() ) { + req(input[[paste0("overview_projection_group_filter_", i)]]) + } + parameters <- list( + projection = input[["overview_projection_to_display"]], + pct_cells = input[["overview_projection_percentage_cells_to_show"]], + group_filters = list() + ) + ## store group filters + for ( i in getGroups() ) { + parameters[['group_filters']][[ i ]] <- input[[paste0("overview_projection_group_filter_", i)]] + } + return(parameters) +}) + +overview_projection_parameters_cell_filtering <- debounce(overview_projection_parameters_cell_filtering_raw, 150) diff --git a/inst/shiny/v1.3/overview/obj_overview_projection_parameters_plot.R b/inst/shiny/v1.3/overview/obj_overview_projection_parameters_plot.R new file mode 100644 index 0000000..22a8bd9 --- /dev/null +++ b/inst/shiny/v1.3/overview/obj_overview_projection_parameters_plot.R @@ -0,0 +1,32 @@ +##----------------------------------------------------------------------------## +## Collect parameters for projection plot. +##----------------------------------------------------------------------------## +overview_projection_parameters_plot_raw <- reactive({ + req( + input[["overview_projection_to_display"]], + input[["overview_projection_point_color"]], + 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"]]) + ) + 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"]] + ) + return(parameters) +}) + +overview_projection_parameters_plot <- debounce(overview_projection_parameters_plot_raw, 150) diff --git a/inst/shiny/v1.3/overview/obj_overview_projection_selected_cells.R b/inst/shiny/v1.3/overview/obj_overview_projection_selected_cells.R new file mode 100644 index 0000000..1fd7f0a --- /dev/null +++ b/inst/shiny/v1.3/overview/obj_overview_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/out_overview_details_selected_cells_plot.R b/inst/shiny/v1.3/overview/out_overview_details_selected_cells_plot.R new file mode 100644 index 0000000..53e6814 --- /dev/null +++ b/inst/shiny/v1.3/overview/out_overview_details_selected_cells_plot.R @@ -0,0 +1,138 @@ +##----------------------------------------------------------------------------## +## 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( + overview_projection_parameters_plot()[["projection"]], + input[["overview_selected_cells_plot_select_variable"]] + ) + ## extract cells to plot + cells_df <- cbind( + getProjection(overview_projection_parameters_plot()[["projection"]]), + 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') + ## ... selection has been made and at least 1 cell is in it + } else { + ## + cells_df <- cells_df %>% + dplyr::rename(X1 = 1, X2 = 2) %>% + dplyr::mutate( + identifier = paste0(X1, '-', X2), + 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, + n = 0 + ) %>% + dplyr::rename(!!color_variable := group) + } + ## 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, + x = ~cells_df[[1]], + y = ~cells_df[[2]], + type = "bar", + color = ~cells_df[[1]], + colors = colors_for_groups, + source = "subset", + 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, + x = ~cells_df[[ 'group' ]], + y = ~cells_df[[ color_variable ]], + type = "violin", + box = list( + visible = TRUE + ), + meanline = list( + visible = TRUE + ), + color = ~cells_df[[1]], + colors = setNames( + c('#e74c3c','#7f8c8d'), + c('selected', 'not selected') + ), + source = "subset", + showlegend = FALSE, + hoverinfo = "y", + marker = list( + size = 5 + ) + ) + y_axis_title <- colnames(cells_df)[2] + } + plot %>% + plotly::layout( + title = "", + xaxis = list( + title = "", + mirror = TRUE, + showline = TRUE + ), + yaxis = list( + title = y_axis_title, + hoverformat = ".0f", + mirror = TRUE, + showline = TRUE + ), + dragmode = "select", + hovermode = "compare" + ) +}) diff --git a/inst/shiny/v1.3/overview/out_overview_details_selected_cells_table.R b/inst/shiny/v1.3/overview/out_overview_details_selected_cells_table.R new file mode 100644 index 0000000..c496c2d --- /dev/null +++ b/inst/shiny/v1.3/overview/out_overview_details_selected_cells_table.R @@ -0,0 +1,51 @@ +##----------------------------------------------------------------------------## +## Table. +##----------------------------------------------------------------------------## +output[["overview_details_selected_cells_table"]] <- DT::renderDataTable(server = FALSE, { + ## don't proceed without these inputs + req(overview_projection_parameters_plot()) + ## 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(overview_projection_parameters_plot()[["projection"]]), + 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_overview_number_of_selected_cells.R b/inst/shiny/v1.3/overview/out_overview_number_of_selected_cells.R new file mode 100644 index 0000000..0a4f168 --- /dev/null +++ b/inst/shiny/v1.3/overview/out_overview_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_overview_projection.R b/inst/shiny/v1.3/overview/out_overview_projection.R new file mode 100644 index 0000000..0f7f7ec --- /dev/null +++ b/inst/shiny/v1.3/overview/out_overview_projection.R @@ -0,0 +1,40 @@ +##----------------------------------------------------------------------------## +## Plotly plot of the selected projection. +##----------------------------------------------------------------------------## +output[["overview_projection"]] <- plotly::renderPlotly({ + plot_ly(type = 'scattergl', mode = 'markers', source = "overview_projection") +}) + +##----------------------------------------------------------------------------## +## 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." + ) +) From c0d01269074c7e01351bf34bad12b7bb9d722333 Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Sat, 13 Feb 2021 23:32:28 +0100 Subject: [PATCH 16/39] Import JavaScript code as string --- inst/shiny/v1.3/overview/UI.R | 254 +++++++++++++++++- .../v1.3/overview/out_overview_projection.R | 2 +- inst/shiny/v1.3/utility_functions.R | 2 +- 3 files changed, 255 insertions(+), 3 deletions(-) diff --git a/inst/shiny/v1.3/overview/UI.R b/inst/shiny/v1.3/overview/UI.R index e31efb0..1920d68 100644 --- a/inst/shiny/v1.3/overview/UI.R +++ b/inst/shiny/v1.3/overview/UI.R @@ -1,6 +1,250 @@ ##----------------------------------------------------------------------------## ## Tab: Overview ##----------------------------------------------------------------------------## + +jsCode <- " +const layout = { + 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: [] + }, + zaxis: { + autorange: true, + mirror: true, + showline: true, + zeroline: false + }, + hoverlabel: { + font: { + size: 11 + }, + align: 'left' + } +}; + +const defaultParams = { + meta: { + color_type: '', + traces: [], + color_variable: '' + }, + data: { + x: [], + y: [], + z: [], + color: [], + size: '', + opacity: '', + line: {}, + x_range: [], + y_range: [] + }, + hover: { + hoverinfo: '', + text: [] + }, + group_centers: { + group: [], + x: [], + y: [], + z: [] + } +} + +shinyjs.updatePlot2DContinuous = function(params) { + params = shinyjs.getParams(params, defaultParams); + 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 + } + ); + let layout_here = Object.assign(layout); + 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); +} + +shinyjs.updatePlot3DContinuous = function(params) { + params = shinyjs.getParams(params, defaultParams); + 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, layout); +} + + +shinyjs.updatePlot2DCategorical = function(params) { + params = shinyjs.getParams(params, defaultParams); + 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 + } + ); + } + let layout_here = Object.assign(layout); + 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); +} + + +shinyjs.updatePlot3DCategorical = function(params) { + params = shinyjs.getParams(params, defaultParams); + 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, layout); +} +" + tab_overview <- tabItem( tabName = "overview", ## necessary to ensure alignment of table headers and content @@ -14,7 +258,15 @@ tab_overview <- tabItem( " ), shinyjs::useShinyjs(), - shinyjs::extendShinyjs(script = paste0(Cerebro.options[["cerebro_root"]], "/shiny/v1.3/overview/js_overview_projection_update_plot.js")), + shinyjs::extendShinyjs( + text = jsCode, + 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/out_overview_projection.R b/inst/shiny/v1.3/overview/out_overview_projection.R index 0f7f7ec..662bb97 100644 --- a/inst/shiny/v1.3/overview/out_overview_projection.R +++ b/inst/shiny/v1.3/overview/out_overview_projection.R @@ -2,7 +2,7 @@ ## Plotly plot of the selected projection. ##----------------------------------------------------------------------------## output[["overview_projection"]] <- plotly::renderPlotly({ - plot_ly(type = 'scattergl', mode = 'markers', source = "overview_projection") + plotly::plot_ly(type = 'scattergl', mode = 'markers', source = "overview_projection") }) ##----------------------------------------------------------------------------## diff --git a/inst/shiny/v1.3/utility_functions.R b/inst/shiny/v1.3/utility_functions.R index c8f5145..edef7bb 100644 --- a/inst/shiny/v1.3/utility_functions.R +++ b/inst/shiny/v1.3/utility_functions.R @@ -793,7 +793,7 @@ centerOfGroups <- function(df, n_dimensions, group) { return() ## ... 3 dimensions - } else if ( n_dimensions == 3 ) { + } else if ( n_dimensions == 3 && is.numeric(df[,3]) ) { ## calculate center for groups and return tidyr::tibble( From dd5e5890ee80e22788e14cf473bcaba037f873fd Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Sun, 14 Feb 2021 11:20:08 +0100 Subject: [PATCH 17/39] Show cellular barcode in table of selected cells in monospace font --- inst/shiny/v1.3/utility_functions.R | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/inst/shiny/v1.3/utility_functions.R b/inst/shiny/v1.3/utility_functions.R index 658687a..15057ba 100644 --- a/inst/shiny/v1.3/utility_functions.R +++ b/inst/shiny/v1.3/utility_functions.R @@ -452,6 +452,10 @@ prettifyTable <- function( } } + # show cellular barcodes in monospace font + table <- table %>% + DT::formatStyle('cell_barcode', target="cell", fontFamily="courier") + ## return the table return(table) From f3ad5d1bd0eb72dcfb13d9c55868b005d43bfd13 Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Sun, 14 Feb 2021 11:48:13 +0100 Subject: [PATCH 18/39] Fix scale of percentage values in table of selected cells if necessary Percentage values are expected to be on 0-1 scale but may be provided on a 0-100 scale. A new step will test whether the largest value in the column (in the entire meta data table) is larger than 1 and convert the values to a 0-1 scale (only if automatic number formatting is active). --- inst/shiny/v1.3/utility_functions.R | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/inst/shiny/v1.3/utility_functions.R b/inst/shiny/v1.3/utility_functions.R index 658687a..cfbc2d8 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(getMetaData()[,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 From 875e64366508b380d9cff2722873421234955e21 Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Mon, 15 Feb 2021 21:36:32 +0100 Subject: [PATCH 19/39] Define separate layouts for 2D and 3D projections in "Overview" tab In the 3D projections, the axes need to be set in the "scene" attribute. --- inst/shiny/v1.3/overview/UI.R | 63 +++++++++++++++++++++++++++-------- 1 file changed, 49 insertions(+), 14 deletions(-) diff --git a/inst/shiny/v1.3/overview/UI.R b/inst/shiny/v1.3/overview/UI.R index 1920d68..57d00d0 100644 --- a/inst/shiny/v1.3/overview/UI.R +++ b/inst/shiny/v1.3/overview/UI.R @@ -2,8 +2,8 @@ ## Tab: Overview ##----------------------------------------------------------------------------## -jsCode <- " -const layout = { +js_code_overview_projection <- " +const layout_2D = { uirevision: 'true', hovermode: 'closest', margin: { @@ -30,11 +30,48 @@ const layout = { zeroline: false, range: [] }, - zaxis: { - autorange: true, - mirror: true, - showline: true, - zeroline: false + hoverlabel: { + font: { + size: 11 + }, + align: 'left' + } +}; + +const 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: { @@ -100,7 +137,7 @@ shinyjs.updatePlot2DContinuous = function(params) { showlegend: false } ); - let layout_here = Object.assign(layout); + const layout_here = Object.assign(layout_2D); layout_here.xaxis['autorange'] = false; layout_here.xaxis['range'] = params.data.x_range; layout_here.yaxis['autorange'] = false; @@ -136,10 +173,9 @@ shinyjs.updatePlot3DContinuous = function(params) { showlegend: false } ); - Plotly.react('overview_projection', data, layout); + Plotly.react('overview_projection', data, layout_3D); } - shinyjs.updatePlot2DCategorical = function(params) { params = shinyjs.getParams(params, defaultParams); const data = []; @@ -185,7 +221,7 @@ shinyjs.updatePlot2DCategorical = function(params) { } ); } - let layout_here = Object.assign(layout); + const layout_here = Object.assign(layout_2D); layout_here.xaxis['autorange'] = false; layout_here.xaxis['range'] = params.data.x_range; layout_here.yaxis['autorange'] = false; @@ -193,7 +229,6 @@ shinyjs.updatePlot2DCategorical = function(params) { Plotly.react('overview_projection', data, layout_here); } - shinyjs.updatePlot3DCategorical = function(params) { params = shinyjs.getParams(params, defaultParams); const data = []; @@ -241,7 +276,7 @@ shinyjs.updatePlot3DCategorical = function(params) { } ); } - Plotly.react('overview_projection', data, layout); + Plotly.react('overview_projection', data, layout_3D); } " @@ -259,7 +294,7 @@ tab_overview <- tabItem( ), shinyjs::useShinyjs(), shinyjs::extendShinyjs( - text = jsCode, + text = js_code_overview_projection, functions = c( "updatePlot2DContinuous", "updatePlot3DContinuous", From 3578f6c1d56465f14537d86ecd7e6909a6bc5a03 Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Mon, 15 Feb 2021 21:37:40 +0100 Subject: [PATCH 20/39] Remove unnecessary part from file names --- ..._overview_projection.R => UI_projection.R} | 0 ... => UI_projection_additional_parameters.R} | 0 ...ilters.R => UI_projection_group_filters.R} | 0 ...ters.R => UI_projection_main_parameters.R} | 0 ..._border.R => UI_projection_point_border.R} | 0 ...ection_scales.R => UI_projection_scales.R} | 0 ...bel.R => UI_projection_show_group_label.R} | 0 ..._cells_plot.R => UI_selected_cells_plot.R} | 0 ...ells_table.R => UI_selected_cells_table.R} | 0 ..._plot.R => event_projection_export_plot.R} | 0 ..._plot.R => event_projection_update_plot.R} | 0 ...e_plot.R => func_projection_update_plot.R} | 0 .../js_overview_projection_update_plot.js | 238 ------------------ ...s.R => obj_projection_color_assignments.R} | 0 ...rojection_data.R => obj_projection_data.R} | 0 ...o_plot.R => obj_projection_data_to_plot.R} | 0 ...ver_info.R => obj_projection_hover_info.R} | 0 ...bj_projection_parameters_cell_filtering.R} | 0 ...lot.R => obj_projection_parameters_plot.R} | 0 ...ells.R => obj_projection_selected_cells.R} | 0 ...ot.R => out_details_selected_cells_plot.R} | 0 ...e.R => out_details_selected_cells_table.R} | 0 ...cells.R => out_number_of_selected_cells.R} | 0 ...overview_projection.R => out_projection.R} | 0 24 files changed, 238 deletions(-) rename inst/shiny/v1.3/overview/{UI_overview_projection.R => UI_projection.R} (100%) rename inst/shiny/v1.3/overview/{UI_overview_projection_additional_parameters.R => UI_projection_additional_parameters.R} (100%) rename inst/shiny/v1.3/overview/{UI_overview_projection_group_filters.R => UI_projection_group_filters.R} (100%) rename inst/shiny/v1.3/overview/{UI_overview_projection_main_parameters.R => UI_projection_main_parameters.R} (100%) rename inst/shiny/v1.3/overview/{UI_overview_projection_point_border.R => UI_projection_point_border.R} (100%) rename inst/shiny/v1.3/overview/{UI_overview_projection_scales.R => UI_projection_scales.R} (100%) rename inst/shiny/v1.3/overview/{UI_overview_projection_show_group_label.R => UI_projection_show_group_label.R} (100%) rename inst/shiny/v1.3/overview/{UI_overview_selected_cells_plot.R => UI_selected_cells_plot.R} (100%) rename inst/shiny/v1.3/overview/{UI_overview_selected_cells_table.R => UI_selected_cells_table.R} (100%) rename inst/shiny/v1.3/overview/{event_overview_projection_export_plot.R => event_projection_export_plot.R} (100%) rename inst/shiny/v1.3/overview/{event_overview_projection_update_plot.R => event_projection_update_plot.R} (100%) rename inst/shiny/v1.3/overview/{func_overview_projection_update_plot.R => func_projection_update_plot.R} (100%) delete mode 100644 inst/shiny/v1.3/overview/js_overview_projection_update_plot.js rename inst/shiny/v1.3/overview/{obj_overview_projection_color_assignments.R => obj_projection_color_assignments.R} (100%) rename inst/shiny/v1.3/overview/{obj_overview_projection_data.R => obj_projection_data.R} (100%) rename inst/shiny/v1.3/overview/{obj_overview_projection_data_to_plot.R => obj_projection_data_to_plot.R} (100%) rename inst/shiny/v1.3/overview/{obj_overview_projection_hover_info.R => obj_projection_hover_info.R} (100%) rename inst/shiny/v1.3/overview/{obj_overview_projection_parameters_cell_filtering.R => obj_projection_parameters_cell_filtering.R} (100%) rename inst/shiny/v1.3/overview/{obj_overview_projection_parameters_plot.R => obj_projection_parameters_plot.R} (100%) rename inst/shiny/v1.3/overview/{obj_overview_projection_selected_cells.R => obj_projection_selected_cells.R} (100%) rename inst/shiny/v1.3/overview/{out_overview_details_selected_cells_plot.R => out_details_selected_cells_plot.R} (100%) rename inst/shiny/v1.3/overview/{out_overview_details_selected_cells_table.R => out_details_selected_cells_table.R} (100%) rename inst/shiny/v1.3/overview/{out_overview_number_of_selected_cells.R => out_number_of_selected_cells.R} (100%) rename inst/shiny/v1.3/overview/{out_overview_projection.R => out_projection.R} (100%) diff --git a/inst/shiny/v1.3/overview/UI_overview_projection.R b/inst/shiny/v1.3/overview/UI_projection.R similarity index 100% rename from inst/shiny/v1.3/overview/UI_overview_projection.R rename to inst/shiny/v1.3/overview/UI_projection.R diff --git a/inst/shiny/v1.3/overview/UI_overview_projection_additional_parameters.R b/inst/shiny/v1.3/overview/UI_projection_additional_parameters.R similarity index 100% rename from inst/shiny/v1.3/overview/UI_overview_projection_additional_parameters.R rename to inst/shiny/v1.3/overview/UI_projection_additional_parameters.R diff --git a/inst/shiny/v1.3/overview/UI_overview_projection_group_filters.R b/inst/shiny/v1.3/overview/UI_projection_group_filters.R similarity index 100% rename from inst/shiny/v1.3/overview/UI_overview_projection_group_filters.R rename to inst/shiny/v1.3/overview/UI_projection_group_filters.R diff --git a/inst/shiny/v1.3/overview/UI_overview_projection_main_parameters.R b/inst/shiny/v1.3/overview/UI_projection_main_parameters.R similarity index 100% rename from inst/shiny/v1.3/overview/UI_overview_projection_main_parameters.R rename to inst/shiny/v1.3/overview/UI_projection_main_parameters.R diff --git a/inst/shiny/v1.3/overview/UI_overview_projection_point_border.R b/inst/shiny/v1.3/overview/UI_projection_point_border.R similarity index 100% rename from inst/shiny/v1.3/overview/UI_overview_projection_point_border.R rename to inst/shiny/v1.3/overview/UI_projection_point_border.R diff --git a/inst/shiny/v1.3/overview/UI_overview_projection_scales.R b/inst/shiny/v1.3/overview/UI_projection_scales.R similarity index 100% rename from inst/shiny/v1.3/overview/UI_overview_projection_scales.R rename to inst/shiny/v1.3/overview/UI_projection_scales.R diff --git a/inst/shiny/v1.3/overview/UI_overview_projection_show_group_label.R b/inst/shiny/v1.3/overview/UI_projection_show_group_label.R similarity index 100% rename from inst/shiny/v1.3/overview/UI_overview_projection_show_group_label.R rename to inst/shiny/v1.3/overview/UI_projection_show_group_label.R diff --git a/inst/shiny/v1.3/overview/UI_overview_selected_cells_plot.R b/inst/shiny/v1.3/overview/UI_selected_cells_plot.R similarity index 100% rename from inst/shiny/v1.3/overview/UI_overview_selected_cells_plot.R rename to inst/shiny/v1.3/overview/UI_selected_cells_plot.R diff --git a/inst/shiny/v1.3/overview/UI_overview_selected_cells_table.R b/inst/shiny/v1.3/overview/UI_selected_cells_table.R similarity index 100% rename from inst/shiny/v1.3/overview/UI_overview_selected_cells_table.R rename to inst/shiny/v1.3/overview/UI_selected_cells_table.R diff --git a/inst/shiny/v1.3/overview/event_overview_projection_export_plot.R b/inst/shiny/v1.3/overview/event_projection_export_plot.R similarity index 100% rename from inst/shiny/v1.3/overview/event_overview_projection_export_plot.R rename to inst/shiny/v1.3/overview/event_projection_export_plot.R diff --git a/inst/shiny/v1.3/overview/event_overview_projection_update_plot.R b/inst/shiny/v1.3/overview/event_projection_update_plot.R similarity index 100% rename from inst/shiny/v1.3/overview/event_overview_projection_update_plot.R rename to inst/shiny/v1.3/overview/event_projection_update_plot.R diff --git a/inst/shiny/v1.3/overview/func_overview_projection_update_plot.R b/inst/shiny/v1.3/overview/func_projection_update_plot.R similarity index 100% rename from inst/shiny/v1.3/overview/func_overview_projection_update_plot.R rename to inst/shiny/v1.3/overview/func_projection_update_plot.R diff --git a/inst/shiny/v1.3/overview/js_overview_projection_update_plot.js b/inst/shiny/v1.3/overview/js_overview_projection_update_plot.js deleted file mode 100644 index 3818af4..0000000 --- a/inst/shiny/v1.3/overview/js_overview_projection_update_plot.js +++ /dev/null @@ -1,238 +0,0 @@ -const layout = { - 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: [] - }, - zaxis: { - autorange: true, - mirror: true, - showline: true, - zeroline: false - }, - hoverlabel: { - font: { - size: 11 - }, - align: 'left' - } -}; - -const defaultParams = { - meta: { - color_type: '', - traces: [], - color_variable: '' - }, - data: { - x: [], - y: [], - z: [], - color: [], - size: '', - opacity: '', - line: {}, - x_range: [], - y_range: [] - }, - hover: { - hoverinfo: '', - text: [] - }, - group_centers: { - group: [], - x: [], - y: [], - z: [] - } -} - -shinyjs.updatePlot2DContinuous = function(params) { - params = shinyjs.getParams(params, defaultParams); - 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 - } - ); - let layout_here = Object.assign(layout); - 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); -} - -shinyjs.updatePlot3DContinuous = function(params) { - params = shinyjs.getParams(params, defaultParams); - 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, layout); -} - - -shinyjs.updatePlot2DCategorical = function(params) { - params = shinyjs.getParams(params, defaultParams); - 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 - } - ); - } - let layout_here = Object.assign(layout); - 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); -} - - -shinyjs.updatePlot3DCategorical = function(params) { - params = shinyjs.getParams(params, defaultParams); - 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, layout); -} - diff --git a/inst/shiny/v1.3/overview/obj_overview_projection_color_assignments.R b/inst/shiny/v1.3/overview/obj_projection_color_assignments.R similarity index 100% rename from inst/shiny/v1.3/overview/obj_overview_projection_color_assignments.R rename to inst/shiny/v1.3/overview/obj_projection_color_assignments.R diff --git a/inst/shiny/v1.3/overview/obj_overview_projection_data.R b/inst/shiny/v1.3/overview/obj_projection_data.R similarity index 100% rename from inst/shiny/v1.3/overview/obj_overview_projection_data.R rename to inst/shiny/v1.3/overview/obj_projection_data.R diff --git a/inst/shiny/v1.3/overview/obj_overview_projection_data_to_plot.R b/inst/shiny/v1.3/overview/obj_projection_data_to_plot.R similarity index 100% rename from inst/shiny/v1.3/overview/obj_overview_projection_data_to_plot.R rename to inst/shiny/v1.3/overview/obj_projection_data_to_plot.R diff --git a/inst/shiny/v1.3/overview/obj_overview_projection_hover_info.R b/inst/shiny/v1.3/overview/obj_projection_hover_info.R similarity index 100% rename from inst/shiny/v1.3/overview/obj_overview_projection_hover_info.R rename to inst/shiny/v1.3/overview/obj_projection_hover_info.R diff --git a/inst/shiny/v1.3/overview/obj_overview_projection_parameters_cell_filtering.R b/inst/shiny/v1.3/overview/obj_projection_parameters_cell_filtering.R similarity index 100% rename from inst/shiny/v1.3/overview/obj_overview_projection_parameters_cell_filtering.R rename to inst/shiny/v1.3/overview/obj_projection_parameters_cell_filtering.R diff --git a/inst/shiny/v1.3/overview/obj_overview_projection_parameters_plot.R b/inst/shiny/v1.3/overview/obj_projection_parameters_plot.R similarity index 100% rename from inst/shiny/v1.3/overview/obj_overview_projection_parameters_plot.R rename to inst/shiny/v1.3/overview/obj_projection_parameters_plot.R diff --git a/inst/shiny/v1.3/overview/obj_overview_projection_selected_cells.R b/inst/shiny/v1.3/overview/obj_projection_selected_cells.R similarity index 100% rename from inst/shiny/v1.3/overview/obj_overview_projection_selected_cells.R rename to inst/shiny/v1.3/overview/obj_projection_selected_cells.R diff --git a/inst/shiny/v1.3/overview/out_overview_details_selected_cells_plot.R b/inst/shiny/v1.3/overview/out_details_selected_cells_plot.R similarity index 100% rename from inst/shiny/v1.3/overview/out_overview_details_selected_cells_plot.R rename to inst/shiny/v1.3/overview/out_details_selected_cells_plot.R diff --git a/inst/shiny/v1.3/overview/out_overview_details_selected_cells_table.R b/inst/shiny/v1.3/overview/out_details_selected_cells_table.R similarity index 100% rename from inst/shiny/v1.3/overview/out_overview_details_selected_cells_table.R rename to inst/shiny/v1.3/overview/out_details_selected_cells_table.R diff --git a/inst/shiny/v1.3/overview/out_overview_number_of_selected_cells.R b/inst/shiny/v1.3/overview/out_number_of_selected_cells.R similarity index 100% rename from inst/shiny/v1.3/overview/out_overview_number_of_selected_cells.R rename to inst/shiny/v1.3/overview/out_number_of_selected_cells.R diff --git a/inst/shiny/v1.3/overview/out_overview_projection.R b/inst/shiny/v1.3/overview/out_projection.R similarity index 100% rename from inst/shiny/v1.3/overview/out_overview_projection.R rename to inst/shiny/v1.3/overview/out_projection.R From ba37ef7c3491dbd1ef107c28559b9c2b3ab9f04e Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Thu, 25 Feb 2021 12:57:14 +0100 Subject: [PATCH 21/39] Update Enrichr API (fix #25) --- R/getEnrichedPathways.R | 6 +++--- R/send_enrichr_query.r | 10 +++++----- man/dot-send_enrichr_query.Rd | 4 ++-- man/getEnrichedPathways.Rd | 6 +++--- 4 files changed, 13 insertions(+), 13 deletions(-) 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/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/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' ) } From 570802bfd00e15b2afd8307c3a7f65d08e542277 Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Tue, 2 Mar 2021 23:47:24 +0100 Subject: [PATCH 22/39] Refactored gene expression and several other changes - Remove empty lines within functions. - Update author and contact information. - Allow setting of additional options in "Cerebro.options". - Fix issue in marker genes and enriched pathways tabs that caused an error when switching from one dataset to another. - Expression by pseudotime is deactivated for now. --- inst/shiny/v1.3/about/server.R | 11 +- inst/shiny/v1.3/color_setup.R | 18 +- .../v1.3/enriched_pathways/select_content.R | 23 +- inst/shiny/v1.3/enriched_pathways/table.R | 48 +- inst/shiny/v1.3/extra_material/UI.R | 1 - inst/shiny/v1.3/extra_material/content.R | 60 +- .../v1.3/extra_material/select_content.R | 15 +- inst/shiny/v1.3/extra_material/server.R | 1 - inst/shiny/v1.3/gene_expression/UI.R | 25 +- ...sion_by_gene.R => UI_expression_by_gene.R} | 25 +- ...on_by_group.R => UI_expression_by_group.R} | 104 +- ...dotime.R => UI_expression_by_pseudotime.R} | 38 +- .../UI_expression_in_selected_cells.R | 124 ++ .../v1.3/gene_expression/UI_projection.R | 174 +++ .../UI_projection_additional_parameters.R | 76 + .../UI_projection_color_scale.R | 18 + .../UI_projection_color_scale_range.R | 76 + .../UI_projection_genes_separate_panels.R | 17 + .../UI_projection_group_filters.R | 54 + .../UI_projection_input_type.R | 26 + .../UI_projection_point_border.R | 17 + .../gene_expression/UI_projection_scales.R | 58 + .../UI_projection_select_projection.R | 15 + ...d_cells.R => UI_table_of_selected_cells.R} | 55 +- .../event_projection_export_plot.R | 128 ++ .../event_projection_update_plot.R | 9 + .../expression_in_selected_cells.R | 151 -- .../func_pltExpProj2DMultPanExp.R | 31 + .../func_pltExpProj2DSglPanExp.R | 65 + .../func_pltExpTrj2DSglPanExp.R | 75 + .../func_projection_update_plot.R | 157 ++ .../js_projection_update_plot.js | 310 ++++ .../obj_projection_cells_to_show.R | 36 + .../obj_projection_coordinates.R | 28 + .../obj_projection_data_to_plot.R | 37 + .../obj_projection_expression_levels.R | 38 + .../obj_projection_hover_info.R | 20 + .../obj_projection_parameters_color.R | 18 + .../obj_projection_parameters_plot.R | 55 + .../obj_projection_selected_cells.R | 28 + .../obj_projection_trajectory.R | 31 + .../v1.3/gene_expression/obj_selected_genes.R | 46 + .../gene_expression/out_genes_displayed.R | 17 + .../out_number_of_selected_cells.R | 19 + .../v1.3/gene_expression/out_projection.R | 66 + inst/shiny/v1.3/gene_expression/projection.R | 1380 ----------------- inst/shiny/v1.3/gene_expression/server.R | 208 +-- inst/shiny/v1.3/gene_id_conversion/UI.R | 1 - inst/shiny/v1.3/gene_id_conversion/server.R | 7 - inst/shiny/v1.3/groups/UI.R | 1 - inst/shiny/v1.3/groups/cell_cycle.R | 23 - inst/shiny/v1.3/groups/composition.R | 30 +- inst/shiny/v1.3/groups/expression_metrics.R | 41 +- inst/shiny/v1.3/groups/select_group.R | 3 - inst/shiny/v1.3/groups/server.R | 1 - inst/shiny/v1.3/groups/tree.R | 22 +- inst/shiny/v1.3/load_data/UI.R | 1 - inst/shiny/v1.3/load_data/sample_info.R | 4 - inst/shiny/v1.3/load_data/server.R | 1 - inst/shiny/v1.3/marker_genes/UI.R | 1 - inst/shiny/v1.3/marker_genes/select_content.R | 18 +- inst/shiny/v1.3/marker_genes/server.R | 1 - inst/shiny/v1.3/marker_genes/table.R | 38 - inst/shiny/v1.3/most_expressed_genes/UI.R | 1 - .../v1.3/most_expressed_genes/select_group.R | 18 - inst/shiny/v1.3/most_expressed_genes/server.R | 1 - inst/shiny/v1.3/most_expressed_genes/table.R | 96 +- inst/shiny/v1.3/overview/UI.R | 282 +--- .../UI_projection_additional_parameters.R | 24 +- .../v1.3/overview/UI_projection_scales.R | 4 +- .../overview/event_projection_export_plot.R | 32 +- .../overview/event_projection_update_plot.R | 5 +- .../overview/func_projection_update_plot.R | 46 +- .../overview/js_projection_update_plot.js | 293 ++++ .../overview/obj_projection_cells_to_show.R | 37 + .../obj_projection_color_assignments.R | 11 +- .../overview/obj_projection_coordinates.R | 16 + .../shiny/v1.3/overview/obj_projection_data.R | 19 +- .../overview/obj_projection_data_to_plot.R | 43 +- .../v1.3/overview/obj_projection_hover_info.R | 20 +- ...obj_projection_parameters_cell_filtering.R | 25 - .../overview/obj_projection_parameters_plot.R | 15 + .../out_details_selected_cells_plot.R | 5 +- .../out_details_selected_cells_table.R | 7 +- inst/shiny/v1.3/overview/out_projection.R | 16 +- inst/shiny/v1.3/overview/server.R | 1 - inst/shiny/v1.3/plotting_functions.R | 15 - inst/shiny/v1.3/shiny_server.R | 143 +- inst/shiny/v1.3/trajectory/projection.R | 24 +- inst/shiny/v1.3/utility_functions.R | 53 +- 90 files changed, 2691 insertions(+), 2786 deletions(-) rename inst/shiny/v1.3/gene_expression/{expression_by_gene.R => UI_expression_by_gene.R} (89%) rename inst/shiny/v1.3/gene_expression/{expression_by_group.R => UI_expression_by_group.R} (62%) rename inst/shiny/v1.3/gene_expression/{expression_by_pseudotime.R => UI_expression_by_pseudotime.R} (93%) create mode 100644 inst/shiny/v1.3/gene_expression/UI_expression_in_selected_cells.R create mode 100644 inst/shiny/v1.3/gene_expression/UI_projection.R create mode 100644 inst/shiny/v1.3/gene_expression/UI_projection_additional_parameters.R create mode 100644 inst/shiny/v1.3/gene_expression/UI_projection_color_scale.R create mode 100644 inst/shiny/v1.3/gene_expression/UI_projection_color_scale_range.R create mode 100644 inst/shiny/v1.3/gene_expression/UI_projection_genes_separate_panels.R create mode 100644 inst/shiny/v1.3/gene_expression/UI_projection_group_filters.R create mode 100644 inst/shiny/v1.3/gene_expression/UI_projection_input_type.R create mode 100644 inst/shiny/v1.3/gene_expression/UI_projection_point_border.R create mode 100644 inst/shiny/v1.3/gene_expression/UI_projection_scales.R create mode 100644 inst/shiny/v1.3/gene_expression/UI_projection_select_projection.R rename inst/shiny/v1.3/gene_expression/{table_of_selected_cells.R => UI_table_of_selected_cells.R} (83%) create mode 100644 inst/shiny/v1.3/gene_expression/event_projection_export_plot.R create mode 100644 inst/shiny/v1.3/gene_expression/event_projection_update_plot.R delete mode 100644 inst/shiny/v1.3/gene_expression/expression_in_selected_cells.R create mode 100644 inst/shiny/v1.3/gene_expression/func_pltExpProj2DMultPanExp.R create mode 100644 inst/shiny/v1.3/gene_expression/func_pltExpProj2DSglPanExp.R create mode 100644 inst/shiny/v1.3/gene_expression/func_pltExpTrj2DSglPanExp.R create mode 100644 inst/shiny/v1.3/gene_expression/func_projection_update_plot.R create mode 100644 inst/shiny/v1.3/gene_expression/js_projection_update_plot.js create mode 100644 inst/shiny/v1.3/gene_expression/obj_projection_cells_to_show.R create mode 100644 inst/shiny/v1.3/gene_expression/obj_projection_coordinates.R create mode 100644 inst/shiny/v1.3/gene_expression/obj_projection_data_to_plot.R create mode 100644 inst/shiny/v1.3/gene_expression/obj_projection_expression_levels.R create mode 100644 inst/shiny/v1.3/gene_expression/obj_projection_hover_info.R create mode 100644 inst/shiny/v1.3/gene_expression/obj_projection_parameters_color.R create mode 100644 inst/shiny/v1.3/gene_expression/obj_projection_parameters_plot.R create mode 100644 inst/shiny/v1.3/gene_expression/obj_projection_selected_cells.R create mode 100644 inst/shiny/v1.3/gene_expression/obj_projection_trajectory.R create mode 100644 inst/shiny/v1.3/gene_expression/obj_selected_genes.R create mode 100644 inst/shiny/v1.3/gene_expression/out_genes_displayed.R create mode 100644 inst/shiny/v1.3/gene_expression/out_number_of_selected_cells.R create mode 100644 inst/shiny/v1.3/gene_expression/out_projection.R delete mode 100644 inst/shiny/v1.3/gene_expression/projection.R create mode 100644 inst/shiny/v1.3/overview/js_projection_update_plot.js create mode 100644 inst/shiny/v1.3/overview/obj_projection_cells_to_show.R create mode 100644 inst/shiny/v1.3/overview/obj_projection_coordinates.R delete mode 100644 inst/shiny/v1.3/overview/obj_projection_parameters_cell_filtering.R diff --git a/inst/shiny/v1.3/about/server.R b/inst/shiny/v1.3/about/server.R index c150478..4dda1d6 100644 --- a/inst/shiny/v1.3/about/server.R +++ b/inst/shiny/v1.3/about/server.R @@ -10,8 +10,6 @@ output[["about"]] <- renderText({
    Author
    Roman Hillje
    - Department of Experimental Oncology
    - IEO, European Institute of Oncology IRCCS, Milan

    Links
      @@ -26,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.

      @@ -57,7 +52,11 @@ output[["preferences"]] <- renderUI({ checkboxInput( "hover_info_in_projections_checkbox", label = "Show hover info in projections", - value = TRUE + value = ifelse( + !is.null(Cerebro.options[['show_hover_info_in_projections']]), + Cerebro.options[['show_hover_info_in_projections']], + TRUE + ) ) ) ) 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..2f843b9 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 ( 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..050ef5f 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, { - - ## 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 83% 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..f54172d 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 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..4106b46 --- /dev/null +++ b/inst/shiny/v1.3/gene_expression/event_projection_export_plot.R @@ -0,0 +1,128 @@ +##----------------------------------------------------------------------------## +## 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']] + expression_levels <- input_data[['expression_levels']] + cells_df$level <- expression_levels + cells_df <- bind_cols(input_data[['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,] + } + ## check if projection or trajectory should be shown + ## ... projection + if ( plot_parameters[["projection"]] %in% availableProjections() ) { + ## check if selection projection consists of 2 or 3 dimensions + ## ... selection projection consists of 3 dimensions + if ( ncol(getProjection(plot_parameters[["projection"]])) == 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(plot_parameters[["projection"]])) == 2 ) { + ## ... 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_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: +
        +
      1. Hovering over the cells shows only limited information.
      2. +
      3. Cells cannot be shown with a (grey) border around them.
      4. +
      5. All genes have the some color scale.
      6. +
      7. Cells cannot be selected.
      8. +
      9. The 'Expression by group' panel needs to be deactivated.
      10. +
      11. It throws annoying but innocent warning messages in the log.
      12. +
      + 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: -
        -
      1. Hovering over the cells shows only limited information.
      2. -
      3. Cells cannot be shown with a (grey) border around them.
      4. -
      5. All genes have the some color scale.
      6. -
      7. Cells cannot be selected.
      8. -
      9. The 'Expression by group' panel needs to be deactivated.
      10. -
      11. It throws annoying but innocent warning messages in the log.
      12. -
      - 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..d2b7bbd 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_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"]], ) - ## 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..33f283a 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" ]]) 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,9 +85,7 @@ 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( @@ -108,10 +94,8 @@ output[["groups_by_other_group_plot"]] <- plotly::renderPlotly({ 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..0f0c517 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"]]) 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"]]) 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"]]) 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"]]) 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..de9002a 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"]]) if ( !is.null(getTree( input[["groups_selected_group"]] )) ) { tagList( shinyWidgets::radioGroupButtons( @@ -100,8 +91,6 @@ output[["groups_tree_plot_or_message"]] <- renderUI({ ##----------------------------------------------------------------------------## output[["groups_tree_plot"]] <- renderPlot({ - - ## req( input[["groups_selected_group"]], input[["groups_tree_edge_width"]], @@ -109,23 +98,18 @@ output[["groups_tree_plot"]] <- renderPlot({ 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..c5d3550 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, { - - ## 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..a1b574a 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"]] - ) - + 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 57d00d0..9f5e550 100644 --- a/inst/shiny/v1.3/overview/UI.R +++ b/inst/shiny/v1.3/overview/UI.R @@ -1,284 +1,9 @@ ##----------------------------------------------------------------------------## ## Tab: Overview ##----------------------------------------------------------------------------## - -js_code_overview_projection <- " -const 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' - } -}; - -const 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' - } -}; - -const defaultParams = { - meta: { - color_type: '', - traces: [], - color_variable: '' - }, - data: { - x: [], - y: [], - z: [], - color: [], - size: '', - opacity: '', - line: {}, - x_range: [], - y_range: [] - }, - hover: { - hoverinfo: '', - text: [] - }, - group_centers: { - group: [], - x: [], - y: [], - z: [] - } -} - -shinyjs.updatePlot2DContinuous = function(params) { - params = shinyjs.getParams(params, defaultParams); - 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(layout_2D); - 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); -} - -shinyjs.updatePlot3DContinuous = function(params) { - params = shinyjs.getParams(params, defaultParams); - 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, layout_3D); -} - -shinyjs.updatePlot2DCategorical = function(params) { - params = shinyjs.getParams(params, defaultParams); - 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(layout_2D); - 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); -} - -shinyjs.updatePlot3DCategorical = function(params) { - params = shinyjs.getParams(params, defaultParams); - 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, layout_3D); -} -" +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", @@ -292,7 +17,6 @@ tab_overview <- tabItem( } " ), - shinyjs::useShinyjs(), shinyjs::extendShinyjs( text = js_code_overview_projection, functions = c( diff --git a/inst/shiny/v1.3/overview/UI_projection_additional_parameters.R b/inst/shiny/v1.3/overview/UI_projection_additional_parameters.R index 46feb82..c92f8cd 100644 --- a/inst/shiny/v1.3/overview/UI_projection_additional_parameters.R +++ b/inst/shiny/v1.3/overview/UI_projection_additional_parameters.R @@ -6,26 +6,26 @@ output[["overview_projection_additional_parameters_UI"]] <- renderUI({ sliderInput( "overview_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"]] + 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 = 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( "overview_projection_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"]] ) ) }) diff --git a/inst/shiny/v1.3/overview/UI_projection_scales.R b/inst/shiny/v1.3/overview/UI_projection_scales.R index 7e8e80f..5750edf 100644 --- a/inst/shiny/v1.3/overview/UI_projection_scales.R +++ b/inst/shiny/v1.3/overview/UI_projection_scales.R @@ -2,10 +2,10 @@ ## 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"]]) + is.na(input[["overview_projection_to_display"]]) || + input[["overview_projection_to_display"]] %in% availableProjections() == FALSE ) { projection_to_display <- availableProjections()[1] } else { diff --git a/inst/shiny/v1.3/overview/event_projection_export_plot.R b/inst/shiny/v1.3/overview/event_projection_export_plot.R index 7f10230..debabfa 100644 --- a/inst/shiny/v1.3/overview/event_projection_export_plot.R +++ b/inst/shiny/v1.3/overview/event_projection_export_plot.R @@ -2,14 +2,12 @@ ## Export projection plot to PDF when pressing the "export to PDF" button. ##----------------------------------------------------------------------------## observeEvent(input[["overview_projection_export"]], { - ## make sure plot parameters are set because it means that the plot can be - ## generated req(overview_projection_data_to_plot()) - ## - cells_df <- overview_projection_data_to_plot()[['cells_df']] - plot_parameters <- overview_projection_data_to_plot()[['plot_parameters']] - color_assignments <- overview_projection_data_to_plot()[['color_assignments']] - hover_info <- overview_projection_data_to_plot()[['hover_info']] + 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( @@ -20,15 +18,17 @@ observeEvent(input[["overview_projection_export"]], { restrictions = system.file(package = "base") ) ## retrieve info from dialog - save_file_input <- shinyFiles::parseSavePath(available_storage_volumes, input[["overview_projection_export"]]) + 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) - ## 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 <- plot_parameters[["projection"]] + ## 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 @@ -37,10 +37,10 @@ observeEvent(input[["overview_projection_export"]], { stroke <- ifelse(plot_parameters[["draw_border"]], 0.2, 0) ## start building the plot plot <- ggplot( - cells_df, + cbind(coordinates, cells_df), aes_q( - x = as.name(colnames(cells_df)[1]), - y = as.name(colnames(cells_df)[2]), + x = as.name(colnames(coordinates)[1]), + y = as.name(colnames(coordinates)[2]), fill = as.name(variable_to_color_cells) ) ) + @@ -67,7 +67,7 @@ observeEvent(input[["overview_projection_export"]], { ## 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(cells_df, 2, variable_to_color_cells) + group_labels <- centerOfGroups(coordinates, cells_df, 2, variable_to_color_cells) ## add group level labels at center of respective groups plot <- plot + geom_label( diff --git a/inst/shiny/v1.3/overview/event_projection_update_plot.R b/inst/shiny/v1.3/overview/event_projection_update_plot.R index 3688a72..3701c79 100644 --- a/inst/shiny/v1.3/overview/event_projection_update_plot.R +++ b/inst/shiny/v1.3/overview/event_projection_update_plot.R @@ -1,5 +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 index 9fc9dbd..ffdd670 100644 --- a/inst/shiny/v1.3/overview/func_projection_update_plot.R +++ b/inst/shiny/v1.3/overview/func_projection_update_plot.R @@ -1,25 +1,34 @@ -## function to be executed to update figure +##----------------------------------------------------------------------------## +## 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 = cells_df[[1]], - y = cells_df[[2]], + 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"]] + y_range = plot_parameters[["y_range"]], + reset_axes = reset_axes ) if ( plot_parameters[["draw_border"]] ) { output_data[['point_line']] <- list( @@ -27,6 +36,7 @@ overview_projection_update_plot <- function(input) { width = 1 ) } + ## put together hover info output_hover <- list( hoverinfo = ifelse(plot_parameters[["hover_info"]], 'text', 'skip'), text = 'empty' @@ -34,6 +44,7 @@ overview_projection_update_plot <- function(input) { 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, @@ -41,19 +52,22 @@ overview_projection_update_plot <- function(input) { output_hover ) } else if ( plot_parameters[['n_dimensions']] == 3 ) { - output_data[['z']] <- cells_df[[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(), @@ -63,7 +77,8 @@ overview_projection_update_plot <- function(input) { point_opacity = plot_parameters[["point_opacity"]], point_line = list(), x_range = plot_parameters[["x_range"]], - y_range = plot_parameters[["y_range"]] + y_range = plot_parameters[["y_range"]], + reset_axes = reset_axes ) if ( plot_parameters[["draw_border"]] ) { output_data[['point_line']] <- list( @@ -71,17 +86,20 @@ overview_projection_update_plot <- function(input) { 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]] <- cells_df[[1]][cells_to_extract] - output_data[['y']][[i]] <- cells_df[[2]][cells_to_extract] + 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( @@ -92,7 +110,8 @@ overview_projection_update_plot <- function(input) { } i <- i + 1 } - group_centers_df <- centerOfGroups(cells_df, 2, plot_parameters[['color_variable']]) + req(plot_parameters[['color_variable']] %in% getGroups()) + 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']], @@ -109,9 +128,9 @@ overview_projection_update_plot <- function(input) { for ( j in names(color_assignments) ) { output_meta[['traces']][[i]] <- j cells_to_extract <- which(color_input==j) - output_data[['x']][[i]] <- cells_df[[1]][cells_to_extract] - output_data[['y']][[i]] <- cells_df[[2]][cells_to_extract] - output_data[['z']][[i]] <- cells_df[[3]][cells_to_extract] + 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( @@ -122,7 +141,8 @@ overview_projection_update_plot <- function(input) { } i <- i + 1 } - group_centers_df <- centerOfGroups(cells_df, 3, plot_parameters[['color_variable']]) + req(plot_parameters[['color_variable']] %in% getGroups()) + 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']], 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 index 9f281e2..ebf41cb 100644 --- a/inst/shiny/v1.3/overview/obj_projection_color_assignments.R +++ b/inst/shiny/v1.3/overview/obj_projection_color_assignments.R @@ -6,10 +6,11 @@ overview_projection_color_assignments <- reactive({ overview_projection_data(), overview_projection_parameters_plot() ) - return( - assignColorsToGroups( - overview_projection_data(), - overview_projection_parameters_plot()[['color_variable']] - ) + # 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 index 04c7648..ea66ee1 100644 --- a/inst/shiny/v1.3/overview/obj_projection_data.R +++ b/inst/shiny/v1.3/overview/obj_projection_data.R @@ -2,20 +2,9 @@ ## Cell meta data and position in projection. ##----------------------------------------------------------------------------## overview_projection_data <- reactive({ - req(overview_projection_parameters_cell_filtering()) - parameters <- overview_projection_parameters_cell_filtering() - cells_df <- cbind(getProjection(parameters[["projection"]]), getMetaData()) - ## remove cells based on group filters - 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% parameters[["group_filters"]][[ i ]] ),] - } - } - ## randomly remove cells (if necessary) - cells_df <- randomlySubsetCells(cells_df, parameters[["pct_cells"]]) - ## put rows in random order - cells_df <- cells_df[ sample(1:nrow(cells_df)) , ] + 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 index 2cc4ca9..6563fd1 100644 --- a/inst/shiny/v1.3/overview/obj_projection_data_to_plot.R +++ b/inst/shiny/v1.3/overview/obj_projection_data_to_plot.R @@ -1,11 +1,17 @@ -## -overview_projection_data_to_plot <- reactive({ +##----------------------------------------------------------------------------## +## 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() + 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 { @@ -14,10 +20,39 @@ overview_projection_data_to_plot <- reactive({ overview_projection_parameters_plot()[['color_variable']] ) } - list( + ## 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 index 81db543..2765b31 100644 --- a/inst/shiny/v1.3/overview/obj_projection_hover_info.R +++ b/inst/shiny/v1.3/overview/obj_projection_hover_info.R @@ -1,10 +1,20 @@ ##----------------------------------------------------------------------------## -## Hover info. +## Hover info of cells in projection. ##----------------------------------------------------------------------------## overview_projection_hover_info <- reactive({ - req(overview_projection_data()) - cells_df <- overview_projection_data() - hover_info <- buildHoverInfoForProjections(cells_df) - hover_info <- setNames(hover_info, cells_df$cell_barcode) + 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_cell_filtering.R b/inst/shiny/v1.3/overview/obj_projection_parameters_cell_filtering.R deleted file mode 100644 index 35a8c5a..0000000 --- a/inst/shiny/v1.3/overview/obj_projection_parameters_cell_filtering.R +++ /dev/null @@ -1,25 +0,0 @@ -##----------------------------------------------------------------------------## -## Input parameters for filtering cells. -##----------------------------------------------------------------------------## -overview_projection_parameters_cell_filtering_raw <- reactive({ - req( - input[["overview_projection_to_display"]], - input[["overview_projection_percentage_cells_to_show"]] - ) - ## require group filters UI elements and at least 1 group level to be selected - for ( i in getGroups() ) { - req(input[[paste0("overview_projection_group_filter_", i)]]) - } - parameters <- list( - projection = input[["overview_projection_to_display"]], - pct_cells = input[["overview_projection_percentage_cells_to_show"]], - group_filters = list() - ) - ## store group filters - for ( i in getGroups() ) { - parameters[['group_filters']][[ i ]] <- input[[paste0("overview_projection_group_filter_", i)]] - } - return(parameters) -}) - -overview_projection_parameters_cell_filtering <- debounce(overview_projection_parameters_cell_filtering_raw, 150) diff --git a/inst/shiny/v1.3/overview/obj_projection_parameters_plot.R b/inst/shiny/v1.3/overview/obj_projection_parameters_plot.R index 22a8bd9..cffa244 100644 --- a/inst/shiny/v1.3/overview/obj_projection_parameters_plot.R +++ b/inst/shiny/v1.3/overview/obj_projection_parameters_plot.R @@ -4,7 +4,9 @@ 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"]]), @@ -13,6 +15,7 @@ overview_projection_parameters_plot_raw <- reactive({ !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"]])), @@ -26,7 +29,19 @@ overview_projection_parameters_plot_raw <- reactive({ 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/out_details_selected_cells_plot.R b/inst/shiny/v1.3/overview/out_details_selected_cells_plot.R index 53e6814..6bcdcf3 100644 --- a/inst/shiny/v1.3/overview/out_details_selected_cells_plot.R +++ b/inst/shiny/v1.3/overview/out_details_selected_cells_plot.R @@ -6,12 +6,13 @@ ##----------------------------------------------------------------------------## output[["overview_details_selected_cells_plot"]] <- plotly::renderPlotly({ req( - overview_projection_parameters_plot()[["projection"]], + 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(overview_projection_parameters_plot()[["projection"]]), + getProjection(input[["overview_projection_to_display"]]), getMetaData() ) ## check selection 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 index c496c2d..8a6f4d4 100644 --- a/inst/shiny/v1.3/overview/out_details_selected_cells_table.R +++ b/inst/shiny/v1.3/overview/out_details_selected_cells_table.R @@ -3,7 +3,10 @@ ##----------------------------------------------------------------------------## output[["overview_details_selected_cells_table"]] <- DT::renderDataTable(server = FALSE, { ## don't proceed without these inputs - req(overview_projection_parameters_plot()) + 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()) ) { @@ -15,7 +18,7 @@ output[["overview_details_selected_cells_table"]] <- DT::renderDataTable(server } else { ## extract cells for table cells_df <- cbind( - getProjection(overview_projection_parameters_plot()[["projection"]]), + getProjection(input[["overview_projection_to_display"]]), getMetaData() ) %>% as.data.frame() diff --git a/inst/shiny/v1.3/overview/out_projection.R b/inst/shiny/v1.3/overview/out_projection.R index 662bb97..20bb1ed 100644 --- a/inst/shiny/v1.3/overview/out_projection.R +++ b/inst/shiny/v1.3/overview/out_projection.R @@ -2,7 +2,21 @@ ## Plotly plot of the selected projection. ##----------------------------------------------------------------------------## output[["overview_projection"]] <- plotly::renderPlotly({ - plotly::plot_ly(type = 'scattergl', mode = 'markers', source = "overview_projection") + 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 + ) + ) }) ##----------------------------------------------------------------------------## diff --git a/inst/shiny/v1.3/overview/server.R b/inst/shiny/v1.3/overview/server.R index 87ef05f..5ecf7c4 100644 --- a/inst/shiny/v1.3/overview/server.R +++ b/inst/shiny/v1.3/overview/server.R @@ -1,7 +1,6 @@ ##----------------------------------------------------------------------------## ## Tab: Overview ##----------------------------------------------------------------------------## - files_to_load <- list.files( paste0(Cerebro.options[["cerebro_root"]], "/shiny/v1.3/overview"), pattern = "func_|obj_|UI_|out_|event_", diff --git a/inst/shiny/v1.3/plotting_functions.R b/inst/shiny/v1.3/plotting_functions.R index d09f713..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,7 +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 bf14f18..61b8b11 100644 --- a/inst/shiny/v1.3/shiny_server.R +++ b/inst/shiny/v1.3/shiny_server.R @@ -13,30 +13,43 @@ 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( + scatter_plot_point_size = list( + min = 1, + max = 20, + step = 1, + default = ifelse( + !is.null(Cerebro.options[['point_size']]), + Cerebro.options[['point_size']], + 5 + ) + ), + scatter_plot_point_opacity = list( + min = 0.1, + max = 1.0, + step = 0.1, + default = ifelse( + !is.null(Cerebro.options[['point_opacity']]), + Cerebro.options[['point_opacity']], + 1.0 + ) + ), + scatter_plot_percentage_cells_to_show = list( + min = 10, + max = 100, + step = 10, + default = ifelse( + !is.null(Cerebro.options[['percentage_cells_to_show']]), + Cerebro.options[['percentage_cells_to_show']], + 100 + ) + ), use_webgl = TRUE, - show_hover_info_in_projections = TRUE + show_hover_info_in_projections = ifelse( + !is.null(Cerebro.options[['show_hover_info_in_projections']]), + Cerebro.options[['show_hover_info_in_projections']], + TRUE + ) ) ## paths for storing plots @@ -54,7 +67,6 @@ server <- function(input, output, session) { ## listen to selected 'input_file', initialize before UI element is loaded observeEvent(input[['input_file']], ignoreNULL = FALSE, { - ## grab path from 'input_file' if one is specified if ( !is.null(input[["input_file"]]) && @@ -62,7 +74,6 @@ server <- function(input, output, session) { file.exists(input[["input_file"]]$datapath) ) { new_path <- input[["input_file"]]$datapath - ## take path from 'Cerebro.options' if it is set } else if ( exists('Cerebro.options') && @@ -70,61 +81,94 @@ server <- function(input, output, session) { file.exists(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") } - ## set reactive value to new file path data_to_load$path <- new_path }) ## 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) - ## 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()) && @@ -151,23 +195,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 ( @@ -179,7 +215,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 1e600e7..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"]] ) ) }) diff --git a/inst/shiny/v1.3/utility_functions.R b/inst/shiny/v1.3/utility_functions.R index edef7bb..fe1c0db 100644 --- a/inst/shiny/v1.3/utility_functions.R +++ b/inst/shiny/v1.3/utility_functions.R @@ -641,29 +641,12 @@ 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: {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( @@ -671,8 +654,6 @@ buildHoverInfoForProjections <- function(table) { "{group}: {table[[ group ]]}" ) } - - ## return(hover_info) } @@ -680,26 +661,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 +685,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) } @@ -771,16 +744,14 @@ getGenesForGeneSet <- function(gene_set) { ##----------------------------------------------------------------------------## ## Function to calculate center of groups in projections/trajectories. ##----------------------------------------------------------------------------## -centerOfGroups <- function(df, n_dimensions, group) { - +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 = df[,1], - y = df[,2], + x = coordinates[,1], + y = coordinates[,2], group = df[[ group ]] ) %>% dplyr::group_by(group) %>% @@ -791,15 +762,13 @@ centerOfGroups <- function(df, n_dimensions, group) { ) %>% dplyr::ungroup() %>% return() - ## ... 3 dimensions - } else if ( n_dimensions == 3 && is.numeric(df[,3]) ) { - + } else if ( n_dimensions == 3 && is.numeric(coordinates[,3]) ) { ## calculate center for groups and return tidyr::tibble( - x = df[,1], - y = df[,2], - z = df[,3], + x = coordinates[,1], + y = coordinates[,2], + z = coordinates[,3], group = df[[ group ]] ) %>% dplyr::group_by(group) %>% From edb5feee5c45cabf2b92386b4bc62060dbf8c388 Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Tue, 2 Mar 2021 23:53:59 +0100 Subject: [PATCH 23/39] Add missing object for expression tab --- inst/shiny/v1.3/gene_expression/obj_projection_data.R | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 inst/shiny/v1.3/gene_expression/obj_projection_data.R 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) +}) From 8a792cc0caf60d9e1351984a570c5f14bb18ec15 Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Wed, 3 Mar 2021 21:35:51 +0100 Subject: [PATCH 24/39] Show modal when trying to export projection with multiple panel --- .../event_projection_export_plot.R | 120 ++++++++++-------- 1 file changed, 65 insertions(+), 55 deletions(-) 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 index 4106b46..06fb0ad 100644 --- a/inst/shiny/v1.3/gene_expression/event_projection_export_plot.R +++ b/inst/shiny/v1.3/gene_expression/event_projection_export_plot.R @@ -6,9 +6,10 @@ observeEvent(input[["expression_projection_export"]], { ## 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(input_data[['coordinates']], cells_df) + cells_df <- bind_cols(coordinates, cells_df) plot_parameters <- input_data[['plot_parameters']] color_settings <- input_data[['color_settings']] trajectory <- input_data[['trajectory']] @@ -40,21 +41,30 @@ observeEvent(input[["expression_projection_export"]], { cell_order <- order(expression_levels) cells_df <- cells_df[cell_order,] } - ## check if projection or trajectory should be shown - ## ... projection - if ( plot_parameters[["projection"]] %in% availableProjections() ) { - ## check if selection projection consists of 2 or 3 dimensions - ## ... selection projection consists of 3 dimensions - if ( ncol(getProjection(plot_parameters[["projection"]])) == 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(plot_parameters[["projection"]])) == 2 ) { + ## + 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 && @@ -84,45 +94,45 @@ observeEvent(input[["expression_projection_export"]], { 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" + ) } - ## ... 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" - ) } }) From 1ca3e95e488fd88be9808bc4e183d149e477ac4a Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Wed, 3 Mar 2021 22:26:42 +0100 Subject: [PATCH 25/39] Add default parameters for projections to launch function --- R/launchCerebroV1.3.R | 54 ++++++++++++++++++++++++++++++++-- inst/shiny/v1.3/about/server.R | 6 +--- inst/shiny/v1.3/shiny_server.R | 24 +++------------ 3 files changed, 57 insertions(+), 27 deletions(-) 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/inst/shiny/v1.3/about/server.R b/inst/shiny/v1.3/about/server.R index 4dda1d6..f06fe0a 100644 --- a/inst/shiny/v1.3/about/server.R +++ b/inst/shiny/v1.3/about/server.R @@ -52,11 +52,7 @@ output[["preferences"]] <- renderUI({ checkboxInput( "hover_info_in_projections_checkbox", label = "Show hover info in projections", - value = ifelse( - !is.null(Cerebro.options[['show_hover_info_in_projections']]), - Cerebro.options[['show_hover_info_in_projections']], - TRUE - ) + value = Cerebro.options[['projections_show_hover_info']] ) ) ) diff --git a/inst/shiny/v1.3/shiny_server.R b/inst/shiny/v1.3/shiny_server.R index 61b8b11..2c9fdf3 100644 --- a/inst/shiny/v1.3/shiny_server.R +++ b/inst/shiny/v1.3/shiny_server.R @@ -18,38 +18,22 @@ server <- function(input, output, session) { min = 1, max = 20, step = 1, - default = ifelse( - !is.null(Cerebro.options[['point_size']]), - Cerebro.options[['point_size']], - 5 - ) + default = Cerebro.options[['projections_default_point_size']] ), scatter_plot_point_opacity = list( min = 0.1, max = 1.0, step = 0.1, - default = ifelse( - !is.null(Cerebro.options[['point_opacity']]), - Cerebro.options[['point_opacity']], - 1.0 - ) + default = Cerebro.options[['projections_default_point_opacity']] ), scatter_plot_percentage_cells_to_show = list( min = 10, max = 100, step = 10, - default = ifelse( - !is.null(Cerebro.options[['percentage_cells_to_show']]), - Cerebro.options[['percentage_cells_to_show']], - 100 - ) + default = Cerebro.options[['projections_default_percentage_cells_to_show']] ), use_webgl = TRUE, - show_hover_info_in_projections = ifelse( - !is.null(Cerebro.options[['show_hover_info_in_projections']]), - Cerebro.options[['show_hover_info_in_projections']], - TRUE - ) + show_hover_info_in_projections = Cerebro.options[['projections_show_hover_info']] ) ## paths for storing plots From ae73b394118f3e9735572ba940c97c57ddf43e87 Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Wed, 3 Mar 2021 22:28:09 +0100 Subject: [PATCH 26/39] Update documentation --- man/launchCerebroV1.3.Rd | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) 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}.} } From 39826b3b6127373a6531e77be9f644b4244dc742 Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Thu, 4 Mar 2021 12:50:33 +0100 Subject: [PATCH 27/39] Fix error in marker genes table --- inst/shiny/v1.3/utility_functions.R | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/inst/shiny/v1.3/utility_functions.R b/inst/shiny/v1.3/utility_functions.R index fd6b843..f5fdca7 100644 --- a/inst/shiny/v1.3/utility_functions.R +++ b/inst/shiny/v1.3/utility_functions.R @@ -132,7 +132,7 @@ prettifyTable <- function( if (number_formatting == TRUE && length(columns_percent) > 0) { for (col in columns_percent) { col_name <- colnames(table)[col] - if (max(getMetaData()[,col_name] > 1)) { + if (max(table[,col_name] > 1)) { table[,col] <- table[,col] / 100 } } @@ -464,8 +464,10 @@ prettifyTable <- function( } # show cellular barcodes in monospace font - table <- table %>% - DT::formatStyle('cell_barcode', target="cell", fontFamily="courier") + if ('cell_barcode' %in% colnames(table)) { + table <- table %>% + DT::formatStyle('cell_barcode', target="cell", fontFamily="courier") + } ## return the table return(table) From 5bcfdeccd5fb759974be2b24f976838316f4f827 Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Thu, 4 Mar 2021 16:43:24 +0100 Subject: [PATCH 28/39] Fix issue in projection in Overview tab Selecting a categorical grouping variable that is not registered as one of the official groups in the dataset would not update the plot. --- inst/shiny/v1.3/overview/func_projection_update_plot.R | 2 -- 1 file changed, 2 deletions(-) diff --git a/inst/shiny/v1.3/overview/func_projection_update_plot.R b/inst/shiny/v1.3/overview/func_projection_update_plot.R index ffdd670..9842ad4 100644 --- a/inst/shiny/v1.3/overview/func_projection_update_plot.R +++ b/inst/shiny/v1.3/overview/func_projection_update_plot.R @@ -110,7 +110,6 @@ overview_projection_update_plot <- function(input) { } i <- i + 1 } - req(plot_parameters[['color_variable']] %in% getGroups()) group_centers_df <- centerOfGroups(coordinates, cells_df, 2, plot_parameters[['color_variable']]) output_group_centers <- list( group = group_centers_df[['group']], @@ -141,7 +140,6 @@ overview_projection_update_plot <- function(input) { } i <- i + 1 } - req(plot_parameters[['color_variable']] %in% getGroups()) group_centers_df <- centerOfGroups(coordinates, cells_df, 3, plot_parameters[['color_variable']]) output_group_centers <- list( group = group_centers_df[['group']], From c4efa0a02368730d1644095a8f1e46d484ddd9ca Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Fri, 5 Mar 2021 18:28:16 +0100 Subject: [PATCH 29/39] Prevent errors in "Groups" tab after changing datasets --- inst/shiny/v1.3/groups/cell_cycle.R | 8 ++++---- inst/shiny/v1.3/groups/composition.R | 6 +++--- inst/shiny/v1.3/groups/expression_metrics.R | 8 ++++---- inst/shiny/v1.3/groups/tree.R | 4 ++-- 4 files changed, 13 insertions(+), 13 deletions(-) diff --git a/inst/shiny/v1.3/groups/cell_cycle.R b/inst/shiny/v1.3/groups/cell_cycle.R index d2b7bbd..c99450d 100644 --- a/inst/shiny/v1.3/groups/cell_cycle.R +++ b/inst/shiny/v1.3/groups/cell_cycle.R @@ -89,8 +89,8 @@ output[["groups_by_cell_cycle_UI_rest"]] <- renderUI({ ##----------------------------------------------------------------------------## 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" ) { @@ -142,8 +142,8 @@ 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( diff --git a/inst/shiny/v1.3/groups/composition.R b/inst/shiny/v1.3/groups/composition.R index 33f283a..ef782ed 100644 --- a/inst/shiny/v1.3/groups/composition.R +++ b/inst/shiny/v1.3/groups/composition.R @@ -24,7 +24,7 @@ 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", @@ -89,8 +89,8 @@ 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"]] ) diff --git a/inst/shiny/v1.3/groups/expression_metrics.R b/inst/shiny/v1.3/groups/expression_metrics.R index 0f0c517..a62a758 100644 --- a/inst/shiny/v1.3/groups/expression_metrics.R +++ b/inst/shiny/v1.3/groups/expression_metrics.R @@ -57,7 +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", @@ -84,7 +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", @@ -111,7 +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", @@ -138,7 +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", diff --git a/inst/shiny/v1.3/groups/tree.R b/inst/shiny/v1.3/groups/tree.R index de9002a..d6b786b 100644 --- a/inst/shiny/v1.3/groups/tree.R +++ b/inst/shiny/v1.3/groups/tree.R @@ -67,7 +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( @@ -92,7 +92,7 @@ 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"]], From 7d58d402dafde5255de0b0db7445ac1ccc888599 Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Sat, 6 Mar 2021 12:01:42 +0100 Subject: [PATCH 30/39] Fix issue of cell barcodes not being shown in monospace font --- inst/shiny/v1.3/utility_functions.R | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/inst/shiny/v1.3/utility_functions.R b/inst/shiny/v1.3/utility_functions.R index f5fdca7..7ffacfc 100644 --- a/inst/shiny/v1.3/utility_functions.R +++ b/inst/shiny/v1.3/utility_functions.R @@ -228,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 @@ -463,12 +472,6 @@ prettifyTable <- function( } } - # show cellular barcodes in monospace font - if ('cell_barcode' %in% colnames(table)) { - table <- table %>% - DT::formatStyle('cell_barcode', target="cell", fontFamily="courier") - } - ## return the table return(table) From 956f5640d72626431f6b31d3d8c9550b42d58693 Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Sat, 6 Mar 2021 12:40:54 +0100 Subject: [PATCH 31/39] Handle tables server-side With large datasets, this greatly increases performance. --- inst/shiny/v1.3/enriched_pathways/table.R | 2 +- inst/shiny/v1.3/extra_material/content.R | 2 +- inst/shiny/v1.3/gene_expression/UI_table_of_selected_cells.R | 2 +- inst/shiny/v1.3/marker_genes/table.R | 2 +- inst/shiny/v1.3/most_expressed_genes/table.R | 2 +- inst/shiny/v1.3/overview/out_details_selected_cells_table.R | 2 +- inst/shiny/v1.3/trajectory/selected_cells_table.R | 2 +- 7 files changed, 7 insertions(+), 7 deletions(-) diff --git a/inst/shiny/v1.3/enriched_pathways/table.R b/inst/shiny/v1.3/enriched_pathways/table.R index 2f843b9..eaedff6 100644 --- a/inst/shiny/v1.3/enriched_pathways/table.R +++ b/inst/shiny/v1.3/enriched_pathways/table.R @@ -170,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/content.R b/inst/shiny/v1.3/extra_material/content.R index 050ef5f..0e946e9 100644 --- a/inst/shiny/v1.3/extra_material/content.R +++ b/inst/shiny/v1.3/extra_material/content.R @@ -70,7 +70,7 @@ 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"]] diff --git a/inst/shiny/v1.3/gene_expression/UI_table_of_selected_cells.R b/inst/shiny/v1.3/gene_expression/UI_table_of_selected_cells.R index f54172d..3411508 100644 --- a/inst/shiny/v1.3/gene_expression/UI_table_of_selected_cells.R +++ b/inst/shiny/v1.3/gene_expression/UI_table_of_selected_cells.R @@ -37,7 +37,7 @@ output[["expression_details_selected_cells_UI"]] <- renderUI({ ##----------------------------------------------------------------------------## ## Table with results. ##----------------------------------------------------------------------------## -output[["expression_details_selected_cells"]] <- DT::renderDataTable(server = FALSE, { +output[["expression_details_selected_cells"]] <- DT::renderDataTable({ req( expression_projection_data(), expression_projection_coordinates(), diff --git a/inst/shiny/v1.3/marker_genes/table.R b/inst/shiny/v1.3/marker_genes/table.R index c5d3550..e2f5edc 100644 --- a/inst/shiny/v1.3/marker_genes/table.R +++ b/inst/shiny/v1.3/marker_genes/table.R @@ -131,7 +131,7 @@ 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"]], diff --git a/inst/shiny/v1.3/most_expressed_genes/table.R b/inst/shiny/v1.3/most_expressed_genes/table.R index a1b574a..ddeafb8 100644 --- a/inst/shiny/v1.3/most_expressed_genes/table.R +++ b/inst/shiny/v1.3/most_expressed_genes/table.R @@ -98,7 +98,7 @@ output[["most_expressed_genes_filter_subgroups_UI"]] <- renderUI({ ##----------------------------------------------------------------------------## ## Table with results. ##----------------------------------------------------------------------------## -output[["most_expressed_genes_table"]] <- DT::renderDataTable(server = FALSE, { +output[["most_expressed_genes_table"]] <- DT::renderDataTable({ selected_group <- input[['most_expressed_genes_selected_group']] req(selected_group %in% getGroups()) ## fetch results 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 index 8a6f4d4..bc51725 100644 --- a/inst/shiny/v1.3/overview/out_details_selected_cells_table.R +++ b/inst/shiny/v1.3/overview/out_details_selected_cells_table.R @@ -1,7 +1,7 @@ ##----------------------------------------------------------------------------## ## Table. ##----------------------------------------------------------------------------## -output[["overview_details_selected_cells_table"]] <- DT::renderDataTable(server = FALSE, { +output[["overview_details_selected_cells_table"]] <- DT::renderDataTable({ ## don't proceed without these inputs req( input[["overview_projection_to_display"]], diff --git a/inst/shiny/v1.3/trajectory/selected_cells_table.R b/inst/shiny/v1.3/trajectory/selected_cells_table.R index 5d59d19..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( From 42b2b500af49f46680c94c9038dd8058d4b6fb83 Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Sat, 6 Mar 2021 14:48:32 +0100 Subject: [PATCH 32/39] Use comma format in Y axis hovers and ticks in plot of selected cells This applies to the projection in the "Overview" tab. --- inst/shiny/v1.3/overview/out_details_selected_cells_plot.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/inst/shiny/v1.3/overview/out_details_selected_cells_plot.R b/inst/shiny/v1.3/overview/out_details_selected_cells_plot.R index 6bcdcf3..d67d683 100644 --- a/inst/shiny/v1.3/overview/out_details_selected_cells_plot.R +++ b/inst/shiny/v1.3/overview/out_details_selected_cells_plot.R @@ -129,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 ), From 3f1404323b7f700aa70690dd131879359653a335 Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Mon, 8 Mar 2021 12:30:24 +0100 Subject: [PATCH 33/39] Fix color assignments to groups in plot of selected cells (overview tab) Only occurred in some cases. --- inst/shiny/v1.3/overview/out_details_selected_cells_plot.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/inst/shiny/v1.3/overview/out_details_selected_cells_plot.R b/inst/shiny/v1.3/overview/out_details_selected_cells_plot.R index d67d683..2a42b74 100644 --- a/inst/shiny/v1.3/overview/out_details_selected_cells_plot.R +++ b/inst/shiny/v1.3/overview/out_details_selected_cells_plot.R @@ -70,11 +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, From 8c720b88b058ab603ae645b7920711ab4e4b4c05 Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Mon, 8 Mar 2021 12:32:06 +0100 Subject: [PATCH 34/39] Extract columns as vectors using double square brackets When using a tibble instead of a standard data frame, the previous procedure would return a tibble with a single column instead of a vector. --- inst/shiny/v1.3/utility_functions.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/inst/shiny/v1.3/utility_functions.R b/inst/shiny/v1.3/utility_functions.R index 7ffacfc..9da0a1d 100644 --- a/inst/shiny/v1.3/utility_functions.R +++ b/inst/shiny/v1.3/utility_functions.R @@ -770,8 +770,8 @@ centerOfGroups <- function(coordinates, df, n_dimensions, group) { if ( n_dimensions == 2 ) { ## calculate center for groups and return tidyr::tibble( - x = coordinates[,1], - y = coordinates[,2], + x = coordinates[[1]], + y = coordinates[[2]], group = df[[ group ]] ) %>% dplyr::group_by(group) %>% @@ -786,9 +786,9 @@ centerOfGroups <- function(coordinates, df, n_dimensions, group) { } 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], + x = coordinates[[1]], + y = coordinates[[2]], + z = coordinates[[3]], group = df[[ group ]] ) %>% dplyr::group_by(group) %>% From ac48f9c5971c61ee89a7afe49fc419330171ccee Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Mon, 8 Mar 2021 18:16:47 +0100 Subject: [PATCH 35/39] Allow initialization of default data set from existing object When "Cerebro.options$crb_file_to_load" is set to the name of an existing object in the R environment, the specified object will be loaded as a data set on launch. This is particularly useful when hosting Cerebro on a server in "closed" mode because the data set can be loaded on server launch and does not need to be loaded in each user session. --- inst/shiny/v1.3/shiny_server.R | 37 ++++++++++++++++++++++------------ 1 file changed, 24 insertions(+), 13 deletions(-) diff --git a/inst/shiny/v1.3/shiny_server.R b/inst/shiny/v1.3/shiny_server.R index 2c9fdf3..b3456a0 100644 --- a/inst/shiny/v1.3/shiny_server.R +++ b/inst/shiny/v1.3/shiny_server.R @@ -51,34 +51,45 @@ 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 From 1834e451cb835f8a32701bbbb245005093c02a25 Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Mon, 8 Mar 2021 18:24:01 +0100 Subject: [PATCH 36/39] Update article about hosting Cerebro on shinyapps Add recommendation to load data set once when running closed mode. --- vignettes/host_cerebro_on_shinyapps.Rmd | 38 +++++++++++++++++++++++++ 1 file changed, 38 insertions(+) diff --git a/vignettes/host_cerebro_on_shinyapps.Rmd b/vignettes/host_cerebro_on_shinyapps.Rmd index 8b3e026..dcc9fb2 100644 --- a/vignettes/host_cerebro_on_shinyapps.Rmd +++ b/vignettes/host_cerebro_on_shinyapps.Rmd @@ -120,6 +120,44 @@ shiny::shinyApp( ) ``` +When hosting Cerebo in `closed` mode, meaning that you host it together with a data set that users cannot change, it is recommended to load the data set once on server launch and set `Cerebro.options$crb_file_to_load` to that: + +```{r eval=FALSE} +## 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 +) +``` + # Deploy app Now, it is time to upload the app the shinyapps.io. From d42fca572ad436725b7aaef954fa98e394e64f8c Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Mon, 8 Mar 2021 19:21:18 +0100 Subject: [PATCH 37/39] Make ot optional to provide default options for projections --- inst/shiny/v1.3/shiny_server.R | 28 ++++++++++++++++++++++++---- 1 file changed, 24 insertions(+), 4 deletions(-) diff --git a/inst/shiny/v1.3/shiny_server.R b/inst/shiny/v1.3/shiny_server.R index b3456a0..c184427 100644 --- a/inst/shiny/v1.3/shiny_server.R +++ b/inst/shiny/v1.3/shiny_server.R @@ -18,22 +18,42 @@ server <- function(input, output, session) { min = 1, max = 20, step = 1, - default = Cerebro.options[['projections_default_point_size']] + 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 = Cerebro.options[['projections_default_point_opacity']] + 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 = Cerebro.options[['projections_default_percentage_cells_to_show']] + 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 = Cerebro.options[['projections_show_hover_info']] + 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 From 7cf3e5dd12bef369b0a04cf9baf1217c34b48ce6 Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Fri, 12 Mar 2021 17:48:29 +0100 Subject: [PATCH 38/39] Remove example of launching Cerebro with a loaded Cerebro object --- vignettes/host_cerebro_on_shinyapps.Rmd | 38 ------------------------- 1 file changed, 38 deletions(-) diff --git a/vignettes/host_cerebro_on_shinyapps.Rmd b/vignettes/host_cerebro_on_shinyapps.Rmd index dcc9fb2..8b3e026 100644 --- a/vignettes/host_cerebro_on_shinyapps.Rmd +++ b/vignettes/host_cerebro_on_shinyapps.Rmd @@ -120,44 +120,6 @@ shiny::shinyApp( ) ``` -When hosting Cerebo in `closed` mode, meaning that you host it together with a data set that users cannot change, it is recommended to load the data set once on server launch and set `Cerebro.options$crb_file_to_load` to that: - -```{r eval=FALSE} -## 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 -) -``` - # Deploy app Now, it is time to upload the app the shinyapps.io. From acaf4a262557822e899e1ab57a2029da816bb3d1 Mon Sep 17 00:00:00 2001 From: Roman Hillje Date: Fri, 12 Mar 2021 18:11:30 +0100 Subject: [PATCH 39/39] Bump version to 1.3.1 and update changelog --- DESCRIPTION | 2 +- NEWS.md | 28 ++++++++++++++ .../loading_cerebro_with_loaded_data_set.md | 37 +++++++++++++++++++ 3 files changed, 66 insertions(+), 1 deletion(-) create mode 100644 other_documents/loading_cerebro_with_loaded_data_set.md 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/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 +) +```