diff --git a/program/shinyApp/R/C.R b/program/shinyApp/R/C.R index 554425aa..6d16b3aa 100644 --- a/program/shinyApp/R/C.R +++ b/program/shinyApp/R/C.R @@ -20,12 +20,32 @@ PADJUST_METHOD <<- list( CODE_DOWNLOAD_PREFACE <<- "# ShinyOmics R Code Download\n# Load necassary packages (if errors please install respective packages) library(ggplot2) +library(ggvenn) library(ggpubr) library(rstudioapi) +library(SummarizedExperiment) +library(pheatmap) +library(ComplexUpset) +library(clusterProfiler) + +# make sure environment is empty + # if not run in RStudio you need to specify the directory fo the file yourself! -direcoty_of_files=dirname(rstudioapi::getSourceEditorContext()$path) -envList=readRDS(paste0(direcoty_of_files,'/','Data.rds')) +if(Sys.getenv('RSTUDIO')==1){ + direcoty_of_files=dirname(rstudioapi::getSourceEditorContext()$path) + envList=readRDS(paste0(direcoty_of_files,'/','Data.rds')) + if('utils.R' %in% list.files(direcoty_of_files)){ + source(file.path(direcoty_of_files,'utils.R')) + } +}else{ + # assuming to be in the correct directory (where Code lies) + envList=readRDS('Data.rds') + if('utils.R' %in% list.files()){ + source('utils.R') + } +} + list2env(envList,envir = globalenv()) # loads the varaibles directly into global env diff --git a/program/shinyApp/R/SourceAll.R b/program/shinyApp/R/SourceAll.R index d1d179ea..361ad275 100644 --- a/program/shinyApp/R/SourceAll.R +++ b/program/shinyApp/R/SourceAll.R @@ -1,9 +1,10 @@ +source("R/C.R",local = T) source("R/fun_filterRNA.R",local = T) source("R/fun_LFC.R",local = T) source("R/heatmap/fun_entitieSelection.R",local = T) source("R/fun_LogIt.R",local = T) source("R/fun_readInSampleTable.R",local = T) -source("R/fun_ggplot.R",local = T) +source("R/fun_getCodeSnippets.R",local = T) source("R/Guide.R",local = T) source("R/module_DownloadReport.R",local = T) source("R/enrichment_analysis/enrichment_analysis.R", local = T) @@ -21,3 +22,4 @@ source("R/significance_analysis/server.R", local = T) source("R/significance_analysis/util.R", local = T) source("R/pre_processing/util.R", local = T) source("R/util.R", local = T) + diff --git a/program/shinyApp/R/enrichment_analysis/overrepresentation_analysis.R b/program/shinyApp/R/enrichment_analysis/overrepresentation_analysis.R index 623a4fbc..0b9d497e 100644 --- a/program/shinyApp/R/enrichment_analysis/overrepresentation_analysis.R +++ b/program/shinyApp/R/enrichment_analysis/overrepresentation_analysis.R @@ -9,6 +9,7 @@ over_representation_analysis <- function( # Overrepresentation analysis # no translation needed as already done before. + # set Species species <- "Mus musculus" if(organsim == "Human genes (GRCh38.p14)"){ diff --git a/program/shinyApp/R/enrichment_analysis/server.R b/program/shinyApp/R/enrichment_analysis/server.R index e0fc7d2c..169c26dc 100644 --- a/program/shinyApp/R/enrichment_analysis/server.R +++ b/program/shinyApp/R/enrichment_analysis/server.R @@ -29,9 +29,9 @@ enrichment_analysis_geneset_server <- function( hideElement(id = "EnrichmentFailure") output$EnrichmentPlot <- renderPlot({clusterProfiler::dotplot(result)}) if(ea_type == "GeneSetEnrichment"){ - ea_scenario <- 14 - }else{ ea_scenario <- 15 + }else{ + ea_scenario <- 14 } } else{ # print that no significant result was found @@ -39,20 +39,33 @@ enrichment_analysis_geneset_server <- function( output$EnrichmentFailure <- renderText("No significant result found. For further details check the table.") ea_scenario <- 0 } + # download R Code for further plotting output$getR_Code <- downloadHandler( filename = function(){ paste0("ShinyOmics_Rcode2Reproduce_", Sys.Date(), ".zip") }, content = function(file){ - envList <- list(EnrichmentRes = result) - # assign unique name to result for saving later - result_name <- paste("EnrichmentRes", id, sep="_") - names(envList) <- result_name - + # tmp <- getUserReactiveValues(input) + # par_tmp$Enrichment[names(tmp)] <<- tmp + envList <- list( + res_tmp = res_tmp[[session$token]], + par_tmp = par_tmp[[session$token]] + ) temp_directory <- file.path(tempdir(), as.integer(Sys.time())) dir.create(temp_directory) + # functions needed + source("R/SourceAll.R") + + save.function.from.env(wanted = c("check_annotation_enrichment_analysis", + "translate_genes_ea", + "translate_genes_oa", + "gene_set_enrichment", + "over_representation_analysis"), + file = file.path(temp_directory, "utils.R")) + + write(getPlotCode(ea_scenario), file.path(temp_directory, "Code.R")) saveRDS(envList, file.path(temp_directory, "Data.RDS")) @@ -565,15 +578,15 @@ enrichment_analysis_Server <- function(id, data, params, updates){ geneSetChoice <- reactive({ if(isTruthy(input$GeneSet2Enrich)){ if(input$GeneSet2Enrich == "DE_Genes"){ - # atm this is not done + # TODO add option to send DE genes geneSetChoice_tmp <- DE_genelist() } if(input$GeneSet2Enrich == "ProvidedGeneSet"){ if(!is.null(input$UploadedGeneSet)){ Tmp <- read.csv(input$UploadedGeneSet$datapath, header = F) - # check take first column as acharacter vector + # check take first column as a character vector geneSetChoice_tmp <- Tmp$V1 - ## Here somehow if value next to gene provieded needs to be considered further down + ## Here somehow if value next to gene provided needs to be considered further down # Check if they start with "ENS.." if(!length(which(grepl("ENS.*",geneSetChoice_tmp) == TRUE)) == length(geneSetChoice_tmp)){ print("wrong data!") @@ -628,6 +641,8 @@ enrichment_analysis_Server <- function(id, data, params, updates){ fun_LogIt("## ENRICHMENT") req(geneSetChoice()) ea_reactives$tmp_genes <- geneSetChoice() + par_tmp[[session$token]]$Enrichment$tmp_genes <<- ea_reactives$tmp_genes + par_tmp[[session$token]]$Enrichment$enrichments2do <<- ea_reactives$enrichments2do # Check whether the necessary annotation is available anno_results <- check_annotation_enrichment_analysis(ea_reactives$data) ea_reactives$data <- anno_results$new_data @@ -739,6 +754,8 @@ enrichment_analysis_Server <- function(id, data, params, updates){ input$Groups2Compare_treat_GSEA, input$ValueToAttach ) + tmp <- getUserReactiveValues(input) + par_tmp[[session$token]]$Enrichment[names(tmp)] <<- tmp }else{ ea_reactives$enrichment_results <- over_representation_analysis( input, @@ -748,20 +765,13 @@ enrichment_analysis_Server <- function(id, data, params, updates){ ea_reactives$enrichments2do, input$test_correction ) + tmp <- getUserReactiveValues(input) + par_tmp[[session$token]]$Enrichment[names(tmp)] <<- tmp } ea_reactives$ea_info <- "**Enrichment Analysis Done!**" # res_temp Zuweisung res_tmp[[session$token]]["Enrichment"] <<- ea_reactives$enrichment_results - # par_temp Zuweisung - par_tmp[[session$token]]["Enrichment"] <<- list( - "ValueToAttach" = input$ValueToAttach, - "GeneSet2Enrich" = input$GeneSet2Enrich, - "Groups2Compare_ref_GSEA" = input$Groups2Compare_ref_GSEA, - "Groups2Compare_treat_GSEA" = input$Groups2Compare_treat_GSEA, - "sample_annotation_types_cmp_GSEA" = input$sample_annotation_types_cmp_GSEA, - "ORA_or_GSE" = input$ORA_or_GSE, - "UniverseOfGene" = input$UniverseOfGene - ) + }) }) diff --git a/program/shinyApp/R/fun_getCodeSnippets.R b/program/shinyApp/R/fun_getCodeSnippets.R new file mode 100644 index 00000000..b6ebe759 --- /dev/null +++ b/program/shinyApp/R/fun_getCodeSnippets.R @@ -0,0 +1,1056 @@ + +getPlotCode <- function(numberOfScenario) { + PreProcessing_Procedure <- par_tmp[[session$token]]$PreProcessing_Procedure + row_selection <- par_tmp[[session$token]]$row_selection + col_selection <- par_tmp[[session$token]]$sample_selection + omic_type <- par_tmp[[session$token]]$omic_type + + #TODO change all data download to par_tmp and res_tmp + # Selection ---- + if(any(row_selection == "all")){ + stringSelection <- 'selected <- rownames(rowData(res_tmp$data_original)) + ' + }else{ + if(!(length(row_selection) == 1 & any(row_selection == "High Values+IQR"))){ + stringSelection <- 'selected <- c() +selected <- unique( + c(selected,rownames(rowData(res_tmp$data_original))[ + which(rowData(res_tmp$data_original) + [,par_tmp$providedRowAnnotationTypes]%in%par_tmp$row_selection)] + ) + ) + ' + } + if(any(row_selection == "High Values+IQR") ){ + stringSelection <- 'toKeep <- filter_rna( + rna = assay(res_tmp$data_original), + prop = par_tmp$propensityChoiceUser + ) + filteredIQR_Expr <- assay(res_tmp$data_original)[toKeep,] + ' + if(length(row_selection) == 1){ + stringSelection <- paste0(stringSelection, + 'selected <- rownames(filteredIQR_Expr)') + }else{ + stringSelection <- paste0(stringSelection, + 'selected <- intersect( + selected, + rownames(filteredIQR_Expr) + )') + } + } + } + + if(any(col_selection == "all")){ + stringSelection <- paste0(stringSelection,"\n", + 'samples_selected <- colnames(assay(res_tmp$data_original)) + tmp_data_selected <- res_tmp$data_original[selected,samples_selected] + ') + }else{ + stringSelection <- paste0(stringSelection, + 'samples_selected <- c( + samples_selected, + rownames(colData(res_tmp$data_original))[which( + colData(res_tmp$data_original)[,par_tmp$providedSampleAnnotationTypes] %in% par_tmp$sample_selection + )] + ) + tmp_data_selected <- res_tmp$data_original[selected,samples_selected] + ') + } + # Preprocessing ---- + + if(PreProcessing_Procedure != "none"){ + if(PreProcessing_Procedure == "filterOnly"){ + if(omic_type == "Transcriptomics"){ + stringPreProcessing <- 'processedData <- tmp_data_selected[which(rowSums(assay(tmp_data_selected)) > 10),]' + } + if(omic_type == "Metabolomics"){ + stringPreProcessing <- 'processedData <- tmp_data_selected[which(apply(assay(tmp_data_selected),1,median)!=0),]' + } + prequel_stringPreProcessing <- c("") + }else{ + if(omic_type == "Transcriptomics"){ + prequel_stringPreProcessing <- 'res_tmp$data <- tmp_data_selected[which(rowSums(assay(tmp_data_selected)) > 10),]' + } + if(omic_type == "Metabolomics"){ + prequel_stringPreProcessing <- 'res_tmp$data <- tmp_data_selected[which(apply(assay(tmp_data_selected),1,median)!=0),]' + } + } + + if(PreProcessing_Procedure == "simpleCenterScaling"){ + stringPreProcessing <- 'processedData <- as.data.frame(t( + scale( + x = as.data.frame(t(as.data.frame(assay(res_tmp$data)))), + scale = T, + center = T + ) + ) + ) + assay(res_tmp$data) <- as.data.frame(processedData) + ' + } + if(PreProcessing_Procedure == "vst_DESeq"){ + stringPreProcessing <- 'dds <- DESeq2::DESeqDataSetFromMatrix( + countData = assay(res_tmp$data), + colData = colData(res_tmp$data), + design = as.formula(par_tmp$DESeq_formula) + ) + de_seq_result <- DESeq2::DESeq(dds) + res_tmp$DESeq_obj <- de_seq_result + dds_vst <- vst( + object = de_seq_result, + blind = TRUE + ) + assay(res_tmp$data) <- as.data.frame(assay(dds_vst)) + ' + } + if(PreProcessing_Procedure == "Scaling_0_1"){ + stringPreProcessing <- 'processedData <- as.data.frame(t( + apply(assay(res_tmp$data),1,function(x){ + (x - min(x))/(max(x) - min(x)) + }) + )) + assay(res_tmp$data) <- as.data.frame(processedData) + ' + } + if(PreProcessing_Procedure == "ln"){ + stringPreProcessing <- 'processedData <- as.data.frame(log( + as.data.frame(assay(res_tmp$data)) + )) + assay(res_tmp$data) <- as.data.frame(processedData) + ' + } + if(PreProcessing_Procedure == "log10"){ + stringPreProcessing <- 'processedData <- as.data.frame(assay(res_tmp$data)) + if(any(processedData==0)){ + processedData <- as.data.frame(log10( + processedData + 1) + ) + assay(res_tmp$data) <- as.data.frame(processedData) + }' + } + + if(PreProcessing_Procedure == "pareto_scaling"){ + stringPreProcessing <- 'processedData <- as.data.frame(assay(res_tmp$data)) + centered <- as.data.frame(t( + apply(processedData, 1, function(x){x - mean(x)}) + )) + pareto.matrix <- as.data.frame(t( + apply(centered, 1, function(x){x/sqrt(sd(x))}) + )) + + assay(res_tmp$data) <- as.data.frame(pareto.matrix) + ' + } + stringPreProcessing <- paste0(prequel_stringPreProcessing,"\n",stringPreProcessing) + }else{ + stringPreProcessing <- '' + } + + +## Plot Code ---- + ## PCA ---- + if(numberOfScenario >= 1 & numberOfScenario < 9){ + # Calculate all necessary intermediate data sets + prequel_stringtosave <- ' + + pca <- prcomp( + x = as.data.frame(t(assay(res_tmp$data))), + center = T, + scale. = FALSE + ) + + pcaData <- data.frame(pca$x,colData(res_tmp$data)) +# Annotation (important for plotly) + if(!any(colnames(pcaData) == "global_ID")){ + pcaData$global_ID <- rownames(pcaData) + } + if(!is.null(par_tmp$PCA$PCA_anno_tooltip)){ + adj2colname <- gsub(" ",".",par_tmp$PCA$PCA_anno_tooltip) + pcaData$chosenAnno <- pcaData[,adj2colname] + }else{ + pcaData$chosenAnno <- pcaData$global_ID + } +# Scree Plot calculations +var_explained_df <- data.frame( + PC = paste0("PC",1:ncol(pca$x)), + var_explained = (pca$sdev)^2/sum((pca$sdev)^2) +) +var_explained_df$Var <- paste0(round(var_explained_df$var_explained,4)*100,"%") +var_explained_df$PC <- factor(var_explained_df$PC,levels = paste0("PC",1:ncol(pca$x))) +percentVar <- round(100 * var_explained_df$var_explained, digits = 1) +names(percentVar)<- var_explained_df$PC + +# Loadings calculations +LoadingsDF <- data.frame( + entitie = rownames(pca$rotation), + Loading = pca$rotation[,par_tmp$PCA$x_axis_selection] +) +LoadingsDF <- LoadingsDF[order(LoadingsDF$Loading,decreasing = T),] +LoadingsDF <- rbind( +LoadingsDF[nrow(LoadingsDF):(nrow(LoadingsDF) - par_tmp$PCA$bottomSlider),], + LoadingsDF[par_tmp$PCA$topSlider:1,] +) +LoadingsDF$entitie <- factor(LoadingsDF$entitie,levels = rownames(LoadingsDF)) +if(!is.null(par_tmp$PCA$EntitieAnno_Loadings)){ + LoadingsDF$entitie=factor( + make.unique(as.character(rowData(res_tmp$data)[rownames(LoadingsDF),par_tmp$PCA$EntitieAnno_Loadings])), + levels = make.unique(as.character(rowData(res_tmp$data)[rownames(LoadingsDF),par_tmp$PCA$EntitieAnno_Loadings])) + ) +} + +if(is.null(par_tmp$PCA$nPCAs_to_look_at)){ + df_loadings <- data.frame( + entity = row.names(pca$rotation), + pca$rotation[, 1:2] + ) +}else{ + df_loadings <- data.frame( + entity = row.names(pca$rotation), + pca$rotation[, 1:par_tmp$PCA$nPCAs_to_look_at] + ) +} + +df_loadings_filtered <- as.matrix(df_loadings[,-1]) >= abs(par_tmp$PCA$filterValue) +entitiesToInclude <- apply(df_loadings_filtered, 1, any) + +df_loadings <- df_loadings[entitiesToInclude,] %>% + tidyr::gather(key = "PC", value = "loading", -entity) + +if(!is.null(par_tmp$PCA$EntitieAnno_Loadings_matrix)){ + df_loadings$chosenAnno <- factor( + make.unique(as.character(rowData(res_tmp$data)[unique(df_loadings$entity),par_tmp$PCA$EntitieAnno_Loadings_matrix])), + levels = make.unique(as.character(rowData(res_tmp$data)[unique(df_loadings$entity),par_tmp$PCA$EntitieAnno_Loadings_matrix])) + ) +}else{ + df_loadings$chosenAnno <- df_loadings$entity +} +' + + if (numberOfScenario == 1) { + stringtosave = 'pca_plot <- ggplot(pcaData, aes(x = pcaData[,par_tmp$PCA$x_axis_selection], + y = pcaData[,par_tmp$PCA$y_axis_selection], + color=pcaData[,par_tmp$PCA$coloring_options], + label=global_ID, + global_ID=global_ID, + chosenAnno=chosenAnno)) + + geom_point(size =3)+ + scale_color_manual(name = par_tmp$PCA$coloring_options,values=par_tmp$PCA$colorTheme)+ + xlab(paste0(names(percentVar[par_tmp$PCA$x_axis_selection]),": ",percentVar[par_tmp$PCA$x_axis_selection], "% variance")) + + ylab(paste0(names(percentVar[par_tmp$PCA$y_axis_selection]),": ", percentVar[par_tmp$PCA$y_axis_selection], "% variance")) + + coord_fixed()+ + theme_classic()+ + theme(aspect.ratio = 1)+ + ggtitle(par_tmp$PCA$customTitle)' + } + if (numberOfScenario == 2) { + stringtosave = 'pca_plot <- ggplot(pcaData, aes(x = pcaData[,par_tmp$PCA$x_axis_selection], + y = pcaData[,par_tmp$PCA$y_axis_selection], + color=pcaData[,par_tmp$PCA$coloring_options], + label=global_ID, + global_ID=global_ID, + chosenAnno=chosenAnno)) + + geom_point(size =3)+ + scale_color_discrete(name = par_tmp$PCA$coloring_options)+ + xlab(paste0(names(percentVar[par_tmp$PCA$x_axis_selection]),": ",percentVar[par_tmp$PCA$x_axis_selection], "% variance")) + + ylab(paste0(names(percentVar[par_tmp$PCA$y_axis_selection]),": ", percentVar[par_tmp$PCA$y_axis_selection], "% variance")) + + coord_fixed()+ + theme_classic()+ + theme(aspect.ratio = 1)+ + ggtitle(par_tmp$PCA$customTitle)' + } + if (numberOfScenario == 3) { + stringtosave = 'pca_plot <- ggplot(pcaData, aes(x = pcaData[,par_tmp$PCA$x_axis_selection], + y = pcaData[,par_tmp$PCA$y_axis_selection], + color=pcaData[,par_tmp$PCA$coloring_options], + label=global_ID, + global_ID=global_ID, + chosenAnno=chosenAnno)) + + geom_point(size =3)+ + scale_color_manual(values=par_tmp$PCA$colorTheme, + name = par_tmp$PCA$coloring_options)+ + xlab(paste0(names(percentVar[par_tmp$PCA$x_axis_selection]),": ",percentVar[par_tmp$PCA$x_axis_selection], "% variance")) + + ylab(paste0(names(percentVar[par_tmp$PCA$y_axis_selection]),": ", percentVar[par_tmp$PCA$y_axis_selection], "% variance")) + + coord_fixed()+ + theme_classic()+ + theme(aspect.ratio = 1)+ + ggtitle(par_tmp$PCA$customTitle)' + } + if (numberOfScenario == 4) { + stringtosave = 'pca_plot <- ggplot(pcaData, aes(x = pcaData[,par_tmp$PCA$x_axis_selection], + y = pcaData[,par_tmp$PCA$y_axis_selection], + color=pcaData[,par_tmp$PCA$coloring_options], + label=global_ID, + global_ID=global_ID, + chosenAnno=chosenAnno)) + + geom_point(size =3)+ + scale_color_manual(name = par_tmp$PCA$coloring_options,values=par_tmp$PCA$colorTheme)+ + xlab(paste0(names(percentVar[par_tmp$PCA$x_axis_selection]),": ",percentVar[par_tmp$PCA$x_axis_selection], "% variance")) + + ylab(paste0(names(percentVar[par_tmp$PCA$y_axis_selection]),": ", percentVar[par_tmp$PCA$y_axis_selection], "% variance")) + + coord_fixed()+ + theme_classic()+ + theme(aspect.ratio = 1)+ + ggtitle(par_tmp$PCA$customTitle)+geom_segment(data=df_out_r[which(df_out_r$feature!=""),], + aes(x=0, y=0, xend=v1, yend=v2), + arrow=arrow(type="closed",unit(0.01, "inches"),ends = "both"), + #linetype="solid", + #alpha=0.5, + color="#ab0521")' + + + } + if (numberOfScenario == 5) { + stringtosave = 'pca_plot <- ggplot(pcaData, aes(x = pcaData[,par_tmp$PCA$PCA$x_axis_selection], + y = pcaData[,par_tmp$PCA$PCA$y_axis_selection], + color=pcaData[,par_tmp$PCA$PCA$coloring_options], + label=global_ID, + global_ID=global_ID, + chosenAnno=chosenAnno)) + + geom_point(size =3)+ + scale_color_discrete(name = par_tmp$PCA$coloring_options)+ + xlab(paste0(names(percentVar[par_tmp$PCA$x_axis_selection]),": ",percentVar[par_tmp$PCA$x_axis_selection], "% variance")) + + ylab(paste0(names(percentVar[par_tmp$PCA$y_axis_selection]),": ", percentVar[par_tmp$PCA$y_axis_selection], "% variance")) + + coord_fixed()+ + theme_classic()+ + theme(aspect.ratio = 1)+ + ggtitle(par_tmp$PCA$customTitle)+ + geom_segment(data=df_out_r[which(df_out_r$feature!=""),], + aes(x=0, y=0, xend=v1, yend=v2), + arrow=arrow(type="closed",unit(0.01, "inches"),ends = "both"), + #linetype="solid", + #alpha=0.5, + color="#ab0521")' + } + if (numberOfScenario == 6) { + stringtosave = 'pca_plot <- ggplot(pcaData, aes(x = pcaData[,par_tmp$PCA$x_axis_selection], + y = pcaData[,par_tmp$PCA$y_axis_selection], + color=pcaData[,par_tmp$PCA$coloring_options], + label=global_ID, + global_ID=global_ID, + chosenAnno=chosenAnno)) + + geom_point(size =3)+ + scale_color_manual(values=par_tmp$PCA$colorTheme, + name = par_tmp$PCA$coloring_options)+ + xlab(paste0(names(percentVar[par_tmp$PCA$x_axis_selection]),": ",percentVar[par_tmp$PCA$x_axis_selection], "% variance")) + + ylab(paste0(names(percentVar[par_tmp$PCA$y_axis_selection]),": ", percentVar[par_tmp$PCA$y_axis_selection], "% variance")) + + coord_fixed()+ + theme_classic()+ + theme(aspect.ratio = 1)+ + ggtitle(par_tmp$PCA$customTitle)+geom_segment(data=df_out_r[which(df_out_r$feature!=""),], + aes(x=0, y=0, xend=v1, yend=v2), + arrow=arrow(type="closed",unit(0.01, "inches"),ends = "both"), + #linetype="solid", + #alpha=0.5, + color="#ab0521")' + } +### Scree + if (numberOfScenario == 7) { + stringtosave = 'scree_plot=ggplot(var_explained_df,aes(x=PC,y=var_explained, group=1))+ + geom_point(size=4,aes(label=Var))+ + geom_line()+ + ylab("Variance explained")+ + theme_bw()+ + ggtitle("Scree-Plot for shown PCA")' + } +### Loadings single + if (numberOfScenario == 8) { + stringtosave = 'plotOut=ggplot(LoadingsDF,aes(x = Loading,y = entitie)) + + geom_col(aes(fill = Loading)) + + scale_y_discrete( + breaks = LoadingsDF$entitie, + labels = stringr::str_wrap(gsub("\\\\.[0-9].*$","",LoadingsDF$entitie),20)) + + scale_fill_gradient2(low = "#277d6a",mid = "white",high = "orange") + + ylab(ifelse(is.null(par_tmp$PCA$EntitieAnno_Loadings),"",par_tmp$PCA$EntitieAnno_Loadings)) + + xlab(paste0("Loadings: ",par_tmp$PCA$x_axis_selection)) + + theme_bw(base_size = 15)' + } +### Loadings matrix + if (numberOfScenario == 8.1) { + stringtosave = 'LoadingsMatrix_plot <- ggplot(df_loadings, + aes(x = PC,y = chosenAnno,fill = loading)) + + geom_raster() + + scale_fill_gradientn( + colors = c("#277d6a", "white", "orange"), + limits = c(-max(df_loadings$loading),max(df_loadings$loading)) + ) + + labs(x = "PCs", y = "entity", fill = "Loading") + + theme_bw(base_size = 15)' + } + + stringtosave <- paste0(prequel_stringtosave,"\n",stringtosave,"\n","lapply(ls(pattern='plot'), get)") + + } + + + ## Heatmap ---- +if(numberOfScenario >= 10 & numberOfScenario <= 11){ + prequel_stringtosave <- ' +colorTheme <- c("#a6cee3", "#1f78b4", "#b2df8a", "#33a02c","#fdbf6f", "#ff7f00", "#fb9a99", "#e31a1c") +paletteLength <- 25 +myColor_fill <- colorRampPalette(c("blue", "white", "firebrick"))(paletteLength) + +# select and caluculate Heatmap input depending on users input - +# check par_tmp$Heatmap for selected options or change accrodingly to what you desire +mycolors <- list() +if(length(par_tmp$Heatmap$anno_options) == 1){ + if(length(unique(colData(res_tmp$data)[,par_tmp$Heatmap$anno_options])) <= 8){ + names(colorTheme) <- unique(colData(res_tmp$data)[,par_tmp$Heatmap$anno_options]) + colorTheme <- colorTheme[!is.na(names(colorTheme))] + mycolors[[par_tmp$Heatmap$anno_options]] <- colorTheme + } +} + + +# Do PreSelection of input to Heatmap to show + +# selection based on row Annotation: +if(!(any(par_tmp$Heatmap$row_selection_options == "all"))){ + if(any(par_tmp$Heatmap$row_selection_options == "rowAnno_based")){ + additionalInput_row_anno <- ifelse(any(par_tmp$Heatmap$row_selection_options == "rowAnno_based"),"yip",NA) + if(!is.na(additionalInput_row_anno)){ + additionalInput_row_anno <- par_tmp$Heatmap$anno_options_heatmap + } + additionalInput_row_anno_factor <- par_tmp$Heatmap$row_anno_options_heatmap + }else{ + additionalInput_row_anno <- ifelse(any(par_tmp$Heatmap$row_selection_options == "rowAnno_based"),par_tmp$Heatmap$anno_options_heatmap,NA) + additionalInput_row_anno_factor <- ifelse(any(par_tmp$Heatmap$row_selection_options == "rowAnno_based"),c(par_tmp$Heatmap$row_anno_options_heatmap),NA) + } +}else{ + additionalInput_row_anno <- "all" + additionalInput_row_anno_factor <- NA +} + +#Selection and/or ordering based on LFC +additionalInput_sample_annotation_types <- ifelse(is.null(par_tmp$Heatmap$sample_annotation_types_cmp_heatmap),NA,par_tmp$Heatmap$sample_annotation_types_cmp_heatmap) +additionalInput_ctrl_idx <- ifelse(is.null(par_tmp$Heatmap$Groups2Compare_ref_heatmap),NA,par_tmp$Heatmap$Groups2Compare_ref_heatmap) +additionalInput_cmp_idx <- ifelse(is.null(par_tmp$Heatmap$Groups2Compare_treat_heatmap),NA,par_tmp$Heatmap$Groups2Compare_treat_heatmap) +psig_threhsold <- ifelse(is.null(par_tmp$Heatmap$psig_threhsold_heatmap),NA,par_tmp$Heatmap$psig_threhsold_heatmap) + +# select TopK (if there is an ordering) +TopK2Show <- ifelse(any(par_tmp$Heatmap$row_selection_options=="TopK"),par_tmp$Heatmap$TopK,NA) + +if(any(par_tmp$Heatmap$row_selection_options=="all")){ + print("No entitie selection") + data2HandOver <- as.data.frame(assay(res_tmp$data)) +}else{ + + # Note entitieSelection and getLFCs is a custom function - source code in utils.R + data2HandOver <- entitieSelection( + res_tmp$data, + type = par_tmp$Heatmap$row_selection_options, + additionalInput_row_anno = additionalInput_row_anno, + additionalInput_row_anno_factor = additionalInput_row_anno_factor, + additionalInput_sample_annotation_types = additionalInput_sample_annotation_types, + additionalInput_ctrl_idx = additionalInput_ctrl_idx, + additionalInput_cmp_idx = additionalInput_cmp_idx, + psig_threhsold = psig_threhsold, + TopK2Show = TopK2Show + ) +} + +doThis_flag <- T +if(is.null(data2HandOver)){ + print("Nothing is left,e.g. no significant Terms or TopK is used but no inherent order of the data") + heatmap_plot <- NULL + doThis_flag <- F +} +' + + if(numberOfScenario == 10){ + stringtosave <- ' +annotation_col <- rowData(res_tmp$data)[,par_tmp$Heatmap$row_anno_options,drop=F] + +ctrl_samples_idx <- which( + colData(res_tmp$data)[,par_tmp$Heatmap$sample_annotation_types_cmp_heatmap]%in%par_tmp$Heatmap$Groups2Compare_ref_heatmap + ) +comparison_samples_idx <- which( + colData(res_tmp$data)[,par_tmp$Heatmap$sample_annotation_types_cmp_heatmap]%in%par_tmp$Heatmap$Groups2Compare_treat_heatmap +) +if(length(comparison_samples_idx) <=1 | length(ctrl_samples_idx) <=1){ + print("Choose variable with at least two samples per condition!") + doThis_flag <- F +} + +if(par_tmp$PreProcessing_Procedure == "simpleCenterScaling"| any(data2HandOver)< 0){ + print("Remember do not use normal center + scaling (negative Values!)") +}else if(doThis_flag){ + Data2Plot <- getLFC( + data = as.data.frame(data2HandOver), + ctrl_samples_idx = ctrl_samples_idx, + comparison_samples_idx = comparison_samples_idx + ) + +if(par_tmp$Heatmap$LFC_toHeatmap){ + myBreaks <- c(seq(min(res_tmp$Heatmap$LFC), 0, length.out=ceiling(paletteLength/2) + 1), + seq(max(res_tmp$Heatmap$LFC)/paletteLength, max(res_tmp$Heatmap$LFC), length.out=floor(paletteLength/2))) + annotation_col <- rowData(res_tmp$data)[rownames(Data2Plot),par_tmp$Heatmap$row_anno_options,drop=F] +} + + +heatmap_plot <- pheatmap((t(Data2Plot[,"LFC",drop=F])), + main="Heatmap - LFC", + show_rownames=ifelse(nrow(Data2Plot)<=25,TRUE,FALSE), + show_colnames=TRUE, + cluster_cols = par_tmp$Heatmap$cluster_cols, + cluster_rows = FALSE, # par_tmp$Heatmap$cluster_rows, + scale=ifelse(par_tmp$Heatmap$rowWiseScaled,"row","none"), + # cutree_cols = 4, + #fontsize = font.size, + annotation_col = annotation_col, + + silent = F, + breaks = myBreaks, + color = myColor_fill)' + } + if(numberOfScenario == 11){ + stringtosave <- ' +annotation_col <- colData(res_tmp$data)[,par_tmp$Heatmap$anno_options,drop=F] +annotation_row <- rowData(res_tmp$data)[,par_tmp$Heatmap$row_anno_options,drop=F] +# convert both to data.frame +annotation_col <- as.data.frame(annotation_col) +annotation_row <- as.data.frame(annotation_row) + +clusterRowspossible <- ifelse(nrow(as.matrix(assay(res_tmp$data)))>1,par_tmp$Heatmap$cluster_rows,F) + +heatmap_plot <- pheatmap(as.matrix(res_tmp$Heatmap), + main="Heatmap", + show_rownames=ifelse(nrow((assay(res_tmp$data)))<=par_tmp$Heatmap$row_label_no,TRUE,FALSE), + labels_row = rowData(res_tmp$data)[rownames(assay(res_tmp$data)),par_tmp$Heatmap$row_label_options], + show_colnames=TRUE, + cluster_cols = par_tmp$Heatmap$cluster_cols, + cluster_rows = clusterRowspossible, + scale=ifelse(par_tmp$Heatmap$rowWiseScaled,"row","none"), + # cutree_cols = 4, + #fontsize = font.size, + annotation_col = annotation_col, + annotation_row =annotation_row, + annotation_colors = mycolors, + silent = F)' + } +stringtosave <- paste0(prequel_stringtosave,"\n",stringtosave) +} + + + +## Single Gene Visualisation ---- +if(numberOfScenario %in% c(12,13)){ + if(par_tmp[[session$token]]$SingleEntVis$type_of_data_gene == "preprocessed"){ + prequel_stringtosave <- '#get IDX to data +idx_selected <- which(par_tmp$SingleEntVis$Select_Gene == rowData(res_tmp$data)[,par_tmp$SingleEntVis$Select_GeneAnno]) +GeneData <- as.data.frame(t(as.data.frame(assay(res_tmp$data))[idx_selected,,drop=F])) +GeneData$anno <- colData(res_tmp$data)[,par_tmp$SingleEntVis$accross_condition] +if(length(idx_selected)>1){ + # summarise the data + GeneData_medians <- rowMedians(as.matrix(GeneData[,-ncol(GeneData)])) + GeneData <- GeneData[,ncol(GeneData),drop=F] + GeneData$rowMedian <- GeneData_medians + GeneData <- GeneData[,c("rowMedian","anno")] +} +GeneData$anno <- as.factor(GeneData$anno) + ' + }else if(par_tmp[[session$token]]$SingleEntVis$type_of_data_gene == "raw" ){ + prequel_stringtosave <- '#get IDX to data +idx_selected <- which(par_tmp$SingleEntVis$Select_Gene == rowData(res_tmp$data_original)[,par_tmp$SingleEntVis$Select_GeneAnno]) +GeneData <- as.data.frame(t(assay(res_tmp$data_original)[idx_selected,,drop=F])) +GeneData$anno <- colData(res_tmp$data_original)[,par_tmp$SingleEntVis$accross_condition] +# select to selection of processed data +annoToSelect=unique(c(colData(res_tmp$data)[,par_tmp$SingleEntVis$accross_condition])) +GeneData = subset(GeneData, anno %in% annoToSelect) +if(length(idx_selected)>1){ + # summarise the data + GeneData_medians <- rowMedians(as.matrix(GeneData[,-ncol(GeneData)])) + GeneData <- GeneData[,ncol(GeneData),drop=F] + GeneData$rowMedian <- GeneData_medians + GeneData <- GeneData[,c("rowMedian","anno")] + } +GeneData$anno <- as.factor(GeneData$anno) + ' + } + + if (numberOfScenario == 12) { + stringtosave = '# GeneData now contains the same as res_tmp$SingleEntVis +P_boxplots <- ggplot(GeneData, + aes(y=GeneData[,colnames(GeneData)[-ncol(GeneData)]], + x=anno, + fill=anno))+ + geom_boxplot()+ # unable if less then 4 samples in all groups to get the same plot as in the App + geom_point(shape = 21,size=5)+ + scale_fill_brewer(palette="RdBu")+ + xlab(par_tmp$SingleEntVis$Select_Gene)+ + ylab(par_tmp$SingleEntVis$type_of_data_gene)+ + theme_bw()+ + geom_hline(yintercept = mean(GeneData[,colnames(GeneData)[-ncol(GeneData)]]), linetype = 2)+ # Add horizontal line at base mean + #stat_compare_means(method = "anova")+ # Add global annova p-value + stat_compare_means(comparisons = par_tmp$SingleEntVis$chooseComparisons_list, + method = par_tmp$SingleEntVis$testMethod, + label = "p.signif", + hide.ns = F)' + } + if (numberOfScenario == 13) { + stringtosave = '# GeneData now contains the same as res_tmp$SingleEntVis +P_boxplots <- ggplot(res_tmp$SingleEntVis, + aes(y=res_tmp$SingleEntVis[,colnames(res_tmp$SingleEntVis)[-ncol(res_tmp$SingleEntVis)]], + x=anno, + fill=anno))+ + geom_boxplot()+# unable if less then 4 samples in all groups to get the same plot as in the App + geom_point(shape = 21,size=5)+ + scale_fill_brewer(palette="RdBu")+ + xlab(par_tmp$SingleEntVis$Select_Gene)+ + ylab(par_tmp$SingleEntVis$type_of_data_gene)+ + theme_bw()' + } + stringtosave <- paste0(prequel_stringtosave,"\n",stringtosave,"\n","lapply(ls(pattern='boxplots'), get)") +} + + ## TODO ensure this remains working with new output from Enrichment, needs a potential update! + if(numberOfScenario == 14){ + stringtosave = 'KEGG_Plot_GSE=clusterProfiler::dotplot(EnrichmentRes_Kegg,split=".sign") + + facet_grid(.~.sign)' + } + if(numberOfScenario==15){ + stringtosave = 'KEGG_Plot_ORA=clusterProfiler::dotplot(EnrichmentRes_Kegg)' + } + if(numberOfScenario==16){ + stringtosave='GO_Plot=clusterProfiler::dotplot(EnrichmentRes_GO)' + } + if(numberOfScenario == 17){ + stringtosave='REACTOME_Plot=clusterProfiler::dotplot(EnrichmentRes_RACTOME)' + } + +## Sample Correlation plot ---- + if(numberOfScenario == 18){ + stringtosave <- 'annotationDF <- colData(res_tmp$data)[,par_tmp$SampleCorr$SampleAnnotationChoice,drop = F] +cormat <- cor( + x = as.matrix(assay(res_tmp$data)), + method = par_tmp$SampleCorr$corrMethod +) + +SampleCorrelationPlot <- pheatmap( +mat = cormat, #res_tmp$SampleCorr +annotation_row = par_tmp$SampleCorr$annotationDF, +main = par_tmp$SampleCorr$customTitleSampleCorrelation, +annotation_colors = par_tmp$SampleCorr$anno_colors +)' + } +## Significance Analysis ----- + +if(numberOfScenario >= 20 & numberOfScenario < 24){ + # Calculate all necessary intermediate data sets + prequel_stringtosave <- ' + # Test correction list +PADJUST_METHOD <<- list( + "None" = "none", + "Bonferroni" = "bonferroni", + "Benjamini-Hochberg" = "BH", + "Benjamini Yekutieli" = "BY", + "Holm" = "holm", + "Hommel" = "hommel", + "Hochberg" = "hochberg", + "FDR" = "BH" +) +# get the results +res2plot <- list() + +if(par_tmp$PreProcessing_Procedure == "vst_DESeq"){ + dds <- data$DESeq_obj + + # rewind the comparisons again + newList <- par_tmp$SigAna$comparisons + contrasts <- vector("list", length(par_tmp$SigAna$comparisons)) + for (i in 1:length(newList)) { + contrasts[[i]] <- unlist(strsplit(x = par_tmp$SigAna$comparisons[i],split = ":")) + } + + # get the results for each contrast and put it all in a big results object + sig_results <<- list() + for (i in 1:length(contrasts)) { + if(identical( + list(test_method = "Wald", test_correction = PADJUST_METHOD[[par_tmp$SigAna$test_correction]]), + par_tmp$SigAna[[par_tmp$SigAna$sample_annotation_types_cmp]][[par_tmp$SigAna$comparisons[i]]] + )){ + print("Results exists, skipping calculations.") + sig_results[[par_tmp$SigAna$comparisons[i]]] <<- res_tmp$SigAna[[par_tmp$SigAna$sample_annotation_types_cmp]][[par_tmp$SigAna$comparisons[i]]] + next + } + sig_results[[par_tmp$SigAna$comparisons[i]]] <<- DESeq2::results( + dds, + contrast = c( + par_tmp$SigAna$sample_annotation_types_cmp, + contrasts[[i]][1], + contrasts[[i]][2] + ), + pAdjustMethod = PADJUST_METHOD[[par_tmp$SigAna$test_correction]] + ) + # fill in res_tmp, par_tmp + res_tmp$SigAna[[par_tmp$SigAna$sample_annotation_types_cmp]][[par_tmp$SigAna$comparisons[i]]] <<- sig_results[[par_tmp$SigAna$comparisons[i]]] + par_tmp$SigAna[[par_tmp$SigAna$sample_annotation_types_cmp]][[par_tmp$SigAna$comparisons[i]]] <<- list( + test_method = "Wald", + test_correction = PADJUST_METHOD[[par_tmp$SigAna$test_correction]] + ) + } + }else{ + # all other methods require manual testing + # rewind the comparisons again + newList <- par_tmp$SigAna$comparisons + contrasts <- vector("list", length(par_tmp$SigAna$comparisons)) + contrasts_all <- list() + for (i in 1:length(newList)) { + contrasts[[i]] <- unlist(strsplit(x = par_tmp$SigAna$comparisons[i],split = ":")) + contrasts_all <- append(contrasts_all, contrasts[[i]]) + } + # make all contrasts unique + contrasts_all <- unique(unlist(contrasts_all)) + # name the contrasts with the comparison names + names(contrasts) <- par_tmp$SigAna$comparisons + # get names of columns we want to choose: + index_comparisons <- which( + colData(res_tmp$data)[,par_tmp$SigAna$sample_annotation_types_cmp] %in% contrasts_all + ) + samples_selected <- colData(res_tmp$data)[index_comparisons,] + # get the data + data_selected <- as.matrix(assay(res_tmp$data))[,index_comparisons] + sig_results <- significance_analysis( + df = as.data.frame(data_selected), + samples = as.data.frame(samples_selected), + contrasts = contrasts, + method = par_tmp$SigAna$test_method, + correction = PADJUST_METHOD[[par_tmp$SigAna$test_correction]], + contrast_level = par_tmp$SigAna$sample_annotation_types_cmp + ) + } + + if(any(par_tmp$SigAna$comparisons_to_visualize == "all")){ + # show all comparisons if no more than 4 + if(length(par_tmp$SigAna$comparisons)<5){ + chosenVizSet <- par_tmp$SigAna$comparisons + }else{ + + chosenVizSet <- par_tmp$SigAna$comparisons[c(1,2)] + print("Note: Although you choose all to visualize only first 2 comparisons are shown to avoid unwanted computational overhead, + as you got more than 4 comparisons. Please choose precisely the comparisons for visualisation.") + } + }else{ + chosenVizSet <- par_tmp$SigAna$comparisons_to_visualize + } + for (i in 1:length(chosenVizSet)) { + to_add_tmp <- rownames( + filter_significant_result( + result = sig_results[[chosenVizSet[i]]], + alpha = par_tmp$SigAna$significance_level, + filter_type = par_tmp$SigAna$sig_to_look_at + ) + ) + # only add if the result is not empty + if(length(to_add_tmp) > 0){ + res2plot[[chosenVizSet[i]]] <- to_add_tmp + } + } + # check that you have more than one comparison + if(length(res2plot) <= 1){ + print("You either have no significant results or only significant results in one comparison.") + # if current plots to llok at are adjusted pvalues, suggest to look at raw pvalues + if(par_tmp$SigAna$sig_to_look_at == "Significant"){ + print("You tried to look at adjusted pvalues.\nYou might want to look at raw pvalues (CAUTION!) or change the significance level.") + } + } + + ' + + ### Venn Diagram ---- + if(numberOfScenario == 20){ + stringtosave <- ' + Venn_plot <- ggvenn::ggvenn( + res2plot, + fill_color=c("#44af69", "#f8333c", "#fcab10", "#2b9eb3"), + set_name_size = 3 + ) + ' + } + + ### UpSet Plot ---- + if(numberOfScenario == 21){ + stringtosave <- ' + overlap_list <- prepare_upset_plot(res2plot=res2plot) + Upset_plot <- ComplexUpset::upset( + overlap_list, + colnames(overlap_list), + themes=list(default=theme()) + ) + intersect_names <- ggplot_build( + Upset_plot + )$layout$panel_params[[1]]$x$get_labels() + + # if we want to change the highlighting + if(!is.null(par_tmp$SigAna$intersection_high)){ + querie_names_all <- map_intersects_for_highlight( + highlights=intersect_names, + plot=Upset_plot, + overlap_list=overlap_list + ) + querie_names <- map_intersects_for_highlight( + highlights=par_tmp$SigAna$intersection_high, + plot=Upset_plot, + overlap_list=overlap_list + ) + queries <- vector("list", length(querie_names_all)) + for(i_querie in seq_along(intersect_names)){ + if(intersect_names[[i_querie]] %in% par_tmp$SigAna$intersection_high){ + queries[[i_querie]] <- upset_query( + intersect=colnames(overlap_list)[querie_names_all[[i_querie]]], + color="red", + fill="red" + ) + }else{ + queries[[i_querie]] <- upset_query( + intersect=colnames(overlap_list)[querie_names_all[[i_querie]]], + color="#595959", + fill="#595959" + ) +} +} +Upset_plot <- ComplexUpset::upset( + overlap_list, + colnames(overlap_list), + themes=list(default=theme()), + queries=queries +) +} + + ' + } + + ### Volcano ---- + # option of both unnecessary + if(numberOfScenario >= 22 & numberOfScenario <= 23 ){ + stringtosave_1 <- ' + # plot volcano plot + data4Volcano <- sig_results[[chosenVizSet[i]]] + par_name <- gsub(":","_",chosenVizSet[i]) + data4Volcano$probename <- rownames(data4Volcano) + data4Volcano$threshold <- ifelse(data4Volcano$padj>par_tmp$SigAna[paste0(par_name,"_psig_th")],"non-significant","significant") + data4Volcano$threshold_raw <- ifelse(data4Volcano$pvalue>par_tmp$SigAna[paste0(par_name,"_psig_th")],"non-significant","significant") + data4Volcano$threshold_fc <- ifelse( + data4Volcano$log2FoldChange>par_tmp$SigAna[paste0(par_name,"_lfc_th")], + "up-regulated", + ifelse( + data4Volcano$log2FoldChange<(-1*as.numeric(par_tmp$SigAna[paste0(par_name,"_lfc_th")])), + "down-regulated", " " + ) + ) + data4Volcano$combined <- paste0(data4Volcano$threshold," + ",data4Volcano$threshold_fc) + data4Volcano$combined_raw <- paste0(data4Volcano$threshold_raw," + ",data4Volcano$threshold_fc) + colorScheme2 <- c("#cf0e5bCD", "#0e5bcfCD", "#939596CD","#cf0e5b1A", "#0e5bcf1A", "#9395961A") + names(colorScheme2) <- c( + "significant + up-regulated", "significant + down-regulated", "significant + ", + "non-significant + up-regulated", "non-significant + down-regulated", "non-significant + " + ) + + # remove NA values + data4Volcano <- data4Volcano[complete.cases(data4Volcano),] + + ' + if(numberOfScenario == 22){ + stringtosave_2 <- 'Volcano_plot <- ggplot( + data4Volcano, + aes(label=probename) + ) + + geom_point(aes( + x = log2FoldChange, + y = -log10(padj), + colour = combined + )) + + geom_hline( + yintercept = -1*(log10(as.numeric(par_tmp$SigAna[paste0(par_name,"_psig_th")]))), + color="lightgrey" + ) + + geom_vline( + xintercept = c((-1*as.numeric(par_tmp$SigAna[paste0(par_name,"_lfc_th")])),par_tmp$SigAna[paste0(par_name,"_lfc_th")]), + color="lightgrey" + ) + + scale_color_manual(values=colorScheme2, name="") + + xlab("Log FoldChange") + + ylab("-log10(p_adj-value)") + + theme(legend.position = "none") + + theme_bw()+ + ggtitle(label="Corrected p-Values")' + } + if(numberOfScenario == 23){ + stringtosave_2 <- 'Volcano_plot <- ggplot( + sig_ana_reactive$data4Volcano, + aes(label=probename) + ) + + geom_point(aes( + x = log2FoldChange, + y = -log10(pvalue), + colour = combined_raw)) + + geom_hline( + yintercept = -1*(log10(as.numeric(par_tmp$SigAna[paste0(par_name,"_psig_th")]))), + color="lightgrey" + ) + + geom_vline( + xintercept = c((-1*as.numeric(par_tmp$SigAna[paste0(par_name,"_lfc_th")])),par_tmp$SigAna[paste0(par_name,"_lfc_th")]), + color="lightgrey" + ) + + scale_color_manual(values=colorScheme2, name="") + + xlab("Log FoldChange") + + ylab("-log10(p-value)") + + ggtitle(label="Uncorrected p-Values") + ' + } + stringtosave <- paste0(stringtosave_1,"\n",stringtosave_2) + } + + stringtosave <- paste0(prequel_stringtosave,"\n",stringtosave,"\n","lapply(ls(pattern='plot'), get)") + +} + + +## Enrichment Analysis ---- +if(numberOfScenario >= 14 & numberOfScenario <= 15){ + if(numberOfScenario == 14){ + stringtosave_1 <- ' + # if you want to upload a different set of genes than uploaded to the App + # uncomment the following lines + # you can also manually change the inputs to geneSetChoice + + # Tmp <- read.csv(input$UploadedGeneSet$datapath, header = F) + # # check take first column as a character vector + # geneSetChoice_tmp <- Tmp$V1 + # # Check if they start with "ENS.." + # if(!length(which(grepl("ENS.*",geneSetChoice_tmp) == TRUE)) == length(geneSetChoice_tmp)){ + # print("wrong data!") + # print("Check your input format, should be only gene names ENSMBL-IDs") + # geneSetChoice_tmp <- geneSetChoice + # }else{ + # geneSetChoice <- geneSetChoice_tmp + # } + + geneSetChoice <- par_tmp$Enrichment$tmp_genes + + ' + stringtosave_3 <- ' + if(anno_results$can_start == FALSE){ + tmp_genes <- translate_genes_oa( + annotation_results = anno_results, + input = par_tmp$Enrichment, + geneSetChoice = geneSetChoice, + geneSet2Enrich = par_tmp$Enrichment$GeneSet2Enrich, + data = res_tmp$data) + anno_results$can_start <- TRUE + geneSetChoice <- tmp_genes + } + + enrichment_results <- over_representation_analysis( + par_tmp$Enrichment, + output, + geneSetChoice, + res_tmp$data, + par_tmp$Enrichment$enrichments2do, + par_tmp$Enrichment$test_correction + ) + + ' + + } + + if(numberOfScenario == 15){ + stringtosave_1 <- ' + if(par_tmp$Enrichment$ValueToAttach == "LFC" | input$ValueToAttach == "LFC_abs"){ + + #get LFC + ctrl_samples_idx <- which(colData(res_tmp$data)[,input$sample_annotation_types_cmp_GSEA] %in% input$Groups2Compare_ref_GSEA) + comparison_samples_idx <- which(colData(res_tmp$data)[,input$sample_annotation_types_cmp_GSEA] %in% input$Groups2Compare_treat_GSEA) + + Data2Plot <- getLFCs( + assays(data$data)$raw, + ctrl_samples_idx, + comparison_samples_idx + ) + + Data2Plot_tmp <- Data2Plot + if(input$ValueToAttach == "LFC"){ + geneSetChoice_tmp <- Data2Plot_tmp$LFC + } + else if(input$ValueToAttach == "LFC_abs"){ + geneSetChoice_tmp <- abs(Data2Plot_tmp$LFC) + } + + if(length(geneSetChoice_tmp) < 1){ + print("Nothing significant!") + geneSetChoice_tmp <- NULL + }else{ + names(geneSetChoice_tmp) <- Data2Plot_tmp$probename + } + geneSetChoice <- geneSetChoice_tmp + } + ' + stringtosave_3 <- ' + if(anno_results$can_start == FALSE){ + res_tmp$data <- translate_genes_ea( + data = res_tmp$data, + annotation_results = anno_results, + input = par_tmp$Enrichment + ) + anno_results$can_start <- TRUE + } + enrichment_results <- gene_set_enrichment( + input, + ea_reactives$tmp_genes, + data$data, + ea_reactives$enrichments2do, + input$test_correction, + input$sample_annotation_types_cmp_GSEA, + input$Groups2Compare_ref_GSEA, + input$Groups2Compare_treat_GSEA, + input$ValueToAttach + ) + + ' + } + + + stringtosave_2 <- '# Check whether the necessary annotation is available + anno_results <- check_annotation_enrichment_analysis(res_tmp$data) + res_tmp$data <- anno_results$new_data + + if(anno_results$no_ann){ + print("No valid annotation type was detected in your row annotation. Please indicate the type of annotation with which you uploaded your genes.") + print("Should be one of ENSEMBL, ENTREZID, SYMBOL (was selected within App") + anno_results$base_annotation <- par_tmp$Enrichment$AnnotationSelection + anno_results$can_start = FALSE + + } + ' + + stringtosave_4 <- + 'storageNames <- paste0("EnrichmentRes_",names(res_tmp$OA)) +plot_list <- list() +for(i in storageNames){ + plot_list[[i]] <- clusterProfiler::dotplot(enrichment_results[[i]])+ggtitle(i) +} +' + + + stringtosave <- paste0(stringtosave_1,"\n", + stringtosave_2,"\n", + stringtosave_3,"\n", + stringtosave_4,"\n", + "lapply(ls(pattern='plot'), get)") +} +### Overrepresentation ---- + +### + + + if(numberOfScenario == 0){ + stringtosave <- '# No_code_yet' + } + + return(paste0(CODE_DOWNLOAD_PREFACE, + "\n", + stringSelection, + "\n", + stringPreProcessing, + "\n", + stringtosave)) +} diff --git a/program/shinyApp/R/heatmap/server.R b/program/shinyApp/R/heatmap/server.R index 8a99c1cc..7802789a 100644 --- a/program/shinyApp/R/heatmap/server.R +++ b/program/shinyApp/R/heatmap/server.R @@ -373,6 +373,7 @@ heatmap_server <- function(id, data, params, updates){ output$Options_selected_out_3 <- renderText("Choose another preprocessing, as there are negative values!") }else if(doThis_flag){ + # getLFC is a custom function -> wrap it in a tryCatch tryCatch({ Data2Plot <- getLFC( @@ -385,6 +386,7 @@ heatmap_server <- function(id, data, params, updates){ return(NULL) }) + ## do pheatmap # use floor and ceiling to deal with even/odd length pallettelengths @@ -558,10 +560,18 @@ heatmap_server <- function(id, data, params, updates){ dir.create(temp_directory) write(getPlotCode(heatmap_scenario), file.path(temp_directory, "Code.R")) - - - + saveRDS(envList, file.path(temp_directory, "Data.RDS")) + + # also save entitie Selection function + #TODO + # Needs an extra sourcing to have in correct env - potential fix sourceing module specific functions within module + # instead of sourcing all - or having them all gloablly source (like general utils) + source("R/heatmap/fun_entitieSelection.R") + source("R/fun_LFC.R") + save.function.from.env(wanted = c("entitieSelection","getLFCs"), + file = file.path(temp_directory, "utils.R")) + zip::zip( zipfile = file, files = dir(temp_directory), diff --git a/program/shinyApp/R/pca/server.R b/program/shinyApp/R/pca/server.R index 20a2002c..7fc6bd4b 100644 --- a/program/shinyApp/R/pca/server.R +++ b/program/shinyApp/R/pca/server.R @@ -307,8 +307,9 @@ pca_Server <- function(id, data, params, row_select){ pca_reactives$df_loadings <- df_loadings # assign res_temp - res_tmp[[session$token]][["PCA"]] <<- list(pca) + res_tmp[[session$token]][["PCA"]] <<- pca # assign par_temp as empty list + ## TODO I think this can be removed par_tmp[[session$token]][["PCA"]] <<- list( sample_selection_pca = input$sample_selection_pca, SampleAnnotationTypes_pca = input$SampleAnnotationTypes_pca @@ -465,20 +466,23 @@ pca_Server <- function(id, data, params, row_select){ customTitle <- "PCA" } + tmp <- getUserReactiveValues(input) + par_tmp[[session$token]]$PCA[names(tmp)] <<- tmp + par_tmp[[session$token]]$PCA$colorTheme <<- colorTheme + + output$getR_Code_PCA <- downloadHandler( filename = function(){ paste0("ShinyOmics_Rcode2Reproduce_", Sys.Date(), ".zip") }, content = function(file){ envList <- list( - pcaData = pcaData, - input = reactiveValuesToList(input), - global_ID = pcaData$global_ID, - chosenAnno = pcaData$chosenAnno, - percentVar = percentVar, - customTitle = customTitle, - colorTheme = colorTheme + + res_tmp = res_tmp[[session$token]], + par_tmp = par_tmp[[session$token]] ) + + temp_directory <- file.path(tempdir(), as.integer(Sys.time())) dir.create(temp_directory) write(getPlotCode(PCA_scenario), file.path(temp_directory, "Code.R")) @@ -544,12 +548,20 @@ pca_Server <- function(id, data, params, row_select){ pca_reactives$Scree_customTitle <- "ScreePlot" } + tmp <- getUserReactiveValues(input) + par_tmp[[session$token]]$PCA[names(tmp)] <<- tmp + output$getR_Code_Scree_Plot <- downloadHandler( filename = function(){ paste0("ShinyOmics_Rcode2Reproduce_", Sys.Date(), ".zip") }, content = function(file){ - envList <- list(var_explained_df = var_explained_df) + + envList <- list( + res_tmp = res_tmp[[session$token]], + par_tmp = par_tmp[[session$token]] + ) + temp_directory <- file.path(tempdir(), as.integer(Sys.time())) dir.create(temp_directory) @@ -609,14 +621,19 @@ pca_Server <- function(id, data, params, row_select){ pca_reactives$Loadings_topSlider <- input$topSlider pca_reactives$Loadings_plot <- plotOut + tmp <- getUserReactiveValues(input) + par_tmp[[session$token]]$PCA[names(tmp)] <<- tmp + output$getR_Code_Loadings <- downloadHandler( filename = function(){ paste0("ShinyOmics_Rcode2Reproduce_", Sys.Date(), ".zip") }, content = function(file){ envList <- list( - LoadingsDF = LoadingsDF, - input = reactiveValuesToList(input) + + res_tmp = res_tmp[[session$token]], + par_tmp = par_tmp[[session$token]] + ) temp_directory <- file.path(tempdir(), as.integer(Sys.time())) @@ -678,18 +695,23 @@ pca_Server <- function(id, data, params, row_select){ ) + labs(x = "PCs", y = "entity", fill = "Loading") + theme_bw(base_size = 15) - scenario <- 19 + scenario <- 8.1 #Loading_scenario <- scenario output[["PCA_Loadings_matrix_plot"]] <- renderPlot({LoadingsMatrix}) - + + tmp <- getUserReactiveValues(input) + par_tmp[[session$token]]$PCA[names(tmp)] <<- tmp + output$getR_Code_Loadings_matrix <- downloadHandler( filename = function(){ paste0("ShinyOmics_Rcode2Reproduce_", Sys.Date(), ".zip") }, content = function(file){ envList <- list( - LoadingsDF = df_loadings, - input = reactiveValuesToList(input) + + res_tmp = res_tmp[[session$token]], + par_tmp = par_tmp[[session$token]] + ) temp_directory <- file.path(tempdir(), as.integer(Sys.time())) diff --git a/program/shinyApp/R/sample_correlation/server.R b/program/shinyApp/R/sample_correlation/server.R index a3ee8dc5..39db5396 100644 --- a/program/shinyApp/R/sample_correlation/server.R +++ b/program/shinyApp/R/sample_correlation/server.R @@ -119,14 +119,13 @@ sample_correlation_server <- function(id, data, params){ if(nchar(customTitleSampleCorrelation) >= 250){ customTitleSampleCorrelation <- "SampleCorrelation" } - par_tmp[[session$token]][["SampleCorr"]] <<- list( - customTitleSampleCorrelation = customTitleSampleCorrelation, - SampleCorrelationPlot_final = SampleCorrelationPlot_final, - cormat = cormat, - annotationDF = annotationDF, - anno_colors = anno_colors, - sampleCorrelation_scenario = sampleCorrelation_scenario - ) + + tmp <- getUserReactiveValues(input) + par_tmp[[session$token]]$SampleCorr[names(tmp)] <<- tmp + par_tmp[[session$token]]$SampleCorr$customTitleSampleCorrelation <<- customTitleSampleCorrelation + par_tmp[[session$token]]$SampleCorr$annotationDF <<- as.data.frame(annotationDF) + par_tmp[[session$token]]$SampleCorr$anno_colors <<- anno_colors + } }) @@ -135,16 +134,17 @@ sample_correlation_server <- function(id, data, params){ filename = function(){ paste0("ShinyOmics_Rcode2Reproduce_", Sys.Date(), ".zip")}, content = function(file){ envList <- list( - cormat = ifelse(exists("cormat"),par_tmp[[session$token]][["SampleCorr"]]$cormat,NA), - annotationDF = ifelse(exists("annotationDF"),par_tmp[[session$token]][["SampleCorr"]]$annotationDF,NA), - customTitleSampleCorrelation = ifelse(exists("customTitleSampleCorrelation"),par_tmp[[session$token]][["SampleCorr"]]$customTitleSampleCorrelation,NA), - anno_colors = ifelse(exists("anno_colors"),par_tmp[[session$token]][["SampleCorr"]]$anno_colors,NA) + + res_tmp = res_tmp[[session$token]], + par_tmp = par_tmp[[session$token]] + ) temp_directory <- file.path(tempdir(), as.integer(Sys.time())) dir.create(temp_directory) + sampleCorrelation_scenario <- 18 - write(getPlotCode(par_tmp[[session$token]][["SampleCorr"]]$sampleCorrelation_scenario), file.path(temp_directory, "Code.R")) + write(getPlotCode(sampleCorrelation_scenario), file.path(temp_directory, "Code.R")) saveRDS(envList, file.path(temp_directory, "Data.RDS")) zip::zip( diff --git a/program/shinyApp/R/significance_analysis/server.R b/program/shinyApp/R/significance_analysis/server.R index 8b339808..ab49b096 100644 --- a/program/shinyApp/R/significance_analysis/server.R +++ b/program/shinyApp/R/significance_analysis/server.R @@ -180,6 +180,12 @@ significance_analysis_server <- function(id, data, params){ }) # Analysis initial info observeEvent(input$significanceGo,{ + + # also here to ensure to get sidepanel Inputs + tmp <- getUserReactiveValues(input) + par_tmp[[session$token]]$SigAna[names(tmp)] <<- tmp + # shinyjs::html(id = 'significance_analysis_info', "Analysis is running...") + sig_ana_reactive$info_text <- "Analysis is running..." sig_ana_reactive$start_analysis <- sig_ana_reactive$start_analysis + 1 }) @@ -311,6 +317,7 @@ significance_analysis_server <- function(id, data, params){ input$sig_to_look_at, sig_ana_reactive$update_plot_post_ana > 0 ) + # assign significance_results again, for safety measures sig_results <- res_tmp[[session$token]]$SigAna[[input$sample_annotation_types_cmp]] # assign scenario=20 for Venn Diagram and scenario=21 for UpSetR @@ -319,6 +326,7 @@ significance_analysis_server <- function(id, data, params){ } else { sig_ana_reactive$scenario <- 21 } + # get the results res2plot <- list() # check that you have more than one comparison @@ -462,29 +470,172 @@ significance_analysis_server <- function(id, data, params){ write.csv(tosave, file, row.names = FALSE) } ) + + + output$getR_Code_Volcano <- downloadHandler( + + filename = function(){ + paste0("ShinyOmics_Rcode2Reproduce_", Sys.Date(), ".zip") + }, + content = function(file){ + tmp <- getUserReactiveValues(input) + par_tmp[[session$token]]$SigAna[names(tmp)] <<- tmp + + envList <- list( + res_tmp = res_tmp[[session$token]], + par_tmp = par_tmp[[session$token]] + ) + + if(params$PreProcessing_Procedure == "vst_DESeq"){ + envList$dds <- data$DESeq_obj + } + temp_directory <- file.path(tempdir(), as.integer(Sys.time())) + dir.create(temp_directory) + + write( + getPlotCode(22), + file.path(temp_directory, "Code.R") + ) + saveRDS(envList, file.path(temp_directory, "Data.RDS")) + + #TODO + # Needs an extra sourcing to have in correct env - potential fix sourceing module specific functions within module + # instead of sourcing all - or having them all gloablly source (like general utils) + source("R/significance_analysis/util.R") + source("R/SourceAll.R") + + save.function.from.env(wanted = c("significance_analysis", + "filter_significant_result", + "getLFC", + "map_intersects_for_highlight", + "prepare_upset_plot", + "filter_rna"), + file = file.path(temp_directory, "utils.R")) + zip::zip( + zipfile = file, + files = dir(temp_directory), + root = temp_directory + ) + }, + contentType = "application/zip" + ) + + output$getR_Code_Volcano_raw <- downloadHandler( + + filename = function(){ + paste0("ShinyOmics_Rcode2Reproduce_", Sys.Date(), ".zip") + }, + content = function(file){ + tmp <- getUserReactiveValues(input) + par_tmp[[session$token]]$SigAna[names(tmp)] <<- tmp + + envList <- list( + res_tmp = res_tmp[[session$token]], + par_tmp = par_tmp[[session$token]] + ) + + if(params$PreProcessing_Procedure == "vst_DESeq"){ + envList$dds <- data$DESeq_obj + } + temp_directory <- file.path(tempdir(), as.integer(Sys.time())) + dir.create(temp_directory) + + write( + getPlotCode(23), + file.path(temp_directory, "Code.R") + ) + saveRDS(envList, file.path(temp_directory, "Data.RDS")) + + #TODO + # Needs an extra sourcing to have in correct env - potential fix sourcing module specific functions within module + # instead of sourcing all - or having them all globablly source (like general utils) + source("R/significance_analysis/util.R") + source("R/SourceAll.R") + + save.function.from.env(wanted = c("significance_analysis", + "filter_significant_result", + "getLFC", + "map_intersects_for_highlight", + "prepare_upset_plot", + "filter_rna"), + file = file.path(temp_directory, "utils.R")) + zip::zip( + zipfile = file, + files = dir(temp_directory), + root = temp_directory + ) + }, + contentType = "application/zip" + ) + + # Download and Report Section + # TODO discuss placement! if here visit choices do not get updated + # for now placed in download section to avoid issues # download R Code for further plotting - output$getR_Code <- downloadHandler( + # tmp <- getUserReactiveValues(input) + # par_tmp$SigAna[names(tmp)] <<- tmp + + output$getR_Code_Sig <- downloadHandler( + filename = function(){ paste0("ShinyOmics_Rcode2Reproduce_", Sys.Date(), ".zip") }, content = function(file){ + tmp <- getUserReactiveValues(input) + par_tmp[[session$token]]$SigAna[names(tmp)] <<- tmp + + # assign scenario=20 for Venn Diagram and scenario=21 for UpSetR + if(input$visualization_method == "Venn Diagram"){ + sig_ana_reactive$scenario <- 20 + }else{ + sig_ana_reactive$scenario <- 21 + } + envList <- list( - sig_results = res_tmp[[session$token]]$SigAna[[input$sample_annotation_types_cmp]], - input = reactiveValuesToList(input), - res2plot = sig_ana_reactive$results_for_plot + + res_tmp = res_tmp[[session$token]], + par_tmp = par_tmp[[session$token]] + ) + if(params$PreProcessing_Procedure == "vst_DESeq"){ envList$dds <- data$DESeq_obj } temp_directory <- file.path(tempdir(), as.integer(Sys.time())) dir.create(temp_directory) + write( getPlotCode(sig_ana_reactive$scenario), # 20 for Venn diagram, 21 for UpSetR file.path(temp_directory, "Code.R") ) saveRDS(envList, file.path(temp_directory, "Data.RDS")) + + #TODO + # Needs an extra sourcing to have in correct env - potential fix sourceing module specific functions within module + # instead of sourcing all - or having them all gloablly source (like general utils) + source("R/significance_analysis/util.R") + source("R/SourceAll.R") + + save.function.from.env(wanted = c("significance_analysis", + "filter_significant_result", + "getLFC", + "map_intersects_for_highlight", + "prepare_upset_plot", + "filter_rna"), + # TODO How to handle constants? load into utils? (Issue : all constant not necassarily needed) - two type of constant scripts? + # for ow constant copy pasted into code snippet + + # TODO [Lea] - filter_rna this needs to be always downloaded if IQR chosen for selection. + # Should be added always - Idea: + # upon an Rcode downloade - zip folder created based on selection and preprocessing + # then user prompted choise of possible downloads for further bits + # but this would need to be triggered above modules + # or once hit after preprocessing temp folder created with first bit then added + # depending on analyses down - pop up based what is present in res_tmp (for this scenarios should be added to par_tmp!) + file = file.path(temp_directory, "utils.R")) + zip::zip( zipfile = file, files = dir(temp_directory), diff --git a/program/shinyApp/R/significance_analysis/util.R b/program/shinyApp/R/significance_analysis/util.R index d515b937..f7a4014f 100644 --- a/program/shinyApp/R/significance_analysis/util.R +++ b/program/shinyApp/R/significance_analysis/util.R @@ -127,11 +127,12 @@ create_new_tab_manual <- function(title, targetPanel, result, contrast, alpha, n label = "Get underlying R code and data", icon = icon("code") ), - downloadButton( - outputId = ns("getR_Code_Volcano_both"), - label = "Get underlying R code and data", - icon = icon("code") - ), + NULL, + # downloadButton( + # outputId = ns("getR_Code_Volcano_both"), + # label = "Get underlying R code and data", + # icon = icon("code") + # ), downloadButton( outputId = ns("getR_Code_Volcano_raw"), label = "Get underlying R code and data", diff --git a/program/shinyApp/R/single_gene_visualisation/server.R b/program/shinyApp/R/single_gene_visualisation/server.R index 7561316d..d0eb3146 100644 --- a/program/shinyApp/R/single_gene_visualisation/server.R +++ b/program/shinyApp/R/single_gene_visualisation/server.R @@ -3,6 +3,7 @@ single_gene_visualisation_server <- function(id, data){ id, function(input,output,session){ ns <- session$ns + # Refresh UI /Data observeEvent(input$refreshUI,{ print("Refresh UI Single Gene") @@ -225,14 +226,18 @@ single_gene_visualisation_server <- function(id, data){ } # Where to save the plot (needed currently to be global, to be able to be saved) res_tmp[[session$token]][["SingleEntVis"]] <<- P_boxplots - par_tmp[[session$token]][["SingleEntVis"]] <<- list( - SingleEnt_customTitle_boxplot = SingleEnt_customTitle_boxplot, - SingleEnt_Select_Gene = input$Select_Gene, - SingleEnt_type_of_data_gene = input$type_of_data_gene, - SingleEnt_accross_condition = input$accross_condition, - SingleEnt_testMethod = testMethod, - SingleEnt_GeneData_anno = GeneData$anno - ) + + #SingleEnt_P_boxplots <- P_boxplots + # TODO: Needs to be trimmed down + tmp <- getUserReactiveValues(input) + par_tmp[[session$token]]$SingleEntVis[names(tmp)] <<- tmp + + par_tmp[[session$token]][["SingleEntVis"]]$SingleEnt_customTitle_boxplot <<- SingleEnt_customTitle_boxplot + par_tmp[[session$token]][["SingleEntVis"]]$testMethod <<- testMethod + par_tmp[[session$token]][["SingleEntVis"]]$chooseComparisons_list <<- xy.list + }else{ + customTitle_boxplot <- "NoBoxplot" + } output$getR_Code_SingleEntities <- downloadHandler( @@ -241,13 +246,12 @@ single_gene_visualisation_server <- function(id, data){ }, content = function(file){ envList <- list( - GeneData = GeneData, - xy.list=ifelse(exists("xy.list"),xy.list,NA), - testMethod=ifelse(exists("testMethod"),testMethod,NA), - input=reactiveValuesToList(input), - myBreaks=ifelse(exists("myBreaks"),myBreaks,NA), - myColor_fill=ifelse(exists("myColor_fill"),myColor_fill,NA) - ) + + res_tmp = res_tmp[[session$token]], + par_tmp = par_tmp[[session$token]] + ) + + temp_directory <- file.path(tempdir(), as.integer(Sys.time())) dir.create(temp_directory) write(getPlotCode(boxplot_scenario), file.path(temp_directory, "Code.R")) diff --git a/program/shinyApp/R/util.R b/program/shinyApp/R/util.R index 64c38bad..d56817e7 100644 --- a/program/shinyApp/R/util.R +++ b/program/shinyApp/R/util.R @@ -91,6 +91,39 @@ getUserReactiveValues <- function(data = input){ } +save.function.from.env <- function(wanted,file="utils.R") +{ + # This function will go through all your defined functions + # and find wanted function + funs <- Filter(is.function, sapply(ls( ".GlobalEnv"), get)) + funs <- funs[names(funs) %in% wanted] + + # Let's + for(i in seq_along(funs)) + { + cat( # number the function we are about to add + paste("\n" , "#------ Function number ", i , "-----------------------------------" ,"\n"), + append = T, file = file + ) + cat( # print the function into the file + paste(names(funs)[i] , "<-", paste(capture.output(funs[[i]]), collapse = "\n"), collapse = "\n"), + append = T, file = file + ) + cat( + paste("\n" , "#-----------------------------------------" ,"\n"), + append = T, file = file + ) + } + cat( # writing at the end of the file how many new functions where added to it + paste("# A total of ", length(funs), " Functions where written into utils"), + append = T, file = file + ) + print(paste("A total of ", length(funs), " Functions where written into utils")) +} + + + + save_pheatmap <- function(x, filename,type = "pdf") { # Saves a heatmap to a file in different formats stopifnot(!missing(x)) @@ -164,3 +197,4 @@ detect_annotation <- function(data) { AnnoCol = NULL )) } + diff --git a/program/shinyApp/server.R b/program/shinyApp/server.R index efed60b9..23046ead 100644 --- a/program/shinyApp/server.R +++ b/program/shinyApp/server.R @@ -732,6 +732,11 @@ server <- function(input,output,session){ selectedData <- reactive({ shiny::req(input$row_selection, input$sample_selection) par_tmp[[session$token]][["row_selection"]] <<- input$row_selection + + par_tmp[[session$token]][["sample_selection"]] <<- input$sample_selection + par_tmp[[session$token]][["providedRowAnnotationTypes"]] <<- input$providedRowAnnotationTypes + print("Alright do Row selection") + selected <- c() if(any(input$row_selection == "all")){ @@ -971,7 +976,6 @@ server <- function(input,output,session){ data = res_tmp[[session$token]] ) - # Enrichment Analysis ---- enrichment_analysis_Server( id = 'EnrichmentAnalysis', diff --git a/program/shinyApp/www/Report.md b/program/shinyApp/www/Report.md new file mode 100644 index 00000000..0f617c0b --- /dev/null +++ b/program/shinyApp/www/Report.md @@ -0,0 +1,7 @@ +**DataInput** - Uploaded Omic Type: Lipidomics + +**DataInput** - The used data was precompiled. Filename: + SHINY_LipidObsesityWTonly_precompiled 2022-06-27.rds + +**DataInput** - The raw data dimensions are:502, 42 +