diff --git a/GRN/.gitignore b/GRN/.gitignore index 447baaf..7ee84b8 100644 --- a/GRN/.gitignore +++ b/GRN/.gitignore @@ -10,4 +10,7 @@ explore data/shared data/joint_cortex data/joint_pons +shiny_bookmarks +data/ct_e12 +data/ct_e12_not_needed diff --git a/GRN/data/data.json b/GRN/data/data.json index daf2de2..d29d6ad 100644 --- a/GRN/data/data.json +++ b/GRN/data/data.json @@ -24,6 +24,13 @@ "contents": "Several R objects: forebrain_data, TF_and_ext, TF_active, metadata, tf_df, cell_metadata_cortex,binary_activity data", "script": "data_prep.R" + }, + { + "file": "joint_cortex.regulon_activity_per_joint_cluster.feather", + "description": "feather file containing average TF activity per joint cluster instead of per sample cluster in the forebrain.", + "contents": "a data frame with a joint cluster column and columns corresponding to TFs and their activity in each cluster.", + "script": "data_prep.R" + }, { "file": "Forebrain_join.2D.tsv", @@ -31,6 +38,13 @@ "description": "Cell-level information for forebrain data, including corresponding clusters and UMAP/tSNE/PCA coordinates, used to plot scatterplots", "contents": "Data frame with columns, 'Cell' 'Sample' 'Sample_cluster', followed by columns for embedding coordinates." + }, + { + "file": "Jessa2019_Table_2b_joint_cortex_metadata.tsv", + "path": "selin.jessa/from_hydra/single_cell/scDev_data/data/metadata/Jessa2019_Table_2b_joint_cortex_metadata.tsv", + "description": "Joint_cluster-level information for forebrain data, including color palatte for each cluster, used to color scatter plots", + "contents": "Data frame with columns, 'Cluster_number' 'Color' 'Cell_type' 'Sample' etc., followed by summary info for each cluster." + }, { @@ -82,6 +96,20 @@ "script": "data_prep.R" }, + { + "file": "joint_pons.regulon_activity_per_joint_cluster.feather", + "description": "feather file containing average TF activity per joint cluster instead of per sample cluster in the pons.", + "contents": "a data frame with a joint cluster column and columns corresponding to TFs and their activity in each cluster.", + "script": "data_prep.R" + + }, + { + "file": "Jessa2019_Table_2c_joint_pons_metadata.tsv", + "path": "selin.jessa/from_hydra/single_cell/scDev_data/data/metadata/Jessa2019_Table_2c_joint_pons_metadata.tsv", + "description": "Joint_cluster-level information for forebrain data, including color palatte for each cluster, used to color scatter plots", + "contents": "Data frame with columns, 'Cluster_number' 'Color' 'Cell_type' 'Sample' etc., followed by summary info for each cluster." + + }, { "file": "Pons_join.2D.tsv", "path": "selin.jessa/from_hydra/single_cell/scDev_data/data/joint_pons/Pons_join.2D.tsv", diff --git a/GRN/functions.R b/GRN/functions.R index 7e5dec2..5705d0e 100644 --- a/GRN/functions.R +++ b/GRN/functions.R @@ -1,3 +1,33 @@ +##----------------------------ggplot style--------------------------------------------- +theme_min <- function(base_size = 11, base_family = "", + border_colour = "black", + border_size = 1) { + + theme_light(base_size = 11, base_family = "") + + theme( + panel.grid.major = element_blank(), + panel.grid.minor = element_blank(), + panel.background = element_blank(), + panel.border = element_rect(fill = NA, colour = border_colour, size = border_size), + axis.ticks = element_line(colour = border_colour), + strip.background = element_rect(fill = NA, colour = NA), + strip.text.x = element_text(colour = "black", size = rel(1.2)), + strip.text.y = element_text(colour = "black", size = rel(1.2)), + title = element_text(size = rel(0.9)), + axis.text = element_text(colour = "black", size = rel(1.2)), + axis.title = element_text(colour = "black", size = rel(1.5)), + legend.title = element_text(colour = "black", size = rel(1.2)), + legend.key.size = unit(0.9, "lines"), + legend.text = element_text(size = rel(0.7), colour = "black"), + legend.key = element_rect(colour = NA, fill = NA), + legend.background = element_rect(colour = NA, fill = NA) + ) +} + + + + +#----------------------------TF information table--------------------------------------------- #function to add a column to data-table containing the HTML code necessary to display the motif logo addMotifPic <- function(subset_data){ #need to comment this and test to see if it works when I have wifi subset_data <- mutate(subset_data, motif_logo = bestMotif) @@ -11,13 +41,176 @@ addMotifPic <- function(subset_data){ #need to comment this and test to see if i return(subset_data) } +#------------------------------Bubble plot-------------------------------------- +#' Prepare input for bubble_plot +#' +#' Load gene expression data from feather, tidy & optionally scale expression, +#' and return the dataframe required as input for the bubble_plot() function +#' +#' @param gene Character vector, one or more genes of interest to plot +#' @param scale Logical, whether or not to linearly scale gene expression across +#' clusters to [0,1] to improve visualization. Default: TRUE +#' @param show_mean Logical, whether or not to display the mean expression of +#' given genes in a new bubble plot line. Default: FALSE +#' TODO: Use this to provide an option to download the underlying data. +#' +#' @examples +#' bubble_prep("Dlx1") +#' bubble_prep <- function(tf, +#' scale = TRUE, +#' show_mean = FALSE, +#' region) { +#' +#' # Load the mean expression of genes across clusters, given gene of interest +#' file_path <- glue("data/joint_{region}/joint_cortex.regulon_activity_per_cluster.feather") +#' exp <- read_feather(path = file_path, +#' columns = c("Cluster", tf)) #%>% +#' #dendogram_order from hydra file, commented out for now because no dendogram +#' #filter(Cluster %in% dendrogram_order) +#' +#' # Scale expression of each gene linearly across clusters to [0, 1] +#' if (scale) { +#' +#' exp <- exp %>% +#' as.data.frame() %>% +#' tibble::column_to_rownames(var = "Cluster") %>% +#' apply(2, scales::rescale, to = c(0, 1)) %>% +#' as.data.frame %>% +#' tibble::rownames_to_column(var = "Cluster") +#' +#' } +#' +#' # Convert to long / tidy format with columns: Cluster, Gene, Expression +#' exp <- exp %>% +#' gather(., "TF", "Activity", 2:ncol(.)) +#' +#' # Probably don't need this in the TF plot +#' # # Load the proportion of cells in each cluster in which each gene was detected, +#' # # and convert to long / tidy format with columns: Cluster, Gene, Pct1 +#' # pct1 <- read_feather("data/joint_mouse/pct1_per_ID_20190715_cluster.feather", +#' # columns = c("Cluster", gene)) %>% +#' # gather(., "Gene", "Pct1", 2:ncol(.)) +#' +#' # # Join with cluster metadata +#' # df <- left_join(exp, pct1, by = c("Cluster", "Gene")) %>% +#' # left_join(metadata, by = c("Cluster" = "Cluster_nounderscore")) +#' +#' # Tidy data for plotting +#' df <- df %>% +#' +#' # Order genes to match order input by user +#' mutate(TF = factor(TF, levels = rev(TF))) %>% +#' arrange(TF) %>% +#' +#' # Pad gene names so that the plot takes up a more standardized +#' # width; to roughly the the # of characters in the gene w/ longest name +#' # However, letters take up more pixels than spaces, so do less padding +#' # for genes with longer names +#' # TODO: Test the (commented) third line inside mutate() and adjust padding as required +#' mutate(TF_padded = case_when( +#' str_length(TF) <= 5 ~ str_pad(TF, 15, side = 'right', pad = " "), +#' between(str_length(TF), 5, 8) ~ str_pad(TF, 12, side = 'right', pad = " ") +#' #, str_length(Gene) > 8 ~ str_pad(Gene, 9, side = 'right', pad = " ") +#' ) +#' ) %>% +#' mutate(TF_padded = factor(TF_padded, levels = unique(.$TF_padded))) %>% +#' +#' # Order the clusters on the x-axis to match the dendrogram image +#' mutate(Cluster = factor(Cluster, levels = dendrogram_order)) %>% +#' +#' filter(!is.na(Cluster)) %>% +#' +#' # Convert NAs (undetected genes) to 0s -- this ensures all +#' # clusters have a value for all genes, so that all clusters are plot, +#' # even if the gene was undetected +#' replace_na(list(Expression = 0, Pct1 = 0)) %>% +#' +#' # Keep columns +#' select(Gene, Cluster, Sample, Cell_type, Cell_class, N_cells, Expression, Pct1, Sample, Colour, Gene_padded) +#' +#' # Create & append set of rows containing mean expression over all selected genes +#' if(show_mean) { +#' +#' # Create mean expression rows, preserving information for tooltip +#' mean_exp <- df %>% +#' group_by(Cluster, Sample, Cell_type, N_cells, Cell_class, Colour) %>% +#' summarize(#Gene = "MEAN", +#' #Cluster = Cluster, +#' #Sample = Sample, +#' #Cell_type = Cell_type, +#' #Cell_class = Cell_class, +#' #N_cells = N_cells, +#' Expression = mean(Expression) +#' #Pct1 = mean(Pct1), +#' #Colour = Colour, +#' #Gene_padded = "MEAN" +#' ) %>% +#' # Remove the Pct1 value from the mean expression +#' # and label the mean expression +#' mutate(Pct1 = 1, Gene = "MEAN", Gene_padded = "MEAN") +#' +#' # Add the rows containing mean expression to the original dataframe, +#' # removing duplicate rows and ordering them once more by user input, +#' # except the mean which is placed at the bottom +#' gene_order_padded <- levels(df$Gene_padded) +#' df <- bind_rows(df, mean_exp) %>% +#' distinct(.) %>% +#' mutate(Gene_padded = factor(Gene_padded, levels = c("MEAN", gene_order_padded))) +#' +#' } +#' +#' return(df) +#' +#' } +#' +#' +#' #' Bubbleplot of gene expression +#' #' +#' #' Generate a bubble plot for genes of interest across clusters in the mouse +#' #' dendrogram, where bubble colour encodes the mean expression in each cluster +#' #' and bubble size encodes the proportion of cells where each gene is detected +#' #' +#' #' @param df Data frame as returned by bubble_prep(), with require columns Cluster, +#' #' Gene_padded, Pct1, and Expression +#' #' +#' #' @return ggplot2 object +#' #' +#' #' @examples +#' #' bubble_prep("Dlx1") %>% bubbleplot() +#' #' +#' #' @export +#' bubble_plot <- function(df, max_point_size) { +#' +#' # Generate plot +#' p1 <- df %>% +#' ggplot(aes(x = Cluster, y = Gene_padded)) + +#' geom_point(aes(size = Pct1, colour = Expression), alpha = 0.8) + +#' scale_size_area(max_size = max_point_size) + +#' scale_color_gradientn(colours = tail(rdbu, 70)) + +#' theme_min() + +#' ylab(NULL) + +#' theme(axis.text.x = element_text(angle = 90, hjust = 1, vjust = 0.5, +#' colour = joint_mouse_palette, size = rel(0.7)), +#' panel.grid.major.x = element_line(colour = "grey90"), +#' panel.border = element_blank(), +#' axis.ticks.x = element_blank(), +#' axis.ticks.y = element_blank(), +#' # Do not show the legend because it is included in the static +#' # dendrogram image displayed above the bubbleplot +#' legend.position = "bottom") + +#' # Put gene labels on the right hand side to improve alignment +#' scale_y_discrete(position = "right") +#' +#' return(p1) +#' +#' } #----------------------------ggNet visualisation--------------------------------------------- #function to create an igraph object #' @param tf the user input vector of transcription factors #' @param tf_target_gene_info a data frame containing information for each association #' between a TF and a target gene; created in data_prep.R, loaded in global.R and used depending #' on the region input in input_new() -make_igraph <- function(tf, tf_target_gene_info, gene_list, labelNodes){ +make_network <- function(tf, tf_target_gene_info, gene_list){ #add a step to select only the transcription factors that are in the list #create edgelist edges <- data_cortex$TF_target_gene_info %>% select(TF, gene, nMotifs, Genie3Weight.weight) %>% @@ -36,25 +229,35 @@ make_igraph <- function(tf, tf_target_gene_info, gene_list, labelNodes){ #making a basic igraph object with an attribute for each gene indicating if it is a gene #target or transcription factor net <- graph_from_data_frame(d=edges, vertices = nodes) %>% - set_vertex_attr("Gene_Type", index = unique_gene_targets, "Gene Target") %>% - set_vertex_attr("Gene_Type", index = gene_list_in_network, "Input Gene") %>% - set_vertex_attr("Gene_Type", index = unique_TF, "TF") #%>% - #set_vertex_attr("label_always", index = unique_TF, "yes") + set_vertex_attr("Gene_Type", index = unique_gene_targets, "Target Genes") %>% + set_vertex_attr("Gene_Type", index = gene_list_in_network, "Input Target Genes") %>% + set_vertex_attr("Gene_Type", index = unique_TF, "TF") +} +plot_network <- function(net, labelNodes, tf){ if(labelNodes){ - set.seed(2) - ggnet2(net, color = "Gene_Type", label = labelNodes, label.size = 3, size = "Gene_Type", - size.palette = c("Gene Target" = 6, "TF" = 6, "Input Gene" = 6), - palette = c("Gene Target" = "grey", "TF" = "lightblue", "Input Gene" = "orange")) + - guides(size = FALSE) + set.seed(0.926) + ggnet2(net, color = "Gene_Type", alpha = "Gene_Type", size = "Gene_Type", shape = "Gene_Type", + label = labelNodes, label.size = 3, + mode = "fruchtermanreingold", layout.par = list(niter = 1000), + size.palette = c("Target Genes" = 2, "TF" = 6, "Input Target Genes" = 6), + alpha.palette = c("Target Genes" = "1", "TF" = "1", "Input Target Genes" = "1"), + shape.palette = c("Target Genes" = "19", "TF" = "19", "Input Target Genes" = "19"), + palette = c("Target Genes" = "grey", "TF" = "lightblue", "Input Target Genes" = "orange"), + group = 1, text = names(V(net))) + + guides(size = FALSE, alpha = FALSE, shape = FALSE, color = guide_legend(title = "Gene Type")) } else{ - set.seed(2) - ggnet2(net, color = "Gene_Type", label = tf, label.size = 3, size = "Gene_Type", - mode = "fruchtermanreingold", laout.par = list(niter = 1000), - size.palette = c("Gene Target" = 2, "TF" = 6, "Input Gene" = 6), - palette = c("Gene Target" = "grey", "TF" = "lightblue", "Input Gene" = "orange")) + - guides(size = FALSE) + set.seed(0.926) + ggnet2(net, color = "Gene_Type", alpha = "Gene_Type", size = "Gene_Type", shape = "Gene_Type", + label = tf, label.size = 3, + mode = "fruchtermanreingold", layout.par = list(niter = 1000), + size.palette = c("Target Genes" = 2, "TF" = 6, "Input Target Genes" = 6), + alpha.palette = c("Target Genes" = "1", "TF" = "1", "Input Target Genes" = "1"), + shape.palette = c("Target Genes" = "19", "TF" = "19", "Input Target Genes" = "19"), + palette = c("Target Genes" = "grey", "TF" = "lightblue", "Input Target Genes" = "orange"), + group = 1, text = names(V(net))) + + guides(size = FALSE, alpha = FALSE, shape = FALSE, color = guide_legend(title = "Gene Type")) } } @@ -83,56 +286,56 @@ make_igraph <- function(tf, tf_target_gene_info, gene_list, labelNodes){ #' network <- createCytoscapeJsNetwork(nodeData, edgeData) #' rcytoscapejs2(network$nodes, network$edges) #' -create_network <- function(tf, TF_target_gene, unique_TF, pathway_genes = c(), - shrink_gray = FALSE){ - TF_interest <- filter(TF_target_gene, TF %in% tf)[["TF"]] - gene_target <- filter(TF_target_gene, TF %in% tf)[["gene"]] - - source <- TF_interest - target <- gene_target - - id <- c(TF_interest, gene_target) - name <- id - nodeData <- data.frame(id,name, stringsAsFactors = FALSE) - edgeData <- data.frame(source, target, stringsAsFactors = FALSE) - - #unique_TF <- unique(TF_target_gene[["TF"]]) - - mutual_target <- edgeData %>% - # a character vector that indicates the nodes that are target of multiple selected TFs - count(target) %>% - filter(n > 1 & !target %in% tf ) %>% - .[[1]] - - nodeData <- nodeData %>% - # you can customize the color using the case_when structure easily, - # check the tfs in id column that exist in your vector, then you can control its size, - # shape and color easily - mutate(color = case_when(id %in% tf ~ "#9d4097", # orange - # orange nodes are tfs that are active in this region - id %in% pathway_genes ~ "green", - id %in% unique_TF ~ "#D6604D", - id %in% mutual_target ~ "#4fafc6", - TRUE ~ "lightgrey")) %>% - mutate(height = case_when(id %in% tf ~ "100", - TRUE ~ "70")) %>% - mutate(width = case_when(id %in% tf ~ "100", - TRUE ~ "70")) - - if(shrink_gray){ - nodeData <- nodeData %>% - mutate(height = case_when(color %in% "lightgrey" ~ "40", - TRUE ~ "70")) %>% - mutate(width = case_when(color %in% "lightgrey" ~ "40", - TRUE ~ "70")) - - } - - return(list(nodes = nodeData, - edges = edgeData - )) -} -# ------------------------------------------------------------------------------------ +# create_network <- function(tf, TF_target_gene, unique_TF, pathway_genes = c(), +# shrink_gray = FALSE){ +# TF_interest <- filter(TF_target_gene, TF %in% tf)[["TF"]] +# gene_target <- filter(TF_target_gene, TF %in% tf)[["gene"]] +# +# source <- TF_interest +# target <- gene_target +# +# id <- c(TF_interest, gene_target) +# name <- id +# nodeData <- data.frame(id,name, stringsAsFactors = FALSE) +# edgeData <- data.frame(source, target, stringsAsFactors = FALSE) +# +# #unique_TF <- unique(TF_target_gene[["TF"]]) +# +# mutual_target <- edgeData %>% +# # a character vector that indicates the nodes that are target of multiple selected TFs +# count(target) %>% +# filter(n > 1 & !target %in% tf ) %>% +# .[[1]] +# +# nodeData <- nodeData %>% +# # you can customize the color using the case_when structure easily, +# # check the tfs in id column that exist in your vector, then you can control its size, +# # shape and color easily +# mutate(color = case_when(id %in% tf ~ "#9d4097", # orange +# # orange nodes are tfs that are active in this region +# id %in% pathway_genes ~ "green", +# id %in% unique_TF ~ "#D6604D", +# id %in% mutual_target ~ "#4fafc6", +# TRUE ~ "lightgrey")) %>% +# mutate(height = case_when(id %in% tf ~ "100", +# TRUE ~ "70")) %>% +# mutate(width = case_when(id %in% tf ~ "100", +# TRUE ~ "70")) +# +# if(shrink_gray){ +# nodeData <- nodeData %>% +# mutate(height = case_when(color %in% "lightgrey" ~ "40", +# TRUE ~ "70")) %>% +# mutate(width = case_when(color %in% "lightgrey" ~ "40", +# TRUE ~ "70")) +# +# } +# +# return(list(nodes = nodeData, +# edges = edgeData +# )) +# } +# --------------------------------Helper functions---------------------------------------------------- #' Identify transcription factor data type #' #' Generate a tibble that has two columns indicating whether the tf has ext type, @@ -242,7 +445,7 @@ tf_ext <- function(TF, TF_and_ext){ filter(TF_and_ext, type==TF & ext=="ext")[[1,1]] } -# --------------------------------Tab2 data-------------------------------- +# --------------------------------Create data for plots-------------------------------- # NOTE: TF_and_ext is a dataframe (loaded already) that created in order to identify # whether the TF data is a regular TF (with high confidence annotation) # or ext type(with lower confidence) @@ -343,7 +546,7 @@ create_activity_data <- function(tf, method, region, TF_and_ext, timepoint = NUL } -#--------------------------------Tab 2: heatmap---------------------------------- +#--------------------------------Heatmap---------------------------------- # This function takes a colour palette as input, # and creates the data formats needed to annotate # a pheatmap with some colours @@ -384,7 +587,7 @@ makePheatmapAnno <- function(palette, column) { #' plot_heatmap(c("Pax6","Lef1"), "Cluster","pons", TF_and_ext_pon, pon_data) #' plot_heatmap(c("Pax6","Lef1"), "Cell","pons", TF_and_ext_pon,pon_data) #' -plot_heatmap <- function(tf,method, region, TF_and_ext, brain_data, cell_plot_num = 300, timepoint = NULL){ +plot_heatmap <- function(tf, method, region, TF_and_ext, brain_data, cell_plot_num = 300, timepoint = NULL){ # sanity checking if(!region %in% c("cortex", "pons")) return("Wrong usage: region should be either cortex/pons") if(!method %in% c("Cell","Cluster", "joint")) return("Wrong usage, method should be Cell/Cluster") @@ -445,12 +648,18 @@ plot_heatmap <- function(tf,method, region, TF_and_ext, brain_data, cell_plot_nu show_colname_plot <- TRUE title <- "Transcription Factor Regulon Activity per Cluster" } + cluster_row <- FALSE + #do not do row clustering if there is only one TF selected + if(length(tf) > 1){ + cluster_row <- TRUE + } pheatmap::pheatmap(t(act), show_colnames = show_colname_plot, scale = "none", border_color = NA, color = colorRampPalette(c("blue", "white", "red"))(100), main = title, + cluster_rows = cluster_row, #annotation_col = anno_col, # change the default color annotation annotation_colors = hm_anno_new$side_colors, # loaded by data_prep.R @@ -459,7 +668,7 @@ plot_heatmap <- function(tf,method, region, TF_and_ext, brain_data, cell_plot_nu cellheight = 10) } - +#----------------------------Dimension reduction--------------------------------------------- #' Make UMAP clustering scatterplot #' #' @param tf_number Either 1 or 2. In the tf input vector we get from user in Shiny app, there could be @@ -478,8 +687,7 @@ plot_heatmap <- function(tf,method, region, TF_and_ext, brain_data, cell_plot_nu #' activity_test_tf1 <- create_activity_data(tf, "Cell","cortex", data_cortex$TF_and_ext) #' plot_UMAP(tf_number = 1,data_cortex$overall, activity_test_tf1) #' -plot_UMAP <- function(tf_number, cell_metadata, cell_activity_data, sample_number = 13000, - sample_reduce = TRUE){ #cell_metadata is the tsv with the +plot_UMAP <- function(tf_number, cell_metadata, cell_activity_data, dim_red_type){ #cell_metadata is the tsv with the #embedding coordinates for each cell in the dataset # if(tf_number == 1) tf_plot <- 2 # number of col, the first col is Cell, so start from 2 # else if(tf_number == 2) tf_plot <- 3 @@ -489,29 +697,57 @@ plot_UMAP <- function(tf_number, cell_metadata, cell_activity_data, sample_numbe tf_plot <- tf_number + 1 #replaces the above control flow - if(! sample_reduce) sample_number <- 27000 activity_tf <- cell_activity_data[,tf_plot][[1]] #extracts the TF activity from the cell_activity_data #and appends it to the cell_metadata to make cell meta with activity to plot - cell_meta_with_activity <- mutate(cell_metadata, activity_tf = activity_tf) %>% - sample_n(sample_number) + cell_meta_with_activity <- mutate(cell_metadata, activity_tf = activity_tf) + x_axis <- switch(dim_red_type, "umap" = "UMAP1", "tsne" = "tSNE_1", "pca" = "PC1") + y_axis <- switch(dim_red_type, "umap" = "UMAP2", "tsne" = "tSNE_2", "pca" = "PC2") - ggplot(data = cell_meta_with_activity, mapping = aes(x=UMAP1,y=UMAP2))+ + ggplot(data = cell_meta_with_activity, mapping = aes_string(x = x_axis, y = y_axis))+ geom_point(aes(color = activity_tf))+ scale_color_gradient(low = "grey", high = "red")+ - theme_bw() + labs(color = 'TF Activity') + theme_min() + labs(color = 'TF Activity') } #if I want to include labeled clusters, then I need to map cells to the clusters #place a label at the mean of the umap coordinates for the cells that belong in that cluster -color_by_cluster <- function(cell_metadata, cluster_palette){ - ggplot(data = cell_metadata, mapping = aes(x=UMAP1,y=UMAP2))+ - geom_point(aes(color = Joint_cluster)) + theme_bw() + theme(legend.position="bottom") + - guides(fill=guide_legend(nrow=5, byrow=TRUE)) + scale_color_manual(values = cluster_palette) +color_by_cluster <- function(cell_metadata, cluster_palette, dim_red_type, cluster_label){ + + x_axis <- switch(dim_red_type, "umap" = "UMAP1", "tsne" = "tSNE_1", "pca" = "PC1") + y_axis <- switch(dim_red_type, "umap" = "UMAP2", "tsne" = "tSNE_2", "pca" = "PC2") + + # Store the center points (medians) of each cluster courtesy of Bhavyaa + centers <- cell_metadata %>% + group_by(Joint_cluster) %>% + summarise(center_x = median(get(x_axis)), + center_y = median(get(y_axis))) + + gg <- ggplot(data = cell_metadata, mapping = aes_string(x = x_axis,y = y_axis))+ + geom_point(aes(color = Joint_cluster)) + theme_min() + theme(legend.position="bottom") + + guides(fill=guide_legend(nrow=5, byrow=TRUE)) + scale_color_manual(values = cluster_palette) + + if(cluster_label){ + gg <- gg + ggrepel::geom_label_repel(data = centers, + aes(x = center_x, y = center_y), + label = centers$Joint_cluster, + size = 4, + segment.color = 'grey50', + fontface = 'bold', + alpha = 0.8, + segment.alpha = 0.8, + label.size = NA, + force = 2, + segment.size = 0.5, + arrow = arrow(length = unit(0.01, 'npc'))) + } + return(gg) } + +#----------------------------Time Course Ribbon Plot--------------------------------------------- #need to maybe change the colors, select out the numbers and rename legend, just cosmetic things #' make cell metadata of certain region, cortex/pon @@ -674,6 +910,7 @@ plot_timeseries <- function(TF,cell_metadata, activity, make_plotly = FALSE, sho limits = c(1, length(unique(df$stage)))) + labs(x = "age", y = "Proportion", title = TF) + guides(fill = guide_legend(ncol = 5)) + + theme_min() + theme(legend.position = "bottom") if(make_plotly) { diff --git a/GRN/global.R b/GRN/global.R index 206012d..67f2c4d 100644 --- a/GRN/global.R +++ b/GRN/global.R @@ -13,7 +13,7 @@ library(ggplot2) library(cowplot) library(pheatmap) library(DT) -library(rcytoscapejs2) # downloaded from https://github.com/uc-bd2k/rcytoscapejs2 +#library(rcytoscapejs2) # downloaded from https://github.com/uc-bd2k/rcytoscapejs2 #could probably get rid of rcytoscape library(glue) library(GGally) @@ -29,3 +29,6 @@ load("data/shared/common_prep.Rda") # metadata and colour_palettes # Custom functions source("functions.R") + +#allows server side save states +enableBookmarking(store = "server") diff --git a/GRN/server.R b/GRN/server.R index 0928b5b..f9006c9 100644 --- a/GRN/server.R +++ b/GRN/server.R @@ -1,30 +1,24 @@ server <- function(input, output, session) { - # help message - observeEvent(input$help, - introjs(session, options = list("nextLabel"="Next", - "prevLabel"="Previous", - "skipLabel"="Exit Tutorial"), - events = list("oncomplete"=I('alert("All Done!")'))) - ) + # Dynamic UI, change the selectInput tf lists on display depending on the brain region that is selected observeEvent(input$region,{ if(input$region == "cortex"){ - updateSelectInput(session, inputId = "TF", choices = data_cortex$unique_active_TFs_bare, - selected = c("Arx","Lef1")) - updateSelectInput(session, inputId = "gene", choices = unique(data_cortex$TF_target_gene_info$gene), - selected = c("Dlx6","Sox6") ) + updateSelectizeInput(session, inputId = "TF", choices = data_cortex$unique_active_TFs_bare, + selected = c("Arx","Lef1"), server = TRUE) + updateSelectizeInput(session, inputId = "gene", choices = unique(data_cortex$TF_target_gene_info$gene), + selected = c("Dlx6","Sox6"), server = TRUE ) } else{ - updateSelectInput(session, inputId = "TF", choices = data_pons$unique_active_TFs_bare, - selected = c("Lhx5","Pax7")) - updateSelectInput(session, inputId = "gene", choices = unique(data_pons$TF_target_gene_info$gene), - selected = c("Gad2")) + updateSelectizeInput(session, inputId = "TF", choices = data_pons$unique_active_TFs_bare, + selected = c("Lhx5","Pax7"), server = TRUE) + updateSelectizeInput(session, inputId = "gene", choices = unique(data_pons$TF_target_gene_info$gene), + selected = c("Gad2"), server = TRUE) } #updateRadioButtons(session, "show", selected = "stop") #resets the network visualization }) - + #uses the input update button to update a list of the parameters of the app for the following functions input_new <- eventReactive(input$update,{ @@ -48,6 +42,8 @@ server <- function(input, output, session) { l$time_point <- temp l$gene <- input$gene l$label <- input$label + l$dim_red <- input$dim_red + l$cluster_label <- input$cluster_label # l$gene_file_path <- input$file_gene$datapath # print(l$gene_file_path) # l has following elements with same names for both options above: @@ -61,18 +57,18 @@ server <- function(input, output, session) { # -----------------------------Tab1:table and network------------------------------------------ #def need to re-write this at the end - output$general_desc <- renderText({ - "This app designs for displaying transcription factor and gene data from mice brain (cortex & pons part) in various fancy ways by three main tabs; - - PROBLEM: There are some transcription factors from your input that may not have the corresponding data - in the following tabs. (Sometimes you may not see the information of that transcription factor or the plot - is not updated, etc. That is unfortunately because of the lack of data in the cell activity data in tab2, - or the binary cell activity data in tab3. - " - - }) + # output$general_desc <- renderText({ + # "This app designs for displaying transcription factor and gene data from mice brain (cortex & pons part) in various fancy ways by three main tabs; + # + # PROBLEM: There are some transcription factors from your input that may not have the corresponding data + # in the following tabs. (Sometimes you may not see the information of that transcription factor or the plot + # is not updated, etc. That is unfortunately because of the lack of data in the cell activity data in tab2, + # or the binary cell activity data in tab3. + # " + # + # }) #filter the data, add a column for logos, then display - output$table <- renderDataTable({ + output$table1 <- renderDataTable({ # process data, filter the lines with our interested TF subset_data <- input_new()$TF_target_gene_info %>% dplyr::filter(TF %in% input_new()$tf) %>% select(TF, gene, Genie3Weight.weight, nMotifs, bestMotif) @@ -82,7 +78,8 @@ server <- function(input, output, session) { colnames = c('Gene' = 'gene', 'Number of Motifs' = 'nMotifs', 'Best Motif' = 'bestMotif', 'Strength of Association' = 'Genie3Weight.weight', - 'Logo' = 'motif_logo')) + 'Logo' = 'motif_logo'), + rownames = FALSE) }) # observeEvent(input$reset, { # reset("file_gene") @@ -126,19 +123,35 @@ server <- function(input, output, session) { ) }) #check if there is a user input gene_list file, if there is, use it, if not, use the selectInput genes - - output$network <- renderPlot({ + igraph_network <- reactive ({ if(is.null(gene_list$data)){ - gene_into_graph <- input_new()$gene + gene_to_highlight <- input_new()$gene } else{ - gene_into_graph <- gene_list$data + gene_to_highlight <- gene_list$data } - make_igraph(input_new()$tf, input_new()$TF_target_gene_info, - gene_into_graph, input_new()$label) - #plot_ggnet(net, input_new()$gene) + make_network(input_new()$tf, input_new()$TF_target_gene_info, + gene_to_highlight) #returns an igraph network object + }) + network_ggplot <- reactive({ + plot_network(igraph_network(), input_new()$label, input_new()$tf) }) + output$network <- renderPlotly({ + net_plotly <- network_ggplot() %>% ggplotly(height = 700, tooltip = "text") %>% + layout(xaxis = list(visible = FALSE), yaxis = list(visible = FALSE), + hovermode = "x", hoverdistance = 100) + net_plotly + + }) + + output$download_network <- downloadHandler(filename = "network.pdf", + contentType = "application/pdf", + content = function(file){ + ggsave(filename = file, plot = network_ggplot(), + width = 8.5, height = 11) + }) + #probably redo this entire part to visualize with ggNet # output$desc <- renderText({ # text <- "\nOrange nodes are active transcription factors (tf genes that express their own tf); @@ -208,23 +221,25 @@ server <- function(input, output, session) { }) output$heatmap_joint <- renderPlot({ - hm_joint_cluster_plot() + hm_joint <- hm_joint_cluster_plot() + hm_joint }) - output$download_hm_joint <- downloadHandler(filename = "heatmap_joint.png", - contentType = "image/png", + output$download_hm_joint <- downloadHandler(filename = "heatmap_joint.pdf", + contentType = "application/pdf", content = function(file){ ggsave(filename = file, plot = hm_joint_cluster_plot(), width = 20, height = 25) }) output$heatmap_cluster <- renderPlot({ - hm_sample_cluster_plot() + hm_sample <- hm_sample_cluster_plot() + hm_sample }) output$download_hm_cluster <- downloadHandler(filename = "heatmap_cluster.png", - contentType = "image/png", + contentType = "application/pdf", content = function(file){ ggsave(filename = file, plot = hm_sample_cluster_plot(), width = 20, height = 25) @@ -243,22 +258,22 @@ server <- function(input, output, session) { # seems redundant, just needs one umap function here Umap_plot_1 <- reactive({ req(length(input_new()$tf)>0) - plot_UMAP(tf_number = 1,input_new()$cell_metadata, activity_data_cluster()) + plot_UMAP(tf_number = 1,input_new()$cell_metadata, activity_data_cluster(), input_new()$dim_red) }) Umap_plot_2 <- reactive({ req(length(input_new()$tf)>1) - plot_UMAP(tf_number = 2,input_new()$cell_metadata, activity_data_cluster()) + plot_UMAP(tf_number = 2,input_new()$cell_metadata, activity_data_cluster(), input_new()$dim_red) }) output$color_by_cluster <- renderPlot({ - color_by_cluster(input_new()$cell_metadata, input_new()$cluster_palette) + color_by_cluster(input_new()$cell_metadata, input_new()$cluster_palette, input_new()$dim_red, input_new()$cluster_label) }) output$cluster1 <- renderPlot({ Umap_plot_1() }) - output$download_UMAP_1 <- downloadHandler(filename = "UMAP1.png", - contentType = "image/png", + output$download_UMAP_1 <- downloadHandler(filename = "UMAP1.pdf", + contentType = "application/pdf", content = function(file){ ggsave(filename = file, plot = Umap_plot_1(), width = 20, height = 20) @@ -269,8 +284,8 @@ server <- function(input, output, session) { }) - output$download_UMAP_2 <- downloadHandler(filename = "UMAP2.png", - contentType = "image/png", + output$download_UMAP_2 <- downloadHandler(filename = "UMAP2.pdf", + contentType = "application/pdf", content = function(file){ ggsave(filename = file, plot = Umap_plot_2(), width = 20, height = 20) @@ -322,18 +337,16 @@ server <- function(input, output, session) { for(tf_n in input_new()$tfs_not_exist_timeseries){ tf_nexist_string <- paste(tf_nexist_string,tf_n,sep = " " ) } - text <- glue("We do not have these followning tfs in this tab: {tf_nexist_string}") + text <- glue("We do not have data for the following trancription: {tf_nexist_string}") }) output$timeseries_desc <- renderText({ - text <- "Click option: You may double click the color palatte of cell types at the right side to - display that cell type ONLY; you could also click on one cell type to eliminate that in the - plot at left. - Mouse over the white vertical line on the plot to see the cell types. - We only support four plots of your first four tfs input for now." + text <- "Click option: double clicking a cell type in the legend displays that cell type ONLY; + single click removes that cell type from the plot. Mouse over ribbons in the plot to see the cell types. + We only support four plots of your first four transcripton factor inputs." }) @@ -367,7 +380,7 @@ server <- function(input, output, session) { }) output$download_ribbon_1 <- downloadHandler(filename = "timeseries_ribbon.png", - contentType = "image/png", + contentType = "application/pdf", content = function(file){ ggsave(filename = file, plot = ggplot_list_plot(), width = 20, height = 15) diff --git a/GRN/ui.R b/GRN/ui.R index cf90b25..294cf64 100644 --- a/GRN/ui.R +++ b/GRN/ui.R @@ -1,19 +1,23 @@ +source("../www/ui_functions.R") + ui <- fluidPage( - introjsUI(), + #introjsUI(), #useShinyjs(), + includeCSS("../www/minimal.css"), + + navigation(), + + beginPage(), + # Application title - introBox( - titlePanel("Joint Cortex and Pons Transcription Factor Activity"), - data.step = 1, - data.intro = "This app displays transcription factor activity inference data from - a developmental timecourse of the mouse Pons and Forebrain." - ), + titlePanel("Transcription Factor Activity in Single-cell Developmental Atlas", + windowTitle = "GRN"), + # ---------------- Side Panel --------------------------------------------- sidebarLayout( sidebarPanel( width = 3, # choose which datasets to analyze for the whole app - actionButton("help", label = "See Instructions"), radioButtons("region", "Brain region", # use the names in the vector to display # use the character "joint_cortex" to match the path to import data @@ -22,76 +26,38 @@ ui <- fluidPage( selected = "cortex"), #actionButton("update_tf", label = "Update transcription factors to see the plots"), - selectInput(inputId = "TF", - label = "Transcription Factor", - choices = data_cortex$unique_active_TFs_bare, - multiple = TRUE, - selected = c("Arx","Lef1")), - # fileInput("file_tf", "Choose CSV File containing your tf list", - # accept = c( - # "text/csv", - # "text/comma-separated-values,text/plain", - # ".csv") - # ), - - # 1. table and network graph of related TF and genes - conditionalPanel( - condition = "input.tabs == 'Transcription Factor Target Information'", - - ), + selectizeInput(inputId = "TF", + label = "Transcription Factor Input", + choices = NULL, + multiple = TRUE, + selected = c("Arx", "Lef1")), + +#----------------------------ggNet visualisation--------------------------------------------- conditionalPanel( condition = "input.tabs == 'Regulatory Network Visualization'", - selectInput(inputId = "gene", - label = "Genes of Interest", - choices = unique(data_cortex$TF_target_gene_info$gene), - multiple = TRUE, - selected = c("Dlx6","Sox6")), + selectizeInput(inputId = "gene", + label = "Genes of Interest", + choices = NULL, + multiple = TRUE, + selected = c("Dlx6","Sox6")), #allows user to input a file containing a list of genes to query #this input returns a dataframe with 4 columns: name, size, type, datapath #each file entered is one row uiOutput('file1_ui'), ## instead of fileInput('file1', label = NULL) so that the file can be reset - # fileInput( - # "file_gene", "Choose a CSV file containing your genes list", - # accept = c( - # "text/csv", - # "text/comma-separated-values, text/plain", - # ".csv"), - # multiple = FALSE, - # placeholder = "example_list.csv" - # ), + actionButton("reset", label = "Reset File"), - checkboxInput(inputId = "label", label = "Label Gene Target Nodes", value = FALSE) + checkboxInput(inputId = "label", label = "Label Target Gene Nodes", value = FALSE) ), - # conditionalPanel(condition = "input.tabs == 'Table and Network'", - # radioButtons("show", "Node Display Option", - # # use the names in the vector to display - # # use the character "joint_cortex" to match the path to import data - # choices = c("Show All Nodes" = "all", - # #"color by user's input tf list" = "pathway", - # "Shrink Grey Nodes" = "shrink", - # "Neglect Grey Nodes" = "neglect", - # - # "Show No Nodes" = "stop"), - # selected = "stop"),#, - # checkboxInput("show_pathway","Color by Input Genes", - # TRUE), - # selectInput("input_pathway", "Gene Pathway of Interest", - # choices = data_cortex$unique_active_TFs_bare, - # multiple = TRUE, - # selected = c("Arx","Lef1")) - # # fileInput("file_gene", "Choose CSV File containing your genes list", - # # accept = c( - # # "text/csv", - # # "text/comma-separated-values,text/plain", - # # ".csv") - # # ) - # #actionButton("update_graph", label = "See the network graph") - # - # ), - # 2. heatmap and clustering +# -----------------TF info table --------------------------------------------- + conditionalPanel( + condition = "input.tabs == 'Transcription Factor Target Information'", + + ), + +# ----------------Heatmap --------------------------------------------- conditionalPanel(condition = "input.tabs == 'Heatmap'", #numericInput(inputId = "num_cell_plot", label = "Number of Cells to Visualize", #value = 300), @@ -102,154 +68,142 @@ ui <- fluidPage( "Sample Cluster" = "Cluster"), selected = "joint"), selectInput(inputId = "time", - label = "Timepoint to Visualize", + label = "Time-point to Visualize", choices = c("All","e12", "e15", "p0", "p3", "p6"), multiple = FALSE, - selected = "e12") + selected = "All") ), +# -----------------DR plots --------------------------------------------- + conditionalPanel(condition = "input.tabs == 'Clustering'", + + radioButtons("dim_red", "Dimension Reduction Method", + choices = c("UMAP" = "umap", + "TSNE" = "tsne", + "PCA" = "pca"), + selected = "umap"), + + checkboxInput(inputId = "cluster_label", label = "Show Cluster Labels", value = TRUE) + ), # 3. time series plot conditionalPanel(condition = "input.tabs == 'Time Series'"), - introBox( # Update everything actionButton("update", label = "Update"), - data.hint = "click me to update everything!", - data.step = 2, - data.intro = "click it to update everything! Do this after you changed your - transcription factor input and options. Feel free to QUIT the intro first and update it to see the - table and plots", - data.position = "right" - ), + bookmarkButton(), ), +# -----------------Main Panel --------------------------------------------- mainPanel( tabsetPanel( - - tabPanel( - p("This tab displays information corresponding to the selected transcription factors and their predicted gene targets."), - p("- Strength of Association represents "), - p("- The top row is colored by cluster and the bottom row is colored by transcription factor activity"), - p("- Only the first two transcriptions factors are displayed"), - title = "Transcription Factor Target Information", - textOutput("general_desc"), - introBox( - dataTableOutput("table"), - data.step = 3, - data.intro = "This table displays the gene targets of the selected transcription factors - along with information about the genes." - ), - value = "Transcription Factor Target Information" - ), + # -----------------ggNet visualisation --------------------------------------------- tabPanel( - title = "Regulatory Network Visualization", + strong("This tab displays a network visualisation of the inferred regulatory relationship between TFs and target genes.") %>% p(), + p("• TFs and target genes are represented as nodes with regulatory relationships represented as edges."), + p("• User input TFs are shown in blue. Target genes that are present in the current + network can be highlighted in orange based on a user-input gene list, either through the + \"Genes of Interest\"input or through a file input."), + p("• Click on the \"Label Target Gene Nodes\" option to see the label of every gene target and enable a hover option. + Currently, hover only displays gene name but more information to come soon!"), + p("• TFs that self regulate are not displayed (i.e no self loops)."), + p("• File input format: single column csv file with the first row titled 'Gene' and the remaining rows containing a list of genes of interest."), + title = "GRN Visualization", #textOutput("general_desc"), # this line breaks things/ probably cause you can't have 2 general_desc - textOutput("desc"), - plotOutput("network"), - #need to work on visualization with the ggNet package - introBox( - data.step = 4, - data.intro = "This table displays a network of your selected transcription factors and - their top gene targets." - ), + #textOutput("desc"), + plotlyOutput("network"), + br(),#so the plotly doesn't overlap with the download button + br(), + br(), + br(), + br(), + br(), + br(), + br(), + br(), + br(), + br(), + br(), + br(), + br(), + br(), + br(), + br(), + downloadButton("download_network", "Network Visualisation Download (PDF)"), + value = "Regulatory Network Visualization" ), - # tabPanel( - # title = "Table and Network", - # textOutput("general_desc"), - # introBox( - # - # dataTableOutput("table"), - # data.step = 3, - # data.intro = "Table and network tab: - # A table of tf and its target gene with motifs and other information" - # ), - # introBox( - # data.intro = "Feel free to quit the intro now, click the 'show all nodes' button - # in the sidebar to see the cytoscape network graph, then we continue", - # data.step = 4 - # ), - # - # - # textOutput("desc"), - # tags$style(type="text/css", "#desc {white-space: pre-wrap;}"), - # introBox( - # rcytoscapejsOutput("network", width = "1200px",height = "600px"), - # data.step = 5, - # data.intro = "a network graph visualization displaying detailed information with node color - # and size: - # Orange nodes are active transcription factors (tf genes that express their own tf); - # Purple nodes in the center are your input transcription factors; - # Green nodes are your input genes related to input tfs(purple nodes) - # ; grey nodes are other genes." - # ), - # value = "Table and Network" - # ), - - - + # -----------------TF info table --------------------------------------------- + tabPanel( + strong("This tab displays information corresponding to the selected TFs and their inferred target genes.") %>% p(), + p("• Strength of Association represents the weight of the putative regulatory links between transcription factor and a gene target, + as predicted with Genie3, with a higher value indicating a more likely regulatory link."), + p("• The number of motifs for each gene is identified via the RcisTarget package. The best motif and its sequence logo is displayed."), + title = "TF Target Information", + #textOutput("general_desc"), + dataTableOutput("table1"), + value = "Transcription Factor Target Information" + ), + + # -----------------Heatmap --------------------------------------------- tabPanel( - title = "Heatmap", + strong("This tab displays a heatmap of user selected TF activity per cluster") %>% p(), + p("• Values in the heatmap represent the mean TF activity per cluster."), + p("• Joint clusters are classified based on the combined data from every developmental + time-point in a brain region (forebrain or pons); sample cluster are identified based on data from each + individual time-point per brain region."), + p("• Use the \"Time-point to Visalise\" option to select which (if not all) time-points + to visualise in the sample cluster heatmap."), + title = "TF Activity Heatmap", value = "Heatmap", fluidRow( plotOutput("heatmap_joint") ), - downloadButton("download_hm_joint", "Heatmap by Joint Cluster (PNG)"), + downloadButton("download_hm_joint", "Heatmap by Joint Cluster (PDF)"), div(style = "margin-left: 1.3em; margin-right: 1.3em;", fluidRow( plotOutput("heatmap_cluster") )), - downloadButton("download_hm_cluster", "Heatmap by Timepoint Cluster (PNG)"), + downloadButton("download_hm_cluster", "Heatmap by Timepoint Cluster (PDF)"), imageOutput("color_hm_palette", width = "6in", height = "4in") ), - + # -----------------DR plots --------------------------------------------- tabPanel( - title = "Clustering", + title = "TF Activity, by Region", value = "Clustering", fluidRow( #make each plot smaller to fit more - p("This tab displays the activity of selected transcription factors"), - p("- Cells are plotted in 2D according to UMAP dimensionality reduction algorithm"), - p("- The top row is colored by cluster and the bottom row is colored by transcription factor activity"), - p("- Only the first two transcriptions factors are displayed"), + p("This tab displays the activity of selected transcription factors") %>% strong(), + p("• Cells are plotted in 2D according to selected dimensionality reduction algorithm"), + p("• The top row is colored by joint cluster and the bottom row is colored by transcription factor activity"), + p("• Only the first two transcriptions factors are displayed"), column(width = 10, plotOutput("color_by_cluster", width = "6in", height = "7in")) ), fluidRow( column(width = 6, plotOutput("cluster1",width = "4.2in", height = "4in"), - downloadButton("download_UMAP_1", "Transcription Factor 1 Activity Plot (PNG)")), + downloadButton("download_UMAP_1", "Transcription Factor 1 Activity Plot (PDF)")), column(width = 6, plotOutput("cluster2", width = "4.2in",height = "4in"), - downloadButton("download_UMAP_2", "Transcription Factor 2 Activity Plot (PNG)")), + downloadButton("download_UMAP_2", "Transcription Factor 2 Activity Plot (PDF)")), ) ), - # tabPanel("Heatmap and Clustering", - # - # plotOutput("heatmap_cell"), - # downloadButton("download_hm_cell", "Heatmap by cell (Png)"), - # plotOutput("heatmap_cluster"), - # downloadButton("download_hm_cluster", "Heatmap by cluster (Png)"), - # imageOutput("color_hm_palette", width = "6in", height = "4in"), - # - # fluidRow( - # textOutput("cluster_UMAP_desc"), - # column(width = 8, plotOutput("cluster1",width = "5in", height = "5in"), - # downloadButton("download_UMAP_1", "UMAP scatterplot 1 (Png)")), - # - # column(width = 8, plotOutput("cluster2", width = "5in",height = "5in"), - # downloadButton("download_UMAP_2", "UMAP scatterplot 2 (Png)")), - # - # ), - # - # value = "Heatmap and Clustering" - # ), + # -----------------Time Series --------------------------------------------- tabPanel("Time Series", - textOutput("tf_timeseries_desc"), - textOutput("timeseries_desc"), + p("This plot quantifies the proportion of cells (from 0 to 1) at each timepoint where a given + TF is active, broken down by cell type, to allow for visualizing activity + across time.") %>% strong(), + p("• For any given cell, any given TF is considered active if its activity in that cell + is higher than a TF activity threshold."), + p("• The time series for the first TF selected in the sidebar will be an interactive plot, with + the remaining plots being static."), + textOutput("timeseries_desc"), + br(), + textOutput("tf_timeseries_desc"), + fluidRow( plotlyOutput("timeseries1"), - downloadButton("download_ribbon_1", "Timeseries ribbon plot (Png)"), + downloadButton("download_ribbon_1", "Timeseries ribbon plot (PDF)"), plotOutput("timeseries2"), imageOutput("timeseries_color"), #plotOutput("timeseries3"), @@ -260,5 +214,6 @@ ui <- fluidPage( )) ), - + # Custom styling + endPage() ) \ No newline at end of file diff --git a/GRN/www/braindex.png b/GRN/www/braindex.png new file mode 100644 index 0000000..8f653fd Binary files /dev/null and b/GRN/www/braindex.png differ diff --git a/clusters/.gitignore b/clusters/.gitignore index 6af25e7..52c5430 100644 --- a/clusters/.gitignore +++ b/clusters/.gitignore @@ -31,3 +31,6 @@ debug-app # Exclude R script used for testing test.R + +# Exclude server-side bookmark files +shiny_bookmarks/ diff --git a/clusters/functions.R b/clusters/functions.R index a5160a7..6f43c39 100644 --- a/clusters/functions.R +++ b/clusters/functions.R @@ -52,7 +52,21 @@ get_expression <- function(sample, } - return(df) + # Output a flag if all expression values in the region are 0 + # used for an informative error message in the app + is_zero = FALSE + + non_zero_exp <- df %>% + filter(Expression != 0) + + # TRUE if non_zero_exp has no rows i.e. i.e. all zero expression + if (dim(non_zero_exp)[1] == 0){ + + is_zero = TRUE + + } + + return(list(data = df, zero = is_zero)) } @@ -117,7 +131,6 @@ bubble_prep <- function(gene, # width; to roughly the the # of characters in the gene w/ longest name # However, letters take up more pixels than spaces, so do less padding # for genes with longer names - # TODO: Fix alignment of bubble plot w/ dendrogram for long gene names (issue #7) mutate(Gene_padded = case_when( str_length(Gene) <= 5 ~ str_pad(Gene, 15, side = 'right', pad = " "), str_length(Gene) > 5 ~ str_pad(Gene, 12, side = 'right', pad = " ") @@ -175,7 +188,7 @@ bubble_prep <- function(gene, #' @param df Data frame as returned by bubble_prep(), with require columns Cluster, #' Gene_padded, Pct1, and Expression #' -#' @return ggplot2 object +#' @return A list containing a ggplot2 object and its legend (extracted with cowplot) #' #' @examples #' bubble_prep("Dlx1") %>% bubbleplot() @@ -287,6 +300,17 @@ ribbon_plot <- function(gene, ribbon_df <- prep_ribbon_input(gene, region) ribbon_df$gene <- ribbon_df[[gene]] + # Output a flag if all expression values in the region are 0 + # used for an informative error message in the app + is_zero = FALSE + non_zero_exp <- ribbon_df %>% + filter(gene != 0) + + # TRUE if non_zero_exp has no rows i.e. i.e. all zero expression + if (dim(non_zero_exp)[1] == 0){ + is_zero = TRUE + } + # For each cluster at each timepoint, calculate the proportion of cells in # which the gene is detected ribbon_df_celltype_frac <- ribbon_df %>% @@ -294,9 +318,9 @@ ribbon_plot <- function(gene, mutate(total = n()) %>% group_by(Age, Cell_type) %>% mutate(frac = sum(gene > 0) / total) %>% - distinct(Age, Cell_type, frac) %>% + distinct(Age, Cell_type, frac, total) %>% ungroup() - + # For each timepoint, calculate the proportion of cells in which the gene # is detected ribbon_df_cum_frac <- ribbon_df %>% @@ -316,7 +340,7 @@ ribbon_plot <- function(gene, df$ranking = match(df$cluster, names(colours)) df = df[order(df$stage, df$ranking),] - df <- left_join(df, select(ribbon_df_celltype_frac, cluster = Cell_type, stage = Age, frac)) %>% + df <- left_join(df, select(ribbon_df_celltype_frac, cluster = Cell_type, stage = Age, frac, total)) %>% # Complete cases when genes were not detected in certain timepoints/clusters # by replacing with a zero mutate(frac = replace_na(frac, 0)) %>% @@ -325,7 +349,9 @@ ribbon_plot <- function(gene, df$xpos = match(df$stage, unique(timepoints2)) p1 <- df %>% - ggplot(aes(x = xpos, y = frac, fill = cluster)) + + # Need to specify group or the text attribute with glue causes errors + ggplot(aes(x = xpos, y = frac, fill = cluster, group = cluster, + text = glue("{total*frac} {gene}+ cells out of {total} cells at this time point"))) + geom_area(stat = "identity") + scale_fill_manual(values = colours, drop = FALSE, name = "") + scale_x_continuous(breaks = seq_along(unique(df$stage)), @@ -337,17 +363,32 @@ ribbon_plot <- function(gene, ylim(0, ymax) if(make_plotly) { - return (ggplotly(p1, - # Only display cluster information within tooltip - tooltip = "cluster") %>% + return (list(zero = is_zero, plot = (ggplotly(p1, + # Display cluster (group) and info on number of cells (text) in tooltips + tooltip = c("group", "text")) %>% # Add hovers both on points as well as filled areas of the plot # Changing it to hoveron="fills" only causes a known issue, see: # https://github.com/ropensci/plotly/issues/1641 style(hoveron="points+fills") - ) + ) %>% + + # Customize the modebar on the plotly object to hide certain buttons, + # remove the plotly logo, and toggle spike lines on by default + config(modeBarButtonsToRemove = c("hoverCompareCartesian", + "hoverClosestCartesian", + "toImage", + "toggleSpikelines", + "autoScale2d"), + displaylogo = FALSE) %>% + layout(yaxis = list(showspikes = TRUE, + spikethickness = 1.5, + spikedash = "solid"), + xaxis = list(showspikes = TRUE, + spikethickness = 1.5, + spikedash = "solid")))) } else { - return(p1) + return(list(zero = is_zero, plot = p1)) } } @@ -379,7 +420,7 @@ ribbon_plot <- function(gene, #' @param hide_axes Logical, whether or not to hide the plot axes. Default: FALSE #' @param show_n_cells Logical, ... Default: FALSE #' -#' @return A ggplot object +#' @return A list containing a ggplot object and a list of cluster centers #' #' @export dr_plot <- function(embedding, @@ -777,3 +818,78 @@ dark <- function(hex_color) { } } + +#' Add ticks below a bar plot to categorize x axis into less granular categories +#' +#' @param df Dataframe, containing the data to use +#' [...] +#' +#' @example +#' plot + add_class_ticks(df, unique(df$Cell_class), palette = palettes$Cell_class, +#' start = -50, sep = 100, height = 500, label_x_pos = -9, fontsize = 3.5) +#' +add_class_ticks <- function(df, classes, height, sep, start, label_x_pos, palette = NULL, fontsize = 3) { + + # Set up our limits + n <- length(classes) + tops <- seq(start, by = - (height + sep), length.out = n) + bottoms <- seq(start - height, by = - (height + sep), length.out = n) + mids <- map2_dbl(tops, bottoms, ~ mean(c(.x, .y))) + betweens <- seq(start - (height + sep/2), by = - (height + sep), length.out = n - 1) + + if (is.null(palette)) palette <- rep("black", n) + + # Make a dataframe for tick positions + df$y_top <- NA + df$y_bottom <- NA + + for (i in seq_along(classes)) { + + df[df$Cell_class == classes[i], ]$y_top <- tops[i] + df[df$Cell_class == classes[i], ]$y_bottom <- bottoms[i] + + } + + # Make a dataframe for class labels + df2 <- data.frame(Class = classes, + x = label_x_pos, + y = mids) + + # Adding ggplot2 elements together + # https://stackoverflow.com/questions/56405904/how-to-add-ggproto-objects-together-and-save-for-later-without-call-to-ggplot + list(geom_segment(data = df, + mapping = aes(x = Cluster, y = y_top, + xend = Cluster, yend = y_bottom), + size = 1, + colour = "gray50"), + geom_hline(yintercept = 0, colour = "gray90"), + geom_hline(yintercept = betweens, linetype = "dotted", size = 0.4, colour = "gray60"), + geom_text(data = df2, mapping = aes(x = x, y = y, label = Class, colour = Class), size = fontsize, fontface = "bold", hjust = "left"), + scale_colour_manual(values = palette)) + +} + +#' Check a certain number of input genes against an list of accepted genes +#' +#' @param user_genes Character vector, inputs from user (from textbox or file) +#' @param n Numeric, the number of genes from the beginning of the list to check. +#' Default: NULL (i.e. check all genes) +#' @param annotation Logical, whether to check against annotation or not. +#' Default: FALSE (i.e. check against list of dataset genes, not annotation) +#' +#' @return A list of inputs that do not match the list of accepted genes + +check_genes <- function(user_genes, + n = 20, + annotation = FALSE) { + + if (!is.null(n)) { + user_genes <- head(user_genes, n) + } + + if (!(all(user_genes %in% genes_mouse))) { + return(user_genes[!(user_genes %in% genes_mouse)]) + } else { + return(NULL) + } +} diff --git a/clusters/global.R b/clusters/global.R index 75e0cff..cde3698 100644 --- a/clusters/global.R +++ b/clusters/global.R @@ -1,7 +1,7 @@ # This file will be run first, and anything in this file will be available # for the other R files required for the shiny app (e.g. server.R, ui.R) -# Load required packages ---- +# ---- Load required packages ---- library(feather) library(tidyr) library(dplyr) @@ -10,14 +10,16 @@ library(glue) library(stringr) library(ggplot2) library(ggrepel) -library(DT) +#library(DT) library(purrr) library(readr) library(shinyWidgets) library(plotly) library(shinycssloaders) +library(shiny) +library(reactable) -# Set-up / load common data ---- +# ---- Set-up / load common data ---- # Cluster-level metadata metadata <- data.table::fread("data/joint_mouse/metadata_20190715_select.tsv", @@ -33,4 +35,12 @@ pons_palette_joint <- readRDS("data/joint_pons/joint_pons.palette_ID_20190715_ load("data/joint_mouse/joint_mouse.palette_ID_20190715.Rda") # Vector specifying the order of clusters in the dendrogram -load("data/joint_mouse/ID_20190715_dendrogram_order.Rda") \ No newline at end of file +load("data/joint_mouse/ID_20190715_dendrogram_order.Rda") + +# Load names of genes detected in mouse to provide choices in input +genes_mouse <- data.table::fread("data/joint_mouse/joint_mouse.gene_names.tsv", data.table = FALSE)$genes + +# ---- Shiny settings ---- + +# Enable bookmarking +enableBookmarking(store = "url") \ No newline at end of file diff --git a/clusters/server.R b/clusters/server.R index 8789303..7415a37 100644 --- a/clusters/server.R +++ b/clusters/server.R @@ -18,9 +18,32 @@ server <- function(input, output, session) { # more options in the future input_new <- eventReactive(input$update, { + g_list <- reactive({ + + req(input$genelist) + + ext <- tools::file_ext(input$genelist$name) + switch(ext, + csv = scan(input$genelist$datapath, + what = "string", sep = ",", + encoding = "UTF-8", fileEncoding = "UTF-8-BOM"), + tsv = scan(input$genelist$datapath, + what = "string", sep = "\t", + encoding = "UTF-8", fileEncoding = "UTF-8-BOM"), + validate("\n\n\nInvalid file; Please upload a .csv or .tsv file") + ) + }) + + # Condition which input is used based on the upload toggle + if (input$upload){ + genes = g_list() + } else { + genes = input$gene + } + # Inputs to use as is l <- list( - "gene" = input$gene, + "gene" = genes, "scale" = input$bubble_scale, "size" = input$bubble_size, "region" = input$region, @@ -80,6 +103,19 @@ server <- function(input, output, session) { # Generate the input dataframe for the bubbleplot bubble_input <- reactive({ + # Check whether a gene was provided or not + validate( + need(length(input_new()$gene) > 0, "\n\n\nPlease enter a gene.") + ) + + # Check first 20 inputs against the dataset genes + error_genes <- check_genes(input_new()$gene, 20) + validate( + need(is.null(error_genes), + glue("\n\n\nThe input gene \"{error_genes}\" does not exist in the dataset.")) + ) + + # Only display mean if more than one gene is given AND the user requested it valid_mean <- FALSE if (length(input_new()$gene) > 1 && input_new()$mean_exp){ @@ -99,7 +135,7 @@ server <- function(input, output, session) { req(bubble_input()) bubble_plot(df = bubble_input(), - max_point_size = input_new()$size)$plot + max_point_size = input_new()$size)$plot # Get plot part of output }, @@ -133,7 +169,7 @@ server <- function(input, output, session) { # background is set to the cluster colour, with opacity = 95% ("F2" at end of hex) # z-index is set so we are sure are tooltip will be on top style <- paste0("position:absolute; z-index:100; background-color: ", point$Colour, "F2;", - "left: -350px; top: 450px; width: 350px;") + "left: -350px; top: 500px; width: 350px;") # Set text to white if the background colour is dark, else it's black (default) if (dark(point$Colour)) { @@ -163,43 +199,99 @@ server <- function(input, output, session) { ) }) + # Render the bubble plot gene labels separately with ggdraw output$bubble_labels <- renderPlot({ ggdraw(bubble_plot(df = bubble_input(), - max_point_size = input_new()$size)$labels) + max_point_size = input_new()$size)$labels) # Get labels part of output }, - height = function() 20 + 28 * length(input_new()$gene), + # Set height of bubble plot gene labels to (hopefully) align with plots + height = function() 28.5 + 29 * length(input_new()$gene), + # Max length of a gene is 200px + # NOTE: If altering this, also change the corresponding cellWidth for + # splitLayout in ui.R width = 200 ) + #### ---- Expression table tab content ---- # Show table with cluster & expression info - output$cluster_table <- renderDataTable({ - + output$cluster_table <- renderReactable({ req(bubble_input()) - bubble_input() %>% + # Use the order from bubble_input except reversed + gene_table_order <- rev(unique(bubble_input()$Gene)) + + table <- + bubble_input() %>% select(-Pct1, -Gene_padded) %>% mutate(Expression = round(Expression, 2)) %>% spread(Gene, Expression) %>% - DT::datatable(options = list( - columnDefs = list(list(visible = FALSE, - # Hide the Colour column - targets = c(6))), - selection = "none") - ) %>% - - # Colour the cluster column based on the palette - formatStyle("Cluster", - backgroundColor = styleEqual(names(joint_mouse_palette), unname(joint_mouse_palette))) - + # Select all except Colour column, rename some variables for clarity, and + # follow bubble_input order for gene columns (saved above) + select(Cluster, + Sample, + "Cell type" = Cell_type, + "Cell class" = Cell_class, + "Number of cells" = N_cells, + all_of(gene_table_order)) + + # Move mean expression to the rightmost column + # if ("MEAN" %in% gene_table_order) { + # table <- table %>% relocate("MEAN", + # .after = last_col()) + # } + + # Produce a data table + reactable(table, + rownames = FALSE, + highlight = TRUE, + compact = TRUE, + searchable = TRUE, + showSortable = TRUE, + fullWidth = FALSE, + showPageSizeOptions = TRUE, pageSizeOptions = c(10, 20, 40), defaultPageSize = 10, + defaultColDef = colDef(minWidth = 80), + # Override colDef manually for the first few rows + columns = list( + Cluster = colDef(minWidth = 110, + style = function(index){ + # Colour cluster column background by existing palette + b_color <- toString(unname(joint_mouse_palette)[index]) + # Change text colour to white if background is dark + if (dark(b_color)){ + f_color = "#FFFFFF" + } else { + f_color = "#000000" + } + list(background = b_color, color = f_color, fontWeight = "bold") + # # Make the cluster column "sticky" i.e. freeze it in horizontal scroll + # position = "sticky", left = 0, zIndex = 1) + }, + # headerStyle = + # list(position = "sticky", left = 0, background = "#fff", zIndex = 1) + ), + Sample = colDef(minWidth = 125), + "Cell type" = colDef(minWidth = 200), + "Cell class" = colDef(minWidth = 150), + "Number of cells" = colDef(minWidth = 100) + ) + ) }) + # output$x4 = renderPrint({ + # s = input$cluster_table_rows_selected + # if (length(s)) { + # cat('These clusters were selected:\n\n') + # cat(bubble_input()$Cluster[s], sep = ', ') + # } + # }) + # Download data in bubbleplot tab and expression table as TSV output$download_bubble <- downloadHandler(filename = "mean_cluster_expression.tsv", @@ -210,14 +302,57 @@ server <- function(input, output, session) { #### ---- Timecourse tab content ---- + observe({ + x <- input_new()$gene + + # Can use character(0) to remove all choices + if (is.null(x)) + x <- character(0) + + if (length(x) == 1){ + text_pick_timecourse <- " input)" + } else if (length(x) > 1){ + text_pick_timecourse <- " inputs)" + } else { + text_pick_timecourse <- NULL + } + + # Can also set the label and select items + updateSelectInput(session, "pick_timecourse", + label = paste("Select gene to display (from ", length(x), text_pick_timecourse), + choices = x, + selected = head(x, 1) + ) + }) + # STATIC TIMECOURSE # Generate ribbon plot and save the output so that we can allow the # user to download it ribbon_static <- reactive({ - p1 <- ribbon_plot(gene = input_new()$gene[1], - region = input_new()$region) + # Check whether a gene was provided or not + validate( + need(length(input_new()$gene) > 0, "\n\n\nPlease enter a gene.") + ) + + # Check user-selected input against the dataset genes + error_genes <- check_genes(input$pick_timecourse, 1) + validate( + need(is.null(error_genes), + glue("\n\n\nThe input gene \"{error_genes}\" does not exist in the dataset.")) + ) + + all_zero <- ribbon_plot(gene = input$pick_timecourse, + region = input_new()$region)$zero + + # Display message to the user instead of plot if 0 expression throughout region + validate( + need(all_zero == FALSE, "This gene has no detected expression in the selected brain region.") + ) + + p1 <- ribbon_plot(gene = input$pick_timecourse, + region = input_new()$region)$plot # Get legend using cowplot leg <- cowplot::get_legend(p1) @@ -244,9 +379,29 @@ server <- function(input, output, session) { # Generate interactive ribbon plot and save the output ribbon_plotly <- reactive({ - ribbon_plot(gene = input_new()$gene[1], + # Check whether a gene was provided or not + validate( + need(length(input_new()$gene) > 0, "\n\n\nPlease enter a gene.") + ) + + # Check first input against the dataset genes + error_genes <- check_genes(input$pick_timecourse, 1) + validate( + need(is.null(error_genes), + glue("\n\n\nThe input gene \"{error_genes}\" does not exist in the dataset.")) + ) + + all_zero = ribbon_plot(gene = input$pick_timecourse, + region = input_new()$region)$zero + + # Display message to the user if there is 0 expression throughout region + validate( + need(all_zero == FALSE, "This gene has no detected expression in the selected brain region.") + ) + + ribbon_plot(gene = input$pick_timecourse, region = input_new()$region, - make_plotly = TRUE) + make_plotly = TRUE)$plot }) @@ -256,7 +411,7 @@ server <- function(input, output, session) { layout(ribbon_plotly(), legend = list(x = 1, y = 0)) }) - # DOWNLOAD TIMECOURSE + # DOWNLOAD TIMECOURSE (static plot) AS A PDF output$download_ribbon <- downloadHandler(filename = "timecourse_ribbon.pdf", @@ -277,6 +432,18 @@ server <- function(input, output, session) { req(input_new()) + # Check whether a gene was provided or not + validate( + need(length(input_new()$gene) > 0, "\n\n\nPlease enter a gene.") + ) + + # Check ALL inputs against the dataset genes + error_genes <- check_genes(input_new()$gene) + validate( + need(is.null(error_genes), + glue("\n\n\nThe input gene \"{error_genes}\" does not exist in the dataset.")) + ) + # Load the Cell barcode, 2D coordinates, and selected clustering solution get_embedding(sample = input_new()$region, dr_cols = input_new()$dr, @@ -368,12 +535,18 @@ server <- function(input, output, session) { req(input_new()) - get_expression(sample = input_new()$region, - embedding = dr_joint_embedding(), - gene = input_new()$gene, - - # If more than one gene was provided, compute an aggregate - aggregate = TRUE) + express <- get_expression(sample = input_new()$region, + embedding = dr_joint_embedding(), + gene = input_new()$gene, + # If more than one gene was provided, compute an aggregate + aggregate = TRUE) + + # Display message to the user if there is 0 expression throughout region + validate( + need(express$zero == FALSE, "This gene has no detected expression in the selected brain region.") + ) + + express$data }) @@ -537,5 +710,94 @@ server <- function(input, output, session) { }) + #### ---- Clusters ranked by expression tab content ---- + + output$rank_tick_plot <- renderPlot({ + + # Check whether a gene was provided or not + validate( + need(length(input_new()$gene) > 0, "\n\n\nPlease enter a gene.") + ) + + if(input_new()$mean_exp){ + # Check ALL inputs against the dataset genes + error_genes <- check_genes(input_new()$gene) + } else{ + # Check only first input against the dataset genes + error_genes <- check_genes(input_new()$gene, 1) + } + + validate( + need(is.null(error_genes), + glue("\n\n\nThe input gene \"{error_genes}\" does not exist in the dataset.")) + ) + + palette_tick_plot <- c("Progenitors/cyc." = "#ffaf49", + "Oligodendrocytes" = "#b7dd5f", + "Astrocytes" = "#00a385", + "Ependymal" = "#8ee5cf", + "Neurons" = "#840200", + "Non-neuroect." = "gray40", + "Other" = "gray60") + + if (input_new()$mean_exp){ + df <- bubble_prep(gene = input_new()$gene, + show_mean = TRUE) %>% + filter(Gene == "MEAN") + y_axis_text <- "Mean gene expression" + title_text <- "Mean expression over all selected genes" + } else { + df <- bubble_prep(gene = input_new()$gene[1]) + y_axis_text <- glue("Mean {input_new()$gene[1]} expression") + title_text <- input_new()$gene[1] + } + + df <- df %>% + # Order from highest to lowest by expression (ranked) + arrange(desc(Expression)) %>% + mutate(Cluster = factor(Cluster, levels = .$Cluster)) %>% + # Rename cell classes to more general names + mutate(Cell_class = case_when( + grepl("RGC", Cell_class) | grepl("-P$", Cluster) ~ "Progenitors/cyc.", + grepl("Olig", Cell_class) ~ "Oligodendrocytes", + grepl("Epen", Cell_class) ~ "Ependymal", + grepl("Astr", Cell_class) ~ "Astrocytes", + grepl("[Nn]euron", Cell_class) ~ "Neurons", + grepl("Non-neuro|Immune", Cell_class) ~ "Non-neuroect.", + TRUE ~ "Other" + )) + + p1 <- df %>% ggplot(aes(x = Cluster, y = Expression)) + + geom_bar(aes(fill = Cluster), stat = "identity") + + scale_fill_manual(values = df$Colour) + + theme_min(border_colour = "gray90") + + theme(legend.position = "none", + axis.title.x = element_blank(), + axis.text.x = element_blank(), + axis.ticks.x = element_blank(), + # Remove white space at the bottom of plot + plot.margin = margin(b=0, unit="cm")) + + expand_limits(x = -18) + + labs(title = title_text) + + ylab(y_axis_text) + + ticks <- ggplot() + add_class_ticks(df, unique(df$Cell_class), + palette = palette_tick_plot, + start = -5, sep = 5, height = 30, label_x_pos = -16, fontsize = 3) + + # Make sure to expand to the same value that's in p1 + expand_limits(x = -18) + + theme(legend.position = "none", + axis.text.x = element_text(angle = 90, vjust = 0.5, hjust = 1, size = 6), + axis.title.y = element_blank(), + axis.text.y = element_blank(), + axis.ticks.y = element_blank(), + # Remove plot border + panel.border = element_blank(), + # Remove white space at the top of the plot + plot.margin = margin(t=0, unit="cm")) + + plot_grid(p1, ticks, ncol = 1, align = "v") + }) + } diff --git a/clusters/ui.R b/clusters/ui.R index b8d91f1..cc612bb 100644 --- a/clusters/ui.R +++ b/clusters/ui.R @@ -1,10 +1,9 @@ source("../www/ui_functions.R") -# Load names of genes detected in mouse to provide choices in input -genes_mouse <- data.table::fread("data/joint_mouse/joint_mouse.gene_names.tsv", data.table = FALSE)$genes - -ui <- bootstrapPage( +ui <- function(request){ + + bootstrapPage( # Custom styling includeCSS("../www/minimal.css"), @@ -19,23 +18,41 @@ ui <- bootstrapPage( #### ---- Sidebar (input) ---- sidebarLayout( + sidebarPanel(width = 3, - # Gene input field, shared across tabs - selectInput("gene", "Gene", choices = genes_mouse, - multiple = TRUE), + conditionalPanel(condition = '!input.upload', + # Gene input field, shared across tabs + selectInput("gene", "Gene", choices = genes_mouse, + multiple = TRUE)), + + conditionalPanel(condition = 'input.upload', + # Gene list input with a file, shared across tabs + fileInput(inputId = "genelist", label = "Gene list", + buttonLabel = "Browse...", + multiple = FALSE, + accept = c(".csv", ".tsv"), + placeholder = "No file selected")), + + materialSwitch("upload", "Use gene list from file", + # status doesn't have any effect other than color scheme. See bootstrap status values + status = "success", + value = FALSE, + right = TRUE), + + # Input for dendrogram tab and expression table tab + conditionalPanel(condition = "(input.tabs == 'dendrogram' || input.tabs == 'exp_table' || input.tabs == 'rank_exp') && + (input.gene.length > 1 || input.upload)", + materialSwitch("mean_exp", "Display mean expression over the selected genes", + # status doesn't have any effect other than color scheme. See bootstrap status values + status = "success", + value = FALSE, + right = TRUE), + ), # Input for dendrogram tab conditionalPanel(condition = "input.tabs == 'dendrogram'", - conditionalPanel(condition = "input.gene.length > 1", - materialSwitch("mean_exp", "Plot mean expression over the selected genes", - # status doesn't have any effect other than color scheme. See bootstrap status values - status = "success", - value = FALSE, - right = TRUE), - ), - selectInput("bubble_scale", "Scaling", choices = c("Scale each gene to [0, 1]" = TRUE, "Conserve scale across genes" = FALSE), @@ -47,8 +64,9 @@ ui <- bootstrapPage( ), - # Input for all tabs other than dendrogram & table - conditionalPanel(condition = "input.tabs != 'dendrogram' && input.tabs != 'exp_table'", + # Input for all tabs other than dendrogram, ranked plot, & table + conditionalPanel(condition = "input.tabs != 'dendrogram' && input.tabs != 'exp_table' + && input.tabs != 'rank_exp'", # Specify the visible label as well as the internal # strings used to refer to each region, matching @@ -110,8 +128,16 @@ ui <- bootstrapPage( ), ), - # Update button for all sidebar inputs - actionButton("update", label = "Update") + # Update button for all sidebar inputs. Coloured to differentiate + # from the bookmark button beside it + # tags$head( + # tags$style(HTML('#update{background-color:#4863A0; + # color:#FFFFFF;}')) + # ), + actionButton("update", label = "Update"), + + # Bookmark button to store current inputs / state of app + bookmarkButton() ), @@ -123,8 +149,9 @@ ui <- bootstrapPage( tabPanel("Dendrogram", tags$br(), - p("This tab displays the mean expression of up to 20 genes in each cluster from the mouse scRNAseq development atlas"), - + tags$b("This tab displays the mean expression of up to 20 genes over each cluster in the mouse scRNAseq development atlas."), + tags$br(), + tags$br(), p("• Clusters are ordered according to the dendrogram which represents a molecular taxonomy of all cell populations"), p("• Below the dendrogram, clusters are annotated by brain region, time point, and a cell cycle G2/M phase score"), @@ -133,7 +160,7 @@ ui <- bootstrapPage( p("• Hover over each bubble, or move to the tab containing the table, to get additional details about each cluster & its expression level"), - p("• When plotting more than one gene, use the sidebar switch to plot the mean expression over the plotted genes in a new row of the bubble plot. Pct values are disregarded here, so all bubbles in this row are the same size"), + p("• When selecting more than one gene, use the sidebar switch to plot the mean expression over these genes in a new row of the bubble plot. Note that Pct values are disregarded here, so all bubbles in this row are the same size"), # Display the image of the cluster dendrogram as in Fig 1 of Jessa et al, # Nat Genet, 2019 @@ -142,18 +169,21 @@ ui <- bootstrapPage( ), # Display the bubbleplot - div(style = "margin-top: 2em; margin-left: 1em; margin-bottom: -5em;", + div(style = "margin-top: 2em; margin-left: 1em; margin-bottom: -5em; + overflow-x: visible; overflow-y: visible;", fluidRow( + # Set cellWidths equal to the actual width of each plot (server.R) splitLayout(cellWidths = c(1103, 200), + # Bubble plot(s) (plotOutput("bubble", - hover = hoverOpts(id = "bubble_hover", clip = FALSE)) %>% - withSpinner(type = 5)), + hover = hoverOpts(id = "bubble_hover", clip = FALSE), + height = 2000) %>% ws), # Gene labels - #No spinner to prevent confusing user, because there is only 1 plot - (plotOutput("bubble_labels")) + # No spinner to prevent confusing user, because there is only 1 plot + (plotOutput("bubble_labels", height = 2000)) ) ), @@ -171,19 +201,23 @@ ui <- bootstrapPage( #### ---- Expression table tab output ---- - tabPanel("Expression table", #TODO: confirm a better name + tabPanel("Expression table", tags$br(), - p("This table compares the expression of up to 20 genes in each cluster from the mouse scRNAseq development atlas"), - + tags$b("This table compares the expression of up to 20 genes in each cluster from the mouse scRNAseq development atlas."), + tags$br(), + tags$br(), p("• The value in each gene column denotes the mean gene expression per cell in the specified cluster (mean expression)"), + p("• When selecting more than one gene, use the sidebar switch to display the mean expression over these genes in a new column of the table"), + p("• Use the download button below the table to obtain a TSV file with mean expression as well as percent cluster expression values"), - fluidRow( - DT::dataTableOutput("cluster_table", width = 1100) %>% - withSpinner(type = 5) - ), + #div(style = "overflow-x: scroll; overflow-y: visible;", + fluidRow( + reactableOutput("cluster_table", width = 1100) %>% ws + ), + #), # Only display download button if update has been pressed at least once conditionalPanel(condition='input.update!=0', @@ -203,23 +237,35 @@ ui <- bootstrapPage( tags$br(), - p("This plot quantifies the proportion of cells (from 0 to 1) at each timepoint where a given gene is detected, broken down by cell type, to allow for visualizing expression across the timecourse"), - + tags$b("This plot quantifies the proportion of cells (from 0 to 1) at each timepoint where a given gene is detected, broken down by cell type, to allow for visualizing expression across the timecourse."), + tags$br(), + tags$br(), p("• Use the side bar to select which brain region to interrogate"), p("• Use the switch above the plot to toggle between static and interactive plots (update button not required)"), + p("• As only one gene can be plotted at a time, use the dropdown tool above the plots to choose which of the input genes to display (update button not required)"), + p("• Download the static version of the plot as a pdf using the button below the plot"), p("• Be aware of the y-axis, which is computed as the max for each gene"), - p("• If more than one gene is provided, only the first gene is plotted"), - - materialSwitch("plotly_ribbon", "Interactive ribbon plot", - # status doesn't have any effect other than color scheme. See bootstrap status values - status = "warning", - value = FALSE, - right = TRUE + fluidRow( + column(6, + wellPanel( + materialSwitch("plotly_ribbon", strong("Interactive ribbon plot"), + # status doesn't have any effect other than color scheme. See bootstrap status values + status = "warning", + value = FALSE, + right = TRUE), + ) + ), + column(6, + wellPanel( + selectInput("pick_timecourse", "Select gene to display", + c("Please enter a gene")) + ) + ) ), # Plot a ribbon plot, showing the proportion of cells in which @@ -228,15 +274,13 @@ ui <- bootstrapPage( conditionalPanel(condition = "input.plotly_ribbon", # Plot the ribbon plot & legend as a plotly (interactive) plot - plotlyOutput("plotlyRibbon", height = "5in", width = "11.5in") %>% - withSpinner(type = 5) + plotlyOutput("plotlyRibbon", height = "5in", width = "11.5in") %>% ws ), conditionalPanel(condition = "!(input.plotly_ribbon)", # Plot the ribbon plot & legend as static plots with ggplot2 - plotOutput("plotRibbon", height = "8.5in", width = "8in") %>% - withSpinner(type = 5) + plotOutput("plotRibbon", height = "8.5in", width = "8in") %>% ws ), # Only display download button if update has been pressed at least once @@ -257,8 +301,9 @@ ui <- bootstrapPage( tags$br(), - p("Use this tab to explore the expression of one or more genes at the single-cell level per brain region"), - + tags$b("Use this tab to explore the expression of one or more genes at the single-cell level per brain region."), + tags$br(), + tags$br(), p("• In the top row, the cells are plot in 2D according to a dimensionality reduction algorithm, coloured by cluster (left) or expression (right)"), p("• If using tSNE or UMAP reduction, hover over the plot coloured by cluster (top left) to identify each cluster. Hover will be disabled if clusters are labeled"), @@ -268,8 +313,7 @@ ui <- bootstrapPage( p("• If more than one gene is provided, the mean expression of all genes is automatically computed and displayed"), fluidRow( - # plotOutput("scatter_joint", width = "10in", height = "4in") %>% - # withSpinner(type = 5) + # plotOutput("scatter_joint", width = "10in", height = "4in") %>% ws splitLayout(cellWidths = c(432, 512), # 432 = 4.5in, 512px = 5.33in #cellArgs = list(style = "padding: 6px"), @@ -277,15 +321,13 @@ ui <- bootstrapPage( (plotOutput("dr_joint", #width = "4.5in", height = "4in", - hover = hoverOpts(id = "dr_joint_hover", clip = TRUE)) %>% - withSpinner(type = 5)), + hover = hoverOpts(id = "dr_joint_hover", clip = TRUE)) %>% ws), (plotOutput("feature_joint", #width = "5.33in", height = "4in" #, hover = hoverOpts(id = "feature_joint_hover", clip = TRUE) - ) %>% - withSpinner(type = 5)) + ) %>% ws) ) ), @@ -297,8 +339,7 @@ ui <- bootstrapPage( #fluidRow(uiOutput("feature_joint_hover_info")), fluidRow( - plotOutput("vln_joint", width = "11in", height = "4in") %>% - withSpinner(type = 5) + plotOutput("vln_joint", width = "11in", height = "4in") %>% ws ), # Specify the value to use when checking if this tab is selected @@ -315,8 +356,9 @@ ui <- bootstrapPage( tags$br(), - p("Use this tab to explore the expression of one or more genes at the single-cell level in each sample"), - + tags$b("Use this tab to explore the expression of one or more genes at the single-cell level in each sample."), + tags$br(), + tags$br(), p("• In the top row, the cells are plot in the 2D tSNE space, coloured by cluster"), p("• In the bottom row, the cells are plot in the 2D tSNE space, coloured by expression"), @@ -324,13 +366,11 @@ ui <- bootstrapPage( p("• If more than one gene is provided, the mean expression of all genes is automatically computed and displayed"), fluidRow( - plotOutput("dr_sample", width = "12.5in", height = "2.6in") %>% - withSpinner(type = 5) + plotOutput("dr_sample", width = "12.5in", height = "2.6in") %>% ws ), fluidRow( - plotOutput("feature_sample", width = "12.5in", height = "3in") %>% - withSpinner(type = 5) + plotOutput("feature_sample", width = "12.5in", height = "3in") %>% ws ) ), @@ -339,15 +379,15 @@ ui <- bootstrapPage( tags$br(), - p("Use this tab to explore the expression of one or more genes at the single-cell level in each sample"), - + tags$b("Use this tab to explore the expression of one or more genes at the single-cell level in each sample."), + tags$br(), + tags$br(), p("• Each violin plot is coloured by cluster and ordered by the expression level within the given sample"), p("• If more than one gene is provided, the mean expression of all genes is automatically computed and displayed"), fluidRow( - plotOutput("vln_sample", width = "10in", height = "20in") %>% - withSpinner(type = 5) + plotOutput("vln_sample", width = "10in", height = "20in") %>% ws ) ) @@ -357,6 +397,29 @@ ui <- bootstrapPage( value = "sample" ), + #### ---- Clusters ranked by expression tab output ---- + + tabPanel("Clusters ranked by expression", + + tags$br(), + + tags$b("This plot displays the mean expression of the selected gene in each cluster, ranked from highest to lowest expression."), + tags$br(), + tags$br(), + p("• The ticks below the plot x-axis provide a general categorization by cell type"), + + p("• If more than one gene is provided, use the sidebar toggle to plot the mean expression over these genes. If this option is off, only the first gene's expression will be plotted"), + + p("• Be aware of the y-axis, which is bounded by the maximum expression value present"), + + fluidRow( + plotOutput("rank_tick_plot", width = "12in", height = "5in") %>% ws + ), + + # Specify the value to use when checking if this tab is selected + value = "rank_exp" + ), + id = "tabs" ))), @@ -364,4 +427,4 @@ ui <- bootstrapPage( # Custom styling endPage() -) +)} diff --git a/www/ui_functions.R b/www/ui_functions.R index 640a8b8..6edc02a 100644 --- a/www/ui_functions.R +++ b/www/ui_functions.R @@ -1,8 +1,8 @@ library(shinycssloaders) -ws <- function(ui) withSpinner(ui, type = 3, size = 0.5, - color.background = "white", color = "#8896AE") +ws <- function(ui) withSpinner(ui, type = 5, + color.background = "white") navigation <- function() { includeHTML('../www/layout/navigation.html')