Skip to content

Commit

Permalink
Update writer.R
Browse files Browse the repository at this point in the history 
Imported the code for violin plots from pull request SGDDNB SGDDNB#75
  • Loading branch information
@irastis
irastis committed Sep 11, 2023
1 parent b2a17f4 commit d64fb3f
Showing 1 changed file with 189 additions and 53 deletions.
242 changes: 189 additions & 53 deletions R/writer.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -661,25 +661,96 @@ wrSVfix <- function() {
' }} \n',
' return(ggOut) \n',
' }} \n',



















#insert from SGDDNB/ #75 Violinplot line 638 - 725
'# Plot gene expression stacked violin / boxplot \n',
'scStacked = function(inpConf, inpMeta, inp, inpGrp, \n',
' inpsub1, inpsub2, inpH5, \n',
' inptyp, inpGene, inpfsz){{ \n',
' if(is.null(inpsub1)){{inpsub1 = inpConf$UI[1]}} \n',
' # Identify genes that are in our dataset \n',
' geneList = scGeneList(inp, inpGene) \n',
' geneList = geneList[present == TRUE] \n',
' shiny::validate(need(nrow(geneList) <= 50, "More than 50 genes to plot! Please reduce the gene list!")) \n',
' shiny::validate(need(nrow(geneList) > 1, "Please input at least 2 genes to plot!")) \n',
' \n',
' # Prepare ggData \n',
' h5file <- H5File$new(inpH5, mode = "r") \n',
' h5data <- h5file[["grp"]][["data"]] \n',
' ggData = data.table() \n',
' for(iGene in geneList$gene){{ \n',
' tmp = inpMeta[, c("sampleID", inpConf[UI == inpsub1]$ID), with = FALSE] \n',
' colnames(tmp) = c("sampleID", "sub") \n',
' tmp$grpBy = inpMeta[[inpConf[UI == inpGrp]$ID]] \n',
' tmp$geneName = iGene \n',
' tmp$val = h5data$read(args = list(inpGene[iGene], quote(expr=))) \n',
' ggData = rbindlist(list(ggData, tmp)) \n',
' }} \n',
' h5file$close_all() \n',
' if(length(inpsub2) != 0 & length(inpsub2) != nlevels(ggData$sub)){{ \n',
' ggData = ggData[sub %in% inpsub2] \n',
' }} \n',
' shiny::validate(need(uniqueN(ggData$grpBy) > 1, "Only 1 group present, unable to plot!")) \n',
' \n',
' ## stacked violine plot \n',
' \n',
' \n',
' if(inptyp=="Stacked Violin"){{ \n',
' plot_list<- purrr::map(geneList$gene, function(feature) {{ \n',
' ggData_sub = subset(ggData, geneName==feature) \n',
' ggplot(ggData_sub, aes(x=grpBy,y=val,fill=grpBy )) + \n',
' geom_violin(scale = "width") + \n',
' xlab("") + ylab(feature) + ggtitle("") \n',
' }}) \n',
' }} else if (inptyp=="Stacked Boxplot"){{ \n',
' plot_list<- purrr::map(geneList$gene, function(feature) {{ \n',
' ggData_sub = subset(ggData, geneName==feature) \n',
' ggplot(ggData_sub, aes(x=grpBy,y=val,fill=grpBy )) + \n',
' geom_boxplot(outlier.size = 0.5) + \n',
' xlab("") + ylab(feature) + ggtitle("") \n',
' }}) \n',
' }} \n',
' ggCol = strsplit(inpConf[UI == inpGrp]$fCL, "\\\\|")[[1]] \n',
' names(ggCol) = levels(ggData$grpBy) \n',
' ggLvl = levels(ggData$grpBy)[levels(ggData$grpBy) %in% unique(ggData$grpBy)] \n',
' ggData$grpBy = factor(ggData$grpBy, levels = ggLvl) \n',
' ggCol = ggCol[ggLvl] \n',
' plot_list = purrr::map(plot_list, function(tmp_plot) {{ \n',
' tmp_plot + \n',
' scale_fill_manual(values = ggCol) + \n',
' theme_classic() + \n',
' theme(legend.position = "none", \n',
' text = element_text(size = sList[inpfsz], family = "Helvetica"), \n',
' plot.title= element_blank(), \n',
' axis.title.x = element_blank(), \n',
' axis.text.x = element_blank(), \n',
' axis.ticks.x = element_blank(), \n',
' axis.title.y = element_text(size = rel(1), angle = 0, vjust = 0.5), \n',
' axis.text.y = element_text(size = rel(1)), \n',
' axis.ticks.y = element_line(size = sList[inpfsz] / 20), \n',
' plot.margin = unit(c(-0.75, 0, -2, 0), "cm") ) \n',
' \n',
' }}) \n',
' \n',
' # Add back x-axis title to bottom plot. patchwork is going to support this? \n',
' plot_list[[length(plot_list)]]<- plot_list[[length(plot_list)]] + \n',
' theme(axis.text.x=element_text(angle = 45, hjust = 1, vjust = 1,size = sList[inpfsz]), \n',
' axis.ticks.x = element_line(size = sList[inpfsz] / 20)) \n',
' \n',
' # change the y-axis tick to only max value \n',
' ymaxs<- purrr::map_dbl(plot_list, function(p){{ \n',
' ymax<- max(ggplot_build(p)$layout$panel_scales_y[[1]]$range$range) \n',
' ceiling(ymax) \n',
' }}) \n',
' plot_list<- purrr::map2(plot_list, ymaxs, function(x,y) {{x + \n',
' scale_y_continuous(breaks = c(y)) + \n',
' expand_limits(y = y)}}) \n',
' p <- patchwork::wrap_plots(plotlist = plot_list, ncol = 1) \n',
' p \n',
' \n',
' return(p) \n',
'}} \n',
' \n',
# END #75 line 638 - 725

' \n',
' \n',
Expand Down Expand Up @@ -1177,35 +1248,81 @@ wrSVmain <- function(prefix, subst = "") {
' }} \n',
' }}) \n',
' output${prefix}d1oup <- renderPlot({{ \n',
' scBubbHeat({prefix}conf, {prefix}meta, input${prefix}d1inp, input${prefix}d1grp, input${prefix}d1plt, \n',
' input${prefix}d1sub1, input${prefix}d1sub2, "{prefix}gexpr.h5", {prefix}gene, \n',
' input${prefix}d1scl, input${prefix}d1row, input${prefix}d1col, \n',
' input${prefix}d1cols, input${prefix}d1fsz) \n',
' }}) \n',
' output${prefix}d1oup.ui <- renderUI({{ \n',
' plotOutput("{prefix}d1oup", height = pList3[input${prefix}d1psz]) \n',
' }}) \n',
' output${prefix}d1oup.pdf <- downloadHandler( \n',
' filename = function() {{ paste0("{prefix}",input${prefix}d1plt,"_",input${prefix}d1grp,".pdf") }}, \n',
' content = function(file) {{ ggsave( \n',
' file, device = "pdf", height = input${prefix}d1oup.h, width = input${prefix}d1oup.w, \n',
' plot = scBubbHeat({prefix}conf, {prefix}meta, input${prefix}d1inp, input${prefix}d1grp, input${prefix}d1plt, \n',
' input${prefix}d1sub1, input${prefix}d1sub2, "{prefix}gexpr.h5", {prefix}gene, \n',
' input${prefix}d1scl, input${prefix}d1row, input${prefix}d1col, \n',
' input${prefix}d1cols, input${prefix}d1fsz, save = TRUE) ) \n',
' }}) \n',
' output${prefix}d1oup.png <- downloadHandler( \n',
' filename = function() {{ paste0("{prefix}",input${prefix}d1plt,"_",input${prefix}d1grp,".png") }}, \n',
' content = function(file) {{ ggsave( \n',
' file, device = "png", height = input${prefix}d1oup.h, width = input${prefix}d1oup.w, \n',
' plot = scBubbHeat({prefix}conf, {prefix}meta, input${prefix}d1inp, input${prefix}d1grp, input${prefix}d1plt, \n',
' input${prefix}d1sub1, input${prefix}d1sub2, "{prefix}gexpr.h5", {prefix}gene, \n',
' input${prefix}d1scl, input${prefix}d1row, input${prefix}d1col, \n',
' input${prefix}d1cols, input${prefix}d1fsz, save = TRUE) ) \n',
' }}) \n',
' \n',
' \n',

#Deleted content from #75
# ' scBubbHeat({prefix}conf, {prefix}meta, input${prefix}d1inp, input${prefix}d1grp, input${prefix}d1plt, \n',
# ' input${prefix}d1sub1, input${prefix}d1sub2, "{prefix}gexpr.h5", {prefix}gene, \n',
# ' input${prefix}d1scl, input${prefix}d1row, input${prefix}d1col, \n',
# ' input${prefix}d1cols, input${prefix}d1fsz) \n',
# ' }}) \n',
# ' output${prefix}d1oup.ui <- renderUI({{ \n',
# ' plotOutput("{prefix}d1oup", height = pList3[input${prefix}d1psz]) \n',
# ' }}) \n',
# ' output${prefix}d1oup.pdf <- downloadHandler( \n',
# ' filename = function() {{ paste0("{prefix}",input${prefix}d1plt,"_",input${prefix}d1grp,".pdf") }}, \n',
# ' content = function(file) {{ ggsave( \n',
# ' file, device = "pdf", height = input${prefix}d1oup.h, width = input${prefix}d1oup.w, \n',
# ' plot = scBubbHeat({prefix}conf, {prefix}meta, input${prefix}d1inp, input${prefix}d1grp, input${prefix}d1plt, \n',
# ' input${prefix}d1sub1, input${prefix}d1sub2, "{prefix}gexpr.h5", {prefix}gene, \n',
# ' input${prefix}d1scl, input${prefix}d1row, input${prefix}d1col, \n',
# ' input${prefix}d1cols, input${prefix}d1fsz, save = TRUE) ) \n',
# ' }}) \n',
# ' output${prefix}d1oup.png <- downloadHandler( \n',
# ' filename = function() {{ paste0("{prefix}",input${prefix}d1plt,"_",input${prefix}d1grp,".png") }}, \n',
# ' content = function(file) {{ ggsave( \n',
# ' file, device = "png", height = input${prefix}d1oup.h, width = input${prefix}d1oup.w, \n',
# ' plot = scBubbHeat({prefix}conf, {prefix}meta, input${prefix}d1inp, input${prefix}d1grp, input${prefix}d1plt, \n',
# ' input${prefix}d1sub1, input${prefix}d1sub2, "{prefix}gexpr.h5", {prefix}gene, \n',
# ' input${prefix}d1scl, input${prefix}d1row, input${prefix}d1col, \n',
# ' input${prefix}d1cols, input${prefix}d1fsz, save = TRUE) ) \n',
# ' }}) \n',
# ' \n',
# ' \n',
#copied #75 part 2
' if(input${prefix}d1plt %in% c("Bubbleplot", "Heatmap")){{ \n',
' scBubbHeat({prefix}conf, {prefix}meta, input${prefix}d1inp, input${prefix}d1grp, input${prefix}d1plt, \n',
' input${prefix}d1sub1, input${prefix}d1sub2, "{prefix}gexpr.h5", {prefix}gene, \n',
' input${prefix}d1scl, input${prefix}d1row, input${prefix}d1col, \n',
' input${prefix}d1cols, input${prefix}d1fsz) \n',
' }} else {{ \n',
' scStacked({prefix}conf, {prefix}meta, input${prefix}d1inp, input${prefix}d1grp, \n',
' input${prefix}d1sub1, input${prefix}d1sub2, "{prefix}gexpr.h5", \n',
' input${prefix}d1plt, {prefix}gene, input${prefix}d1fsz) \n',
' }} \n',
' }}) \n',
' output${prefix}d1oup.ui <- renderUI({{ \n',
' plotOutput("{prefix}d1oup", height = pList3[input${prefix}d1psz]) \n',
' }}) \n',
' output${prefix}d1oup.pdf <- downloadHandler( \n',
' filename = function() {{ paste0("{prefix}",input${prefix}d1plt,"_",input${prefix}d1grp,".pdf") }}, \n',
' content = function(file) {{ ggsave( \n',
' file, device = "pdf", height = input${prefix}d1oup.h, width = input${prefix}d1oup.w, \n',
' plot = if(input${prefix}d1plt %in% c("Bubbleplot", "Heatmap")){{ \n',
' scBubbHeat({prefix}conf, {prefix}meta, input${prefix}d1inp, input${prefix}d1grp, input${prefix}d1plt, \n',
' input${prefix}d1sub1, input${prefix}d1sub2, "{prefix}gexpr.h5", {prefix}gene, \n',
' input${prefix}d1scl, input${prefix}d1row, input${prefix}d1col, \n',
' input${prefix}d1cols, input${prefix}d1fsz) \n',
' }} else {{ \n',
' scStacked({prefix}conf, {prefix}meta, input${prefix}d1inp, input${prefix}d1grp, \n',
' input${prefix}d1sub1, input${prefix}d1sub2, "{prefix}gexpr.h5", \n',
' input${prefix}d1plt, {prefix}gene, input${prefix}d1fsz) \n',
' }}) \n',
' }}) \n',
' output${prefix}d1oup.png <- downloadHandler( \n',
' filename = function() {{ paste0("{prefix}",input${prefix}d1plt,"_",input${prefix}d1grp,".png") }}, \n',
' content = function(file) {{ ggsave( \n',
' file, device = "png", height = input${prefix}d1oup.h, width = input${prefix}d1oup.w, \n',
' plot = if(input${prefix}d1plt %in% c("Bubbleplot", "Heatmap")){{ \n',
' scBubbHeat({prefix}conf, {prefix}meta, input${prefix}d1inp, input${prefix}d1grp, input${prefix}d1plt, \n',
' input${prefix}d1sub1, input${prefix}d1sub2, "{prefix}gexpr.h5", {prefix}gene, \n',
' input${prefix}d1scl, input${prefix}d1row, input${prefix}d1col, \n',
' input${prefix}d1cols, input${prefix}d1fsz) \n',
' }} else {{ \n',
' scStacked({prefix}conf, {prefix}meta, input${prefix}d1inp, input${prefix}d1grp, \n',
' input${prefix}d1sub1, input${prefix}d1sub2, "{prefix}gexpr.h5", \n',
' input${prefix}d1plt, {prefix}gene, input${prefix}d1fsz) \n',
' }}) \n',
' }}) \n',
#end copied #75 part 2
' ### Plots for tab d2 DAVE \n\n',


Expand Down Expand Up @@ -2001,7 +2118,12 @@ wrUImain <- function(prefix, subst = "", ptsiz = "1.25") {
' height = "200px", \n',
' value = paste0({prefix}def$genes, collapse = ", ")) %>% \n',
' helper(type = "inline", size = "m", fade = TRUE, \n',
' title = "List of genes to plot on bubbleplot / heatmap", \n',
#deletion from #75
#' title = "List of genes to plot on bubbleplot / heatmap", \n',
#end deletion
#insert from #75
' title = "List of genes to plot on bubbleplot / heatmap / stacked plot", \n',
#end insert #75
' content = c("Input genes to plot", \n',
' "- Maximum 50 genes (due to ploting space limitations)", \n',
' "- Genes should be separated by comma, semicolon or newline")), \n',
Expand All @@ -2012,10 +2134,24 @@ wrUImain <- function(prefix, subst = "", ptsiz = "1.25") {
' title = "Cell information to group cells by", \n',
' content = c("Select categorical cell information to group cells by", \n',
' "- Single cells are grouped by this categorical covariate", \n',
' "- Plotted as the X-axis of the bubbleplot / heatmap")), \n',
' radioButtons("{prefix}d1plt", "Plot type:", \n',
' choices = c("Bubbleplot", "Heatmap"), \n',
' selected = "Bubbleplot", inline = TRUE), \n',
#Deletion from #75
#' "- Plotted as the X-axis of the bubbleplot / heatmap")), \n',
#' radioButtons("{prefix}d1plt", "Plot type:", \n',
#' choices = c("Bubbleplot", "Heatmap"), \n',
#' selected = "Bubbleplot", inline = TRUE), \n',
#end deletion from #75

#insert from #75 line 2002
' "- Plotted as the X-axis of the bubbleplot / heatmap / stacked plot")), \n',
' radioButtons("sc1d1plt", "Plot type:", \n',
' choices = c("Bubbleplot", "Heatmap", "Stacked Violin", "Stacked Boxplot"), \n',
' selected = "Bubbleplot", inline = FALSE) %>% \n',
' helper(type = "inline", size = "m", fade = TRUE, \n',
' title = "Different types of plot", \n',
' content = c("The 4 plot options could be devided into 2 types", \n',
' "- Bubbleplot / Heatmap are based group summmarization and support scaling and clustering", \n',
' "- Stacked plots are to visualise group distribution and NOT support scaling and clustering")), \n',
#end insert from #75 line 2011
' radioButtons("{prefix}d1scl", "Scale gene expression", choices=c("Expression","Z-score","Fold change"), selected = "Expression", inline=TRUE), \n',
' checkboxInput("{prefix}d1row", "Cluster rows (genes)", value = TRUE), \n',
' checkboxInput("{prefix}d1col", "Cluster columns (samples)", value = FALSE), \n',
Expand Down

0 comments on commit d64fb3f

Please sign in to comment.