From 93c8d5f39ae9f9118e24f4eb232bd881c55b1b72 Mon Sep 17 00:00:00 2001 From: Paul Young Date: Tue, 29 Aug 2023 12:31:43 +1000 Subject: [PATCH 1/2] Update writerPlugin.R --- R/writerPlugin.R | 36 ++++++++++++++++++++++++------------ 1 file changed, 24 insertions(+), 12 deletions(-) diff --git a/R/writerPlugin.R b/R/writerPlugin.R index a161f6c..6cfe163 100644 --- a/R/writerPlugin.R +++ b/R/writerPlugin.R @@ -7,26 +7,38 @@ #' @export writerPlugin #' - writerPlugin <- function(plugInFile,shiny.prefixSet){ sierra <- grep("sierra",shiny.prefixSet,value=TRUE,ignore.case=TRUE) expression <- grep("expression",shiny.prefixSet,value=TRUE,ignore.case=TRUE) scRNA <- grep("scRNA",shiny.prefixSet,value=TRUE,ignore.case=TRUE) atac <- grep("atac",shiny.prefixSet,value=TRUE,ignore.case=TRUE) - - + if("sc1" %in% shiny.prefixSet){ + scRNA <- "sc1" + } + code <- readLines(plugInFile,warn = F) code <- paste0(code,collapse="\n") - - code <- gsub("\\{sierra\\}",sierra,code,ignore.case=TRUE) - code <- gsub("\\{expression\\}",expression,code,ignore.case=TRUE) - code <- gsub("\\{scRNA\\}",scRNA,code,ignore.case=TRUE) - code <- gsub("\\{atac\\}",atac,code,ignore.case=TRUE) - + + c <- try(gsub("\\{sierra\\}",sierra,code,ignore.case=TRUE)) + if(!identical(class(c),"try-error")){ + code <- c + } + c <- try(gsub("\\{expression\\}",expression,code,ignore.case=TRUE)) + if(!identical(class(c),"try-error")){ + code <- c + } + c <- try(gsub("\\{scRNA\\}",scRNA,code,ignore.case=TRUE)) + if(!identical(class(c),"try-error")){ + code <- c + } + c <- try(gsub("\\{atac\\}",atac,code,ignore.case=TRUE)) + if(!identical(class(c),"try-error")){ + code <- c + } + code <- paste0(code,"\n") #code <- glue::glue(code) - - return (code) -} + return (code) +} \ No newline at end of file From b0af530554b6d6879422a71a7dad27b946645ee3 Mon Sep 17 00:00:00 2001 From: Paul Young Date: Tue, 29 Aug 2023 13:30:24 +1000 Subject: [PATCH 2/2] Update writer.R Added Violin plot code from #75 pull --- R/writer.R | 242 +++++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 189 insertions(+), 53 deletions(-) diff --git a/R/writer.R b/R/writer.R index 1f9d6fa..bef9706 100644 --- a/R/writer.R +++ b/R/writer.R @@ -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', @@ -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', @@ -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', @@ -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',