diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/qs/compound_db.qs b/V2.1/ODA/MetaboAnalyst_3.0.3/qs/compound_db.qs
deleted file mode 100644
index 21b880d7bd04e101d01a9527d18079a5550b8220..0000000000000000000000000000000000000000
Binary files a/V2.1/ODA/MetaboAnalyst_3.0.3/qs/compound_db.qs and /dev/null differ
diff --git a/V2.1/CRI_HMDB_KEGG_IDs.xlsx b/V2.2/CRI_HMDB_KEGG_IDs.xlsx
similarity index 100%
rename from V2.1/CRI_HMDB_KEGG_IDs.xlsx
rename to V2.2/CRI_HMDB_KEGG_IDs.xlsx
diff --git a/V2.2/ODA/MetaboAnalyst.R b/V2.2/ODA/MetaboAnalyst.R
new file mode 100644
index 0000000000000000000000000000000000000000..a6cad73eac7de31aaa8320939c72569b7ec12705
--- /dev/null
+++ b/V2.2/ODA/MetaboAnalyst.R
@@ -0,0 +1,302 @@
+#Requires: qs, RcppParallel.
+initial.options=commandArgs(trailingOnly=F)
+scriptPath=file.path(dirname(sub("--file=","",initial.options[grep("--file=",initial.options)])))
+if (length(scriptPath)==0)
+ scriptPath='.'
+scriptPath=normalizePath(scriptPath)
+source(file.path(scriptPath,'constants.R'))
+scriptPath<<-file.path(scriptPath,METABOANALYST)
+source(file.path(scriptPath,'general_data_utils.R'))
+source(file.path(scriptPath,'general_lib_utils.R'))
+source(file.path(scriptPath,'general_misc_utils.R'))
+source(file.path(scriptPath,'general_proc_utils.R'))
+source(file.path(scriptPath,'general_norm_utils.R'))
+source(file.path(scriptPath,'general_anot_utils.R'))
+source(file.path(scriptPath,'enrich_name_match.R'))
+source(file.path(scriptPath,'enrich_mset.R'))
+source(file.path(scriptPath,'enrich_stats.R'))
+source(file.path(scriptPath,'enrich_graphics.R'))
+source(file.path(scriptPath,'enrich_integ.R'))
+source(file.path(scriptPath,'enrich_path_stats.R'))
+source(file.path(scriptPath,'enrich_path_graphics.R'))
+#############################Begin linkQS()#############################
+linkQS=function(sourcePath,destPath,dbType,lipid=F,libOpt=NULL,species=NULL) {
+ file.symlink(file.path(sourcePath,'qs','compound_db.qs'),destPath)
+ file.symlink(file.path(sourcePath,'qs','master_compound_db.qs'),destPath)
+ if (!is.null(libOpt)&&!is.null(species))
+ file.symlink(file.path(sourcePath,'qs',libOpt,paste0(species,'.qs')),destPath)
+ if (dbType!='customized')
+ file.symlink(file.path(sourcePath,'qs',paste0(dbType,'.qs')),destPath)
+ if (lipid) {
+ file.symlink(file.path(sourcePath,'qs','lipid','lipid_compound_db.qs'),destPath)
+ file.symlink(file.path(sourcePath,'qs','lipid','lipid_syn_nms.qs'),destPath)
+ }
+}
+#############################End linkQS()#############################
+
+#############################Begin MSEA_ORA()#############################
+MSEA_ORA=function(filePrefix,ids,refIDs=NULL,idType='hmdb',dbType='kegg_pathway',minSetSize=5,lipid=F,eaFile=NA) {
+#idType: hmdb|kegg|name
+#dbType: smpdb_pathway|kegg_pathway|drug|blood|urine|csf|fecal|super_class|main_class|sub_class|snp|predicted|location for metabolites and super_class|main_class|sub_class|snp for lipids. If none of these, dbType should be customized.
+message('##########Begin MSEA-ORA Analysis by MetaboAnalyst.##########')
+ wd=getwd()
+ tryCatch({
+ setwd(dirname(filePrefix))
+ filePrefix=basename(filePrefix)
+ linkQS(scriptPath,'.',dbType,lipid)
+ mSet=InitDataObjects1("conc", "msetora", FALSE)
+ mSet=Setup.MapData1(mSet, ids);
+ mSet=CrossReferencing1(mSet, idType, lipid=lipid);
+ mSet=CreateMappingResultTable1(mSet)
+ if (!is.null(refIDs)) {
+ if (names(refIDs)=='hmdb')
+ mSet=Setup.HMDBReferenceMetabolome1(mSet, NULL, refIDs, T)
+ if (names(refIDs)=='name')
+ mSet=Setup.HMDBReferenceMetabolome1(mSet, NULL, refIDs, F)
+ if (names(refIDs)=='kegg')
+ mSet=Setup.KEGGReferenceMetabolome1(mSet,NULL,refIDs)
+ print(paste0('Metabolites filtered using the reference metabolome. ID type: ',names(refIDs)))
+ }
+ if (dbType=='customized'&&!is.null(eaFile)&&!is.na(eaFile)) {
+ mSet=Setup.UserMsetLibData1(mSet,eaFile,idType)
+ }
+ mSet=SetMetabolomeFilter1(mSet, !is.null(refIDs));
+ mSet=SetCurrentMsetLib1(mSet, dbType, minSetSize);
+ mSet=CalculateHyperScore1(mSet)
+ if (!is.null(mSet)) {
+ options(warn=-1) #Otherwise when srunning this code on a BioHPC node too many X11 font warnings will stop the program.
+ mSet=PlotORA1(mSet, paste0(filePrefix,'_barplot_'), "net", "pdf", width=NA)
+ mSet=PlotEnrichDotPlot1(mSet, "ora", paste0(filePrefix,'_dotplot_'), "pdf", width=NA)
+ if (dbType %in% VALID_OPTIONS$metabolomics$eaDB_lipid[2:4]) {
+ mSet=PlotEnrichPieChart1(mSet, "ora", paste0(filePrefix,'_piechart_'), "pdf")
+ }
+ options(warn=0)
+}
+ unlink('*.qs')
+ }, error=function(cond) {message('MSEA_ORA error! Check your parameter setting, feature list and customized feature set file (if any). See below for details. If everything looks correct, it is possible that no enrichment result is found by MSEA.'); message(paste0(cond,'\n')); unlink('*.qs')})
+ setwd(wd)
+message('##########End MSEA-ORA Analysis.##########')
+}
+#############################End MSEA_ORA()#############################
+
+#############################Begin MSEA_QEA()#############################
+MSEA_QEA=function(filePrefix,dataFile,refIDs=NULL,idType='hmdb',dbType='kegg_pathway',minSetSize=5,lipid=F,eaFile=NA) {
+#idType: hmdb|kegg|name
+#dbType: smpdb_pathway|kegg_pathway|drug|blood|urine|csf|fecal|super_class|main_class|sub_class|snp|predicted|location for metabolites and super_class|main_class|sub_class|snp for lipids. If none of these, dbType should be customized.
+message('##########Begin MSEA-QEA Analysis by MetaboAnalyst.##########')
+ if (!is.null(dataFile)&&!is.na(dataFile))
+ dataFile=normalizePath(dataFile)
+ else
+ stop('QEA data file is empty!')
+ if (!is.null(eaFile)&&!is.na(eaFile))
+ eaFile=normalizePath(eaFile)
+ wd=getwd()
+ tryCatch({
+ setwd(dirname(filePrefix))
+ filePrefix=basename(filePrefix)
+ linkQS(scriptPath,'.',dbType,lipid)
+ mSet=InitDataObjects1("conc", "msetqea", FALSE)
+ mSet=Read.TextData1(mSet, dataFile, "colu", "disc");
+ mSet=SanityCheckData1(mSet)
+ mSet=ContainMissing1(mSet)
+ mSet=ReplaceMin1(mSet);
+ mSet=CrossReferencing1(mSet, idType, lipid=lipid);
+ mSet=CreateMappingResultTable1(mSet);
+ mSet=PreparePrenormData1(mSet)
+ mSet=Normalization1(mSet, "NULL", "NULL", "NULL", ratio=FALSE, ratioNum=20)
+ #mSet=PlotNormSummary(mSet, "norm_0_", "png", 72, width=NA)
+ #mSet=PlotSampleNormSummary(mSet, "snorm_0_", "png", 72, width=NA)
+ if (!is.null(refIDs)) {
+ if (names(refIDs)=='hmdb')
+ mSet=Setup.HMDBReferenceMetabolome1(mSet, NULL, refIDs, T)
+ if (names(refIDs)=='name')
+ mSet=Setup.HMDBReferenceMetabolome1(mSet, NULL, refIDs, F)
+ if (names(refIDs)=='kegg')
+ mSet=Setup.KEGGReferenceMetabolome1(mSet,NULL,refIDs)
+ print(paste0('Metabolites filtered using the reference metabolome. ID type: ',names(refIDs)))
+ }
+ if (dbType=='customized'&&!is.null(eaFile)&&!is.na(eaFile)) {
+ mSet=Setup.UserMsetLibData1(mSet,eaFile,idType)
+ }
+ mSet=SetMetabolomeFilter1(mSet, !is.null(refIDs));
+ mSet=SetCurrentMsetLib1(mSet, dbType, minSetSize);
+ mSet=CalculateGlobalTestScore1(mSet)
+ options(warn=-1) #Otherwise when srunning this code on a BioHPC node too many X11 font warnings will stop the program.
+ mSet=PlotQEA.Overview1(mSet, paste0(filePrefix,'_barplot_'), "net", "pdf", width=NA)
+ mSet=PlotEnrichDotPlot1(mSet, "qea", paste0(filePrefix,'_dotplot_'), "pdf", width=NA)
+ if (dbType %in% VALID_OPTIONS$metabolomics$eaDB_lipid[2:4]) {
+ mSet=PlotEnrichPieChart1(mSet, "qea", paste0(filePrefix,'_piechart_'), "pdf")
+ }
+ options(warn=0)
+ unlink('*.qs')
+ }, error=function(cond) {message('MSEA_QEA error! Check your parameter setting, differential test input/output and customized feature set file (if any). See below for details. If everything looks correct, it is possible that no enrichment result is found by MSEA.'); message(paste0(cond,'\n')); unlink('*.qs')})
+ setwd(wd)
+message('##########End MSEA-QEA Analysis.##########')
+}
+#############################End MSEA_QEA()#############################
+
+#############################Begin MSPA_ORA()#############################
+MSPA_ORA=function(filePrefix,ids,refIDs=NULL,idType='hmdb',dbType='kegg_pathway',species='mouse',eaFile=NA) {
+#idType: hmdb|kegg|name
+#dbType: smpdb_pathway|kegg_pathway
+#species: mouse|human #Will be converted to mmu|hsa.
+message('##########Begin MSPA-ORA Analysis by MetaboAnalyst.##########')
+ if (!(dbType %in% c('kegg_pathway','smpdb_pathway')))
+ stop('eaDB must be KEGG or SMPDB pathway.')
+ wd=getwd()
+ tryCatch({
+ setwd(dirname(filePrefix))
+ filePrefix=basename(filePrefix)
+ species=ifelse(species=="human","hsa","mmu")
+ linkQS(scriptPath,'.',dbType,lipid=F,libOpt=file.path('metpa',unlist(strsplit(dbType,'_'))[1]),species=species)
+ mSet=InitDataObjects1("conc", "pathora", FALSE)
+ mSet=SetOrganism(mSet, species)
+ mSet=Setup.MapData1(mSet, ids);
+ mSet=CrossReferencing1(mSet, idType);
+ mSet=CreateMappingResultTable1(mSet)
+ if (!is.null(refIDs)) {
+ if (names(refIDs)=='hmdb')
+ mSet=Setup.HMDBReferenceMetabolome1(mSet, NULL, refIDs, T)
+ if (names(refIDs)=='name')
+ mSet=Setup.HMDBReferenceMetabolome1(mSet, NULL, refIDs, F)
+ if (names(refIDs)=='kegg')
+ mSet=Setup.KEGGReferenceMetabolome1(mSet,NULL,refIDs)
+ print(paste0('Metabolites filtered using the reference metabolome. ID type: ',names(refIDs)))
+ }
+ if (dbType=='kegg_pathway') {
+ mSet=SetKEGG.PathLib1(mSet, species, "current")
+ } else {
+ mSet=SetSMPDB.PathLib(mSet, species)
+ }
+ mSet=SetMetabolomeFilter1(mSet, !is.null(refIDs));
+ mSet=CalculateOraScore1(mSet, "rbc", "hyperg")
+ options(warn=-1) #Otherwise when srunning this code on a BioHPC node too many X11 font warnings will stop the program.
+ mSet=PlotPathSummary1(mSet, F, paste0(filePrefix,'_path_view_'), "pdf", 72, width=NA,labeling=T)
+ pathways=GetORA.pathNames(mSet)
+ if (dbType=='kegg_pathway') {
+ dir.create('Pathways')
+ setwd('Pathways')
+ for (i in 1:min(25,length(pathways))) {
+# PlotKEGGPath1(mSet,pathways[i],528,480,"png",NULL)
+ PlotKEGGPath1(mSet,pathways[i],format='pdf',dpi=72)
+ }
+ setwd('..')
+ }
+ options(warn=0)
+ unlink('*.qs')
+ }, error=function(cond) {message('MSPA_ORA error! Check your parameter setting, feature list and customized feature set file (if any). See below for details. If everything looks correct, it is possible that no enrichment result is found by MSPA.'); message(paste0(cond,'\n')); unlink('*.qs')})
+ setwd(wd)
+message('##########End MSPA-ORA Analysis.##########')
+}
+#############################End MSPA_ORA()#############################
+
+#############################TBD Begin MSPA_QEA()#############################
+MSPA_QEA=function(filePrefix,dataFile,refIDs=NULL,idType='hmdb',dbType='kegg_pathway',species='mouse',eaFile=NA) {
+#idType: hmdb|kegg|name
+#dbType: smpdb_pathway|kegg_pathway
+#species: mouse|human #Will be converted to mmu|hsa.
+message('##########Begin MSPA-QEA Analysis by MetaboAnalyst.##########')
+if (!(dbType %in% c('kegg_pathway','smpdb_pathway')))
+ stop('eaDB must be KEGG or SMPDB pathway.')
+ if (!is.null(dataFile)&&!is.na(dataFile))
+ dataFile=normalizePath(dataFile)
+ else
+ stop('QEA data file is empty!')
+ if (!is.null(eaFile)&&!is.na(eaFile))
+ eaFile=normalizePath(eaFile)
+ wd=getwd()
+ tryCatch({
+ setwd(dirname(filePrefix))
+ filePrefix=basename(filePrefix)
+ species=ifelse(species=="human","hsa","mmu")
+ linkQS(scriptPath,'.',dbType,lipid=F,libOpt=file.path('metpa',unlist(strsplit(dbType,'_'))[1]),species=species)
+ mSet=InitDataObjects1("conc", "pathqea", FALSE)
+ mSet=Read.TextData1(mSet, dataFile, "colu", "disc");
+ mSet=SanityCheckData1(mSet)
+ mSet=ContainMissing1(mSet)
+ mSet=ReplaceMin1(mSet);
+ mSet=CrossReferencing1(mSet, idType);
+ mSet=CreateMappingResultTable1(mSet);
+ mSet=PreparePrenormData1(mSet)
+ mSet=Normalization1(mSet, "NULL", "NULL", "NULL", ratio=FALSE, ratioNum=20)
+ #mSet=PlotNormSummary(mSet, "norm_0_", "png", 72, width=NA)
+ #mSet=PlotSampleNormSummary(mSet, "snorm_0_", "png", 72, width=NA)
+ if (!is.null(refIDs)) {
+ if (names(refIDs)=='hmdb')
+ mSet=Setup.HMDBReferenceMetabolome1(mSet, NULL, refIDs, T)
+ if (names(refIDs)=='name')
+ mSet=Setup.HMDBReferenceMetabolome1(mSet, NULL, refIDs, F)
+ if (names(refIDs)=='kegg')
+ mSet=Setup.KEGGReferenceMetabolome1(mSet,NULL,refIDs)
+ print(paste0('Metabolites filtered using the reference metabolome. ID type: ',names(refIDs)))
+ }
+ if (dbType=='kegg_pathway') {
+ mSet=SetKEGG.PathLib1(mSet, species, "current")
+ } else {
+ mSet=SetSMPDB.PathLib(mSet, species)
+ }
+ mSet=SetMetabolomeFilter1(mSet, !is.null(refIDs));
+ mSet=CalculateQeaScore1(mSet, "rbc", "gt");
+ options(warn=-1) #Otherwise when srunning this code on a BioHPC node too many X11 font warnings will stop the program.
+ mSet=PlotPathSummary1(mSet, F, paste0(filePrefix,'_path_view_'), "pdf", 72, width=NA,labeling=T)
+ pathways=GetQEA.pathNames(mSet)
+ if (dbType=='kegg_pathway') {
+ dir.create('Pathways')
+ setwd('Pathways')
+ for (i in 1:min(25,length(pathways))) {
+# PlotKEGGPath1(mSet,pathways[i],528,480,"png",NULL)
+ PlotKEGGPath1(mSet,pathways[i],format='pdf',dpi=72)
+ }
+ setwd('..')
+ }
+ options(warn=0)
+ unlink('*.qs')
+ }, error=function(cond) {message('MSPA_QEA error! Check your parameter setting, differential test input/output and customized feature set file (if any). See below for details. If everything looks correct, it is possible that no enrichment result is found by MSPA.'); message(paste0(cond,'\n')); unlink('*.qs')})
+ setwd(wd)
+message('##########End MSPA-QEA Analysis.##########')
+}
+#############################End MSPA_QEA()#############################
+
+#############################Begin MetaboAnalyst_JointPA()#############################
+MetaboAnalyst_JointPA=function(filePrefix,metaboliteIDs,geneIDs,metaboliteIDType='hmdb',geneIDType='symbol',species='mouse',option='metab_integ') {
+#Metabolite idType: hmdb|kegg|name
+#Gene idType: entrez|symbol|uniprot
+#species: mouse|human #Will be converted to mmu|hsa.
+#option: metab_integ|all_integ|metab_metab|all_genetic
+message('##########Begin JointPA Analysis by MetaboAnalyst.##########')
+ wd=getwd()
+ tryCatch({
+ setwd(dirname(filePrefix))
+ filePrefix=basename(filePrefix)
+ option=unlist(strsplit(option,'_'))
+ species=ifelse(species=="human","hsa","mmu")
+ linkQS(scriptPath,'.','kegg_pathway',lipid=F,libOpt=option[1],species=species)
+ mSet=InitDataObjects1("conc", "pathinteg", FALSE)
+ mSet=SetOrganism(mSet, species)
+ url.pre<<-file.path(scriptPath,'sqlite')
+ if (!is.null(metaboliteIDs))
+ mSet=PerformIntegCmpdMapping1(mSet, metaboliteIDs, species, metaboliteIDType)
+ if (!is.null(geneIDs))
+ mSet=PerformIntegGeneMapping1(mSet, geneIDs, species, geneIDType)
+ mSet=PrepareIntegData(mSet)
+ mSet=PerformIntegPathwayAnalysis1(mSet, "dc", "hyper", "current", option[2], "query") #These are default settings. Topology can be dc|bc|cc. Test can be hyper|fisher. Analysis can be integ|metab|genetic. Integration can be query|pvalu|pvalo|pvalp.
+# mSet=CreateIntegMatchingTable1(mSet) #This has been called by PerformIntegPathwayAnalysis1.
+ mSet=PlotPathSummary1(mSet, F, paste0(filePrefix,'_path_view_'), "pdf", 72, width=NA,labeling=T)
+ pathways=mSet$dataSet$path.mat[,'Name']
+ dir.create('Pathways')
+ setwd('Pathways')
+ file.rename(file.path('..','pathinteg.impTopo.qs'),'pathinteg.impTopo.qs')
+ for (i in 1:min(25,length(pathways))) {
+# PlotKEGGPath1(mSet,pathways[i],528,480,"png",NULL)
+ PlotKEGGPath1(mSet,pathways[i],format='pdf',dpi=72)
+ }
+ unlink('*.qs')
+ setwd('..')
+ options(warn=0)
+ unlink('*.qs')
+ }, error=function(cond) {message('JointPA error! Check your parameter setting and feature list. See below for details. If everything looks correct, it is possible that no result is found by JointPA of MetaboAnalyst.'); message(paste0(cond,'\n')); unlink('*.qs');})
+ setwd(wd)
+message('##########End JointPA Analysis.##########')
+}
+#############################End MetaboAnalyst_JointPA()#############################
+
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/All_generic_utils.R b/V2.2/ODA/MetaboAnalyst_3.0.3/All_generic_utils.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/All_generic_utils.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/All_generic_utils.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/batch_effect_utils.R b/V2.2/ODA/MetaboAnalyst_3.0.3/batch_effect_utils.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/batch_effect_utils.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/batch_effect_utils.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/biomarker_utils.R b/V2.2/ODA/MetaboAnalyst_3.0.3/biomarker_utils.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/biomarker_utils.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/biomarker_utils.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/data_trimming.R b/V2.2/ODA/MetaboAnalyst_3.0.3/data_trimming.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/data_trimming.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/data_trimming.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/dependencies_function_imported.R b/V2.2/ODA/MetaboAnalyst_3.0.3/dependencies_function_imported.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/dependencies_function_imported.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/dependencies_function_imported.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/enrich_graphics.R b/V2.2/ODA/MetaboAnalyst_3.0.3/enrich_graphics.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/enrich_graphics.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/enrich_graphics.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/enrich_integ.R b/V2.2/ODA/MetaboAnalyst_3.0.3/enrich_integ.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/enrich_integ.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/enrich_integ.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/enrich_mset.R b/V2.2/ODA/MetaboAnalyst_3.0.3/enrich_mset.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/enrich_mset.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/enrich_mset.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/enrich_name_match.R b/V2.2/ODA/MetaboAnalyst_3.0.3/enrich_name_match.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/enrich_name_match.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/enrich_name_match.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/enrich_path_graphics.R b/V2.2/ODA/MetaboAnalyst_3.0.3/enrich_path_graphics.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/enrich_path_graphics.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/enrich_path_graphics.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/enrich_path_stats.R b/V2.2/ODA/MetaboAnalyst_3.0.3/enrich_path_stats.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/enrich_path_stats.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/enrich_path_stats.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/enrich_stats.R b/V2.2/ODA/MetaboAnalyst_3.0.3/enrich_stats.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/enrich_stats.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/enrich_stats.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/gene_fun_utils.R b/V2.2/ODA/MetaboAnalyst_3.0.3/gene_fun_utils.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/gene_fun_utils.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/gene_fun_utils.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/general_anot_utils.R b/V2.2/ODA/MetaboAnalyst_3.0.3/general_anot_utils.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/general_anot_utils.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/general_anot_utils.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/general_data_utils.R b/V2.2/ODA/MetaboAnalyst_3.0.3/general_data_utils.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/general_data_utils.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/general_data_utils.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/general_lib_utils.R b/V2.2/ODA/MetaboAnalyst_3.0.3/general_lib_utils.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/general_lib_utils.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/general_lib_utils.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/general_load_libs.R b/V2.2/ODA/MetaboAnalyst_3.0.3/general_load_libs.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/general_load_libs.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/general_load_libs.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/general_misc_utils.R b/V2.2/ODA/MetaboAnalyst_3.0.3/general_misc_utils.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/general_misc_utils.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/general_misc_utils.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/general_norm_utils.R b/V2.2/ODA/MetaboAnalyst_3.0.3/general_norm_utils.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/general_norm_utils.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/general_norm_utils.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/general_proc_utils.R b/V2.2/ODA/MetaboAnalyst_3.0.3/general_proc_utils.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/general_proc_utils.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/general_proc_utils.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/generic_c_utils.R b/V2.2/ODA/MetaboAnalyst_3.0.3/generic_c_utils.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/generic_c_utils.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/generic_c_utils.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/meta_data_utils.R b/V2.2/ODA/MetaboAnalyst_3.0.3/meta_data_utils.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/meta_data_utils.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/meta_data_utils.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/meta_methods.R b/V2.2/ODA/MetaboAnalyst_3.0.3/meta_methods.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/meta_methods.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/meta_methods.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/meta_pathway.R b/V2.2/ODA/MetaboAnalyst_3.0.3/meta_pathway.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/meta_pathway.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/meta_pathway.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/misc_effect_size_functions.R b/V2.2/ODA/MetaboAnalyst_3.0.3/misc_effect_size_functions.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/misc_effect_size_functions.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/misc_effect_size_functions.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/networks_data.R b/V2.2/ODA/MetaboAnalyst_3.0.3/networks_data.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/networks_data.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/networks_data.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/networks_enrich.R b/V2.2/ODA/MetaboAnalyst_3.0.3/networks_enrich.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/networks_enrich.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/networks_enrich.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/networks_view.R b/V2.2/ODA/MetaboAnalyst_3.0.3/networks_view.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/networks_view.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/networks_view.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/others_lipomics.R b/V2.2/ODA/MetaboAnalyst_3.0.3/others_lipomics.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/others_lipomics.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/others_lipomics.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/parameters_db.R b/V2.2/ODA/MetaboAnalyst_3.0.3/parameters_db.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/parameters_db.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/parameters_db.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/parameters_optimization.R b/V2.2/ODA/MetaboAnalyst_3.0.3/parameters_optimization.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/parameters_optimization.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/parameters_optimization.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/peak_utils.R b/V2.2/ODA/MetaboAnalyst_3.0.3/peak_utils.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/peak_utils.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/peak_utils.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/peaks_to_function.R b/V2.2/ODA/MetaboAnalyst_3.0.3/peaks_to_function.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/peaks_to_function.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/peaks_to_function.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/power_utils.R b/V2.2/ODA/MetaboAnalyst_3.0.3/power_utils.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/power_utils.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/power_utils.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/preproc_utils.R b/V2.2/ODA/MetaboAnalyst_3.0.3/preproc_utils.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/preproc_utils.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/preproc_utils.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/project_sharing_utils.R b/V2.2/ODA/MetaboAnalyst_3.0.3/project_sharing_utils.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/project_sharing_utils.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/project_sharing_utils.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/qs/all/hsa.qs b/V2.2/ODA/MetaboAnalyst_3.0.3/qs/all/hsa.qs
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/qs/all/hsa.qs
rename to V2.2/ODA/MetaboAnalyst_3.0.3/qs/all/hsa.qs
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/qs/all/mmu.qs b/V2.2/ODA/MetaboAnalyst_3.0.3/qs/all/mmu.qs
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/qs/all/mmu.qs
rename to V2.2/ODA/MetaboAnalyst_3.0.3/qs/all/mmu.qs
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/qs/blood.qs b/V2.2/ODA/MetaboAnalyst_3.0.3/qs/blood.qs
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/qs/blood.qs
rename to V2.2/ODA/MetaboAnalyst_3.0.3/qs/blood.qs
diff --git a/V2.2/ODA/MetaboAnalyst_3.0.3/qs/compound_db.qs b/V2.2/ODA/MetaboAnalyst_3.0.3/qs/compound_db.qs
new file mode 100644
index 0000000000000000000000000000000000000000..1a7f8c150149e3b574db94a5569a36aeba437045
Binary files /dev/null and b/V2.2/ODA/MetaboAnalyst_3.0.3/qs/compound_db.qs differ
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/qs/csf.qs b/V2.2/ODA/MetaboAnalyst_3.0.3/qs/csf.qs
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/qs/csf.qs
rename to V2.2/ODA/MetaboAnalyst_3.0.3/qs/csf.qs
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/qs/drug.qs b/V2.2/ODA/MetaboAnalyst_3.0.3/qs/drug.qs
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/qs/drug.qs
rename to V2.2/ODA/MetaboAnalyst_3.0.3/qs/drug.qs
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/qs/fecal.qs b/V2.2/ODA/MetaboAnalyst_3.0.3/qs/fecal.qs
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/qs/fecal.qs
rename to V2.2/ODA/MetaboAnalyst_3.0.3/qs/fecal.qs
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/qs/kegg_pathway.qs b/V2.2/ODA/MetaboAnalyst_3.0.3/qs/kegg_pathway.qs
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/qs/kegg_pathway.qs
rename to V2.2/ODA/MetaboAnalyst_3.0.3/qs/kegg_pathway.qs
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/qs/lipid/lipid_compound_db.qs b/V2.2/ODA/MetaboAnalyst_3.0.3/qs/lipid/lipid_compound_db.qs
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/qs/lipid/lipid_compound_db.qs
rename to V2.2/ODA/MetaboAnalyst_3.0.3/qs/lipid/lipid_compound_db.qs
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/qs/lipid/lipid_syn_nms.qs b/V2.2/ODA/MetaboAnalyst_3.0.3/qs/lipid/lipid_syn_nms.qs
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/qs/lipid/lipid_syn_nms.qs
rename to V2.2/ODA/MetaboAnalyst_3.0.3/qs/lipid/lipid_syn_nms.qs
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/qs/location.qs b/V2.2/ODA/MetaboAnalyst_3.0.3/qs/location.qs
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/qs/location.qs
rename to V2.2/ODA/MetaboAnalyst_3.0.3/qs/location.qs
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/qs/main_class.qs b/V2.2/ODA/MetaboAnalyst_3.0.3/qs/main_class.qs
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/qs/main_class.qs
rename to V2.2/ODA/MetaboAnalyst_3.0.3/qs/main_class.qs
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/qs/master_compound_db.qs b/V2.2/ODA/MetaboAnalyst_3.0.3/qs/master_compound_db.qs
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/qs/master_compound_db.qs
rename to V2.2/ODA/MetaboAnalyst_3.0.3/qs/master_compound_db.qs
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/qs/metab/hsa.qs b/V2.2/ODA/MetaboAnalyst_3.0.3/qs/metab/hsa.qs
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/qs/metab/hsa.qs
rename to V2.2/ODA/MetaboAnalyst_3.0.3/qs/metab/hsa.qs
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/qs/metab/mmu.qs b/V2.2/ODA/MetaboAnalyst_3.0.3/qs/metab/mmu.qs
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/qs/metab/mmu.qs
rename to V2.2/ODA/MetaboAnalyst_3.0.3/qs/metab/mmu.qs
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/qs/metpa/kegg/hsa.qs b/V2.2/ODA/MetaboAnalyst_3.0.3/qs/metpa/kegg/hsa.qs
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/qs/metpa/kegg/hsa.qs
rename to V2.2/ODA/MetaboAnalyst_3.0.3/qs/metpa/kegg/hsa.qs
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/qs/metpa/kegg/human.qs b/V2.2/ODA/MetaboAnalyst_3.0.3/qs/metpa/kegg/human.qs
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/qs/metpa/kegg/human.qs
rename to V2.2/ODA/MetaboAnalyst_3.0.3/qs/metpa/kegg/human.qs
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/qs/metpa/kegg/mmu.qs b/V2.2/ODA/MetaboAnalyst_3.0.3/qs/metpa/kegg/mmu.qs
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/qs/metpa/kegg/mmu.qs
rename to V2.2/ODA/MetaboAnalyst_3.0.3/qs/metpa/kegg/mmu.qs
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/qs/metpa/smpdb/hsa.qs b/V2.2/ODA/MetaboAnalyst_3.0.3/qs/metpa/smpdb/hsa.qs
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/qs/metpa/smpdb/hsa.qs
rename to V2.2/ODA/MetaboAnalyst_3.0.3/qs/metpa/smpdb/hsa.qs
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/qs/metpa/smpdb/mmu.qs b/V2.2/ODA/MetaboAnalyst_3.0.3/qs/metpa/smpdb/mmu.qs
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/qs/metpa/smpdb/mmu.qs
rename to V2.2/ODA/MetaboAnalyst_3.0.3/qs/metpa/smpdb/mmu.qs
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/qs/predicted.qs b/V2.2/ODA/MetaboAnalyst_3.0.3/qs/predicted.qs
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/qs/predicted.qs
rename to V2.2/ODA/MetaboAnalyst_3.0.3/qs/predicted.qs
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/qs/self-name.qs b/V2.2/ODA/MetaboAnalyst_3.0.3/qs/self-name.qs
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/qs/self-name.qs
rename to V2.2/ODA/MetaboAnalyst_3.0.3/qs/self-name.qs
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/qs/smpdb_pathway.qs b/V2.2/ODA/MetaboAnalyst_3.0.3/qs/smpdb_pathway.qs
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/qs/smpdb_pathway.qs
rename to V2.2/ODA/MetaboAnalyst_3.0.3/qs/smpdb_pathway.qs
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/qs/snp.qs b/V2.2/ODA/MetaboAnalyst_3.0.3/qs/snp.qs
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/qs/snp.qs
rename to V2.2/ODA/MetaboAnalyst_3.0.3/qs/snp.qs
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/qs/sub_class.qs b/V2.2/ODA/MetaboAnalyst_3.0.3/qs/sub_class.qs
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/qs/sub_class.qs
rename to V2.2/ODA/MetaboAnalyst_3.0.3/qs/sub_class.qs
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/qs/super_class.qs b/V2.2/ODA/MetaboAnalyst_3.0.3/qs/super_class.qs
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/qs/super_class.qs
rename to V2.2/ODA/MetaboAnalyst_3.0.3/qs/super_class.qs
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/qs/urine.qs b/V2.2/ODA/MetaboAnalyst_3.0.3/qs/urine.qs
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/qs/urine.qs
rename to V2.2/ODA/MetaboAnalyst_3.0.3/qs/urine.qs
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/share_projects.R b/V2.2/ODA/MetaboAnalyst_3.0.3/share_projects.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/share_projects.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/share_projects.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/spectra_processing.R b/V2.2/ODA/MetaboAnalyst_3.0.3/spectra_processing.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/spectra_processing.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/spectra_processing.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/spectra_utils.R b/V2.2/ODA/MetaboAnalyst_3.0.3/spectra_utils.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/spectra_utils.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/spectra_utils.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/sqlite/hsa_genes.sqlite b/V2.2/ODA/MetaboAnalyst_3.0.3/sqlite/hsa_genes.sqlite
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/sqlite/hsa_genes.sqlite
rename to V2.2/ODA/MetaboAnalyst_3.0.3/sqlite/hsa_genes.sqlite
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/sqlite/mmu_genes.sqlite b/V2.2/ODA/MetaboAnalyst_3.0.3/sqlite/mmu_genes.sqlite
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/sqlite/mmu_genes.sqlite
rename to V2.2/ODA/MetaboAnalyst_3.0.3/sqlite/mmu_genes.sqlite
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/stats_chemometrics.R b/V2.2/ODA/MetaboAnalyst_3.0.3/stats_chemometrics.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/stats_chemometrics.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/stats_chemometrics.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/stats_classification.R b/V2.2/ODA/MetaboAnalyst_3.0.3/stats_classification.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/stats_classification.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/stats_classification.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/stats_clustering.R b/V2.2/ODA/MetaboAnalyst_3.0.3/stats_clustering.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/stats_clustering.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/stats_clustering.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/stats_correlations.R b/V2.2/ODA/MetaboAnalyst_3.0.3/stats_correlations.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/stats_correlations.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/stats_correlations.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/stats_opls.R b/V2.2/ODA/MetaboAnalyst_3.0.3/stats_opls.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/stats_opls.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/stats_opls.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/stats_peaks.R b/V2.2/ODA/MetaboAnalyst_3.0.3/stats_peaks.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/stats_peaks.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/stats_peaks.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/stats_plot3d.R b/V2.2/ODA/MetaboAnalyst_3.0.3/stats_plot3d.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/stats_plot3d.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/stats_plot3d.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/stats_sigfeatures.R b/V2.2/ODA/MetaboAnalyst_3.0.3/stats_sigfeatures.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/stats_sigfeatures.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/stats_sigfeatures.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/stats_spls.R b/V2.2/ODA/MetaboAnalyst_3.0.3/stats_spls.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/stats_spls.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/stats_spls.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/stats_univariates.R b/V2.2/ODA/MetaboAnalyst_3.0.3/stats_univariates.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/stats_univariates.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/stats_univariates.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_biomarker.R b/V2.2/ODA/MetaboAnalyst_3.0.3/sweave_report_biomarker.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_biomarker.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/sweave_report_biomarker.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_enrichment.R b/V2.2/ODA/MetaboAnalyst_3.0.3/sweave_report_enrichment.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_enrichment.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/sweave_report_enrichment.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_integmex.R b/V2.2/ODA/MetaboAnalyst_3.0.3/sweave_report_integmex.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_integmex.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/sweave_report_integmex.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_meta_analysis.R b/V2.2/ODA/MetaboAnalyst_3.0.3/sweave_report_meta_analysis.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_meta_analysis.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/sweave_report_meta_analysis.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_mummichog.R b/V2.2/ODA/MetaboAnalyst_3.0.3/sweave_report_mummichog.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_mummichog.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/sweave_report_mummichog.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_network.R b/V2.2/ODA/MetaboAnalyst_3.0.3/sweave_report_network.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_network.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/sweave_report_network.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_pathway.R b/V2.2/ODA/MetaboAnalyst_3.0.3/sweave_report_pathway.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_pathway.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/sweave_report_pathway.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_power.R b/V2.2/ODA/MetaboAnalyst_3.0.3/sweave_report_power.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_power.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/sweave_report_power.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_raw_spectra.R b/V2.2/ODA/MetaboAnalyst_3.0.3/sweave_report_raw_spectra.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_raw_spectra.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/sweave_report_raw_spectra.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_stats.R b/V2.2/ODA/MetaboAnalyst_3.0.3/sweave_report_stats.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_stats.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/sweave_report_stats.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_time.R b/V2.2/ODA/MetaboAnalyst_3.0.3/sweave_report_time.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_time.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/sweave_report_time.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_reporter.R b/V2.2/ODA/MetaboAnalyst_3.0.3/sweave_reporter.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/sweave_reporter.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/sweave_reporter.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/time_asca_heatmap2.R b/V2.2/ODA/MetaboAnalyst_3.0.3/time_asca_heatmap2.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/time_asca_heatmap2.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/time_asca_heatmap2.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/time_mb.R b/V2.2/ODA/MetaboAnalyst_3.0.3/time_mb.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/time_mb.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/time_mb.R
diff --git a/V2.1/ODA/MetaboAnalyst_3.0.3/time_pca_anova2.R b/V2.2/ODA/MetaboAnalyst_3.0.3/time_pca_anova2.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst_3.0.3/time_pca_anova2.R
rename to V2.2/ODA/MetaboAnalyst_3.0.3/time_pca_anova2.R
diff --git a/V2.2/ODA/ODA.R b/V2.2/ODA/ODA.R
new file mode 100755
index 0000000000000000000000000000000000000000..443b43c3f694cd603efe70541c9e3bd840e7665f
--- /dev/null
+++ b/V2.2/ODA/ODA.R
@@ -0,0 +1,286 @@
+#This script was developed by zhiyu.zhao@utsouthwestern.edu .
+initial.options=commandArgs(trailingOnly=F)
+scriptPath=file.path(dirname(sub("--file=","",initial.options[grep("--file=",initial.options)])))
+if (length(scriptPath)==0)
+ scriptPath='.'
+source(file.path(scriptPath,'odaObject.R'))
+source(file.path(scriptPath,'workBook.R'))
+source(file.path(scriptPath,'statTests.R'))
+source(file.path(scriptPath,'clusterProfiler.R'))
+source(file.path(scriptPath,'MetaboAnalyst.R'))
+##############################Begin Reading Arguments#############################
+if (DEBUGGING) { #Set to F for actual files or T for debugging a test.xlsx in the R console. See constants.R
+ inputFile='./test/test.xlsx'
+ outputPath='./test/Result'
+} else {
+ args=commandArgs(trailingOnly=T)
+ if (length(args)!=2)
+ stop('Please specify input file and output path.')
+ inputFile=args[1]
+ outputPath=args[2]
+}
+if (!file.exists(inputFile))
+ stop('Input file is not found.')
+#############################End Reading Arguments#############################
+
+#############################Begin Main#############################
+message('######################Analysis started.######################')
+odaObj=createODAObject(inputFile,outputPath)
+wbObj=createWBObject(odaObj$parameters)
+
+##############################Begin Writing Summary#####################################
+report=odaObj$parameters
+report$heatmapColors=NULL
+#report$formulaForFitting=NULL
+if (report$logTransform)
+ report$groupMeanLowerBound=paste0('log2(',2^report$groupMeanLowerBound,')=',report$groupMeanLowerBound)
+if (report$normalization=='byupperquantile') {
+ report$uqProb=paste0(report$uqProb*100,'%')
+} else {
+ report$uqProb=NULL
+}
+wbObj=writeTable(wbObj,'Summary',report,'Parameters')
+report=odaObj$attributes
+#report$formulaForFitting=NULL
+wbObj=writeTable(wbObj,'Summary',report,'Attributes',NULL,0,3)
+wbObj=writeTable(wbObj,'Summary',odaObj$groupSummary,'Groups',NULL,0,6)
+wbObj=writeTable(wbObj,'Summary',odaObj$sampleSummary,'Samples',NULL,0,10)
+##############################End Writing Summary#####################################
+
+##############################Begin Writing Data and Figures#####################################
+if (odaObj$parameters$visual) {
+ plotPosition=1
+ wbObj=writeGeneralFigures(wbObj,'Visual',odaObj$rawDataTable,odaObj$rawDataList,odaObj$samples,odaObj$parameters,'Raw_Data',plotPosition,odaObj$figuresPath)
+ plotPosition=plotPosition+1
+ wbObj=writeEulerDiagrams(wbObj,'Visual',odaObj$presentGroups,odaObj$presentSamples,odaObj$samples,odaObj$parameters,odaObj$attributes,plotPosition,odaObj$figuresPath)
+ if (odaObj$transform) {
+ plotPosition=plotPosition+1
+ wbObj=writeGeneralFigures(wbObj,'Visual',odaObj$transformedDataTable,odaObj$transformedDataList,odaObj$samples,odaObj$parameters,'Transformed_Data',plotPosition,odaObj$figuresPath)
+ }
+}
+wbObj=writeDataSheet(wbObj,'Filtered_Data',odaObj$rawDataTable,odaObj$samples,odaObj$parameters,'Raw_Data',odaObj$featureDescription)
+if (odaObj$transform)
+ wbObj=writeDataSheet(wbObj,'Transformed_Filtered_Data',odaObj$transformedDataTable,odaObj$samples,odaObj$parameters,odaObj$trTitle,odaObj$featureDescription)
+wbObj=writeTable(wbObj,'Sample_Counts',odaObj$presentSamples,'ID',odaObj$featureDescription,0,0,2,ifelse(is.null(odaObj$featureDescription),2,3))
+wbObj=writeTable(wbObj,'Group_Counts',odaObj$presentGroups,'ID',odaObj$featureDescription,0,0,2,ifelse(is.null(odaObj$featureDescription),2,3))
+##############################End Writing Data and Figures#####################################
+
+##############################Begin Writing Selected Features#####################################
+if (odaObj$attributes$nInterestedFeatures>0) {
+message('###############Processing selected features###############')
+ rowOffset=0
+ wbObj=writeDataSheet(wbObj,'Selected_Features',odaObj$rawDataTable[odaObj$features$interested,,drop=F],odaObj$samples,odaObj$parameters,'Raw_Data',odaObj$featureDescription[odaObj$features$interested,],rowOffset,F)
+ if (odaObj$parameters$visual&&odaObj$attributes$nInterestedFeatures>1) {
+ plotPosition=plotPosition+1
+ wbObj=writeGeneralFigures(wbObj,'Visual',odaObj$rawDataTable[odaObj$features$interested,,drop=F],odaObj$rawDataList[odaObj$rawDataList$Feature %in% odaObj$features$interested,],odaObj$samples,odaObj$parameters,'Selected_Raw_Data',plotPosition,odaObj$figuresPath)
+ if (odaObj$attributes$nInterestedFeatures<=20&&odaObj$attributes$nSamples>=6) {
+ plotPosition=plotPosition+1
+ wbObj=writeFeatureFigures(wbObj,'Visual',odaObj$rawDataTable[odaObj$features$interested,,drop=F],odaObj$rawDataList[odaObj$rawDataList$Feature %in% odaObj$features$interested,],'Selected_Raw_Features',plotPosition,odaObj$figuresPath)
+ }
+ }
+ if (odaObj$transform) {
+ rowOffset=odaObj$attributes$nInterestedFeatures+8
+ wbObj=writeDataSheet(wbObj,'Selected_Features',odaObj$transformedDataTable[odaObj$features$interested,,drop=F],odaObj$samples,odaObj$parameters,odaObj$trTitle,odaObj$featureDescription[odaObj$features$interested,],rowOffset,F)
+ if (odaObj$parameters$visual&&odaObj$attributes$nInterestedFeatures>1) {
+ plotPosition=plotPosition+1
+ wbObj=writeGeneralFigures(wbObj,'Visual',odaObj$transformedDataTable[odaObj$features$interested,,drop=F],odaObj$transformedDataList[odaObj$transformedDataList$Feature %in% odaObj$features$interested,],odaObj$samples,odaObj$parameters,'Selected_Transformed_Data',plotPosition,odaObj$figuresPath)
+ if (odaObj$attributes$nInterestedFeatures<=20&&odaObj$attributes$nSamples>=6) {
+ plotPosition=plotPosition+1
+ wbObj=writeFeatureFigures(wbObj,'Visual',odaObj$transformedDataTable[odaObj$features$interested,,drop=F],odaObj$transformedDataList[odaObj$transformedDataList$Feature %in% odaObj$features$interested,],'Selected_Transformed_Features',plotPosition,odaObj$figuresPath)
+ }
+ }
+ }
+ rowOffset=rowOffset+odaObj$attributes$nInterestedFeatures+8
+ wbObj=writeTable(wbObj,'Selected_Features',odaObj$presentSamples[odaObj$features$interested,,drop=F],'Sample_Counts',odaObj$featureDescription,rowOffset,0)
+ rowOffset=rowOffset+odaObj$attributes$nInterestedFeatures+3
+ wbObj=writeTable(wbObj,'Selected_Features',odaObj$presentGroups[odaObj$features$interested,,drop=F],'Group_Counts',odaObj$featureDescription,rowOffset,0)
+message('###############Finished processing selected features###############')
+}
+##############################End Writing Selected Features#####################################
+
+##############################Begin Writing Size Ratio Figures (RLE-only)#####################################
+if (odaObj$parameters$visual&&odaObj$parameters$normalization=='rle') {
+ plotPosition=plotPosition+1
+ wbObj=writeGeneralFigures(wbObj,'Visual',odaObj$sizeRatiosTable,odaObj$sizeRatiosList,odaObj$samples,odaObj$parameters,'Log2_Size_Ratio',plotPosition,odaObj$figuresPath)
+}
+##############################End Writing Size Ratio Figures #####################################
+
+if (!(odaObj$parameters$species %in% c('mouse','Mouse','human','Human'))) {
+ odaObj$parameters$eaDB='customized'
+ message('eaDB is changed to "Customized" due to unsupported species. eaFile must be supplied for the enrichment analysis.')
+}
+
+##############################Begin ORA Analysis#####################################
+if (odaObj$parameters$oraMethod!='no'&&odaObj$parameters$eaDB!='no'&&!is.null(odaObj$features$eaFeatures)) {
+ eaPath=file.path(odaObj$eaPath,paste0(odaObj$parameters$eaDB,'_',odaObj$parameters$oraMethod),odaObj$parameters$eaName)
+ if (file.exists(eaPath)&&!rlang::is_empty(dir(eaPath))) {
+ message('CAUTION: ORA folder is not empty.')
+ }
+ {
+ dir.create(eaPath,recursive=T,showWarnings=F)
+ if (odaObj$parameters$oraMethod=='msea-ora')
+ MSEA_ORA(file.path(eaPath,'msea_ora'),rownames(odaObj$features$eaFeatures),odaObj$features$refFeatures,idType=odaObj$features$eaFeatureIDType,dbType=odaObj$parameters$eaDB,lipid=(odaObj$parameters$featureType=='lipid'),eaFile=odaObj$parameters$eaFile)
+ if (odaObj$parameters$oraMethod=='mspa-ora')
+ MSPA_ORA(file.path(eaPath,'mspa_ora'),rownames(odaObj$features$eaFeatures),odaObj$features$refFeatures,idType=odaObj$features$eaFeatureIDType,dbType=odaObj$parameters$eaDB,odaObj$parameters$species,eaFile=odaObj$parameters$eaFile)
+ if (odaObj$parameters$oraMethod=='clusterprofiler-ora') {
+ if (odaObj$parameters$qeaMethod=='clusterprofiler-qea') {
+ stop('clusterProfiler ORA and QEA analyses cannot be done at the same time. Please run them separately.')
+ }
+ clusterProfiler_EA(file.path(eaPath,'clusterProfiler_ora'),odaObj$features$eaFeatures,odaObj$features$refFeatures,idType=odaObj$features$eaFeatureIDType,dbType=odaObj$parameters$eaDB,odaObj$parameters$species,eaFile=odaObj$parameters$eaFile,method='ORA',showTop=odaObj$parameters$eaShowTop)
+ }
+ }
+}
+##############################End ORA Analysis#####################################
+
+##############################Begin JointPA Analysis by MetaboAnalyst#####################################
+if ((!is.null(odaObj$features$eaFeatures)||!is.null(odaObj$features$eaGenes))&&odaObj$parameters$jointPA!='no') {
+ eaPath=file.path(odaObj$eaPath,'kegg_pathway_JointPA',odaObj$parameters$eaName)
+ if (file.exists(eaPath)&&!rlang::is_empty(dir(eaPath))) {
+ message('CAUTION: JointPA folder is not empty.')
+ }
+ {
+ dir.create(eaPath,recursive=T,showWarnings=F)
+ MetaboAnalyst_JointPA(file.path(eaPath,'JointPA'),odaObj$features$eaFeatures,odaObj$features$eaGenes,odaObj$features$eaFeatureIDType,odaObj$features$eaGeneIDType,odaObj$parameters$species,odaObj$parameters$jointPA)
+ }
+}
+##############################End JointPA Analysis by MetaboAnalyst#####################################
+
+if (odaObj$transform) {
+ dataList=odaObj$transformedDataList
+ dataTable=odaObj$transformedDataTable
+} else {
+ dataList=odaObj$rawDataList
+ dataTable=odaObj$rawDataTable
+}
+
+##############################Begin QEA Analysis#####################################
+if (odaObj$parameters$qeaMethod!='no') {
+ if (!is.null(odaObj$comparisons$dePairs)&&(odaObj$parameters$qeaMethod=='msea-qea'||odaObj$parameters$qeaMethod=='mspa-qea')) {
+ for (i in 1:length(odaObj$comparisons$dePairs)) {
+ if (odaObj$parameters$eaDB!='no') {
+ eaPath=file.path(odaObj$eaPath,paste0(odaObj$parameters$eaDB,'_',odaObj$parameters$qeaMethod),paste0(odaObj$comparisons$dePairs[[i]],collapse='_vs_'),odaObj$parameters$eaName)
+ if (file.exists(eaPath)&&!rlang::is_empty(dir(eaPath))) {
+ message('CAUTION: QEA folder is not empty.')
+ }
+ {
+ dir.create(eaPath,recursive=T,showWarnings=F)
+ temp=rbind(as.character(odaObj$samples$GroupID),dataTable) #MetaboAnalyst uses the normalized, transformed data table with sample labels.
+ temp=temp[,as.character(odaObj$samples$GroupID)%in%odaObj$comparisons$dePairs[[i]]]
+ write.csv(temp,file=file.path(eaPath,'temp_qea_data.csv'),quote=T)
+ if (odaObj$parameters$qeaMethod=='msea-qea') {
+ MSEA_QEA(file.path(eaPath,'msea_qea'),file.path(eaPath,'temp_qea_data.csv'),odaObj$features$refFeatures,idType=odaObj$parameters$idType,dbType=odaObj$parameters$eaDB,lipid=(odaObj$parameters$featureType=='lipid'),eaFile=odaObj$parameters$eaFile)
+ }
+ if (odaObj$parameters$qeaMethod=='mspa-qea') {
+ MSPA_QEA(file.path(eaPath,'mspa_qea'),file.path(eaPath,'temp_qea_data.csv'),odaObj$features$refFeatures,idType=odaObj$parameters$idType,dbType=odaObj$parameters$eaDB,species=odaObj$parameters$species,eaFile=odaObj$parameters$eaFile)
+ }
+ unlink(file.path(eaPath,'temp_qea_data.csv'))
+ }
+ }
+ }
+ }
+ if (odaObj$parameters$qeaMethod=='clusterprofiler-qea'&&!is.null(odaObj$features$eaFeatures)&&sum(odaObj$features$eaFeatures!=0)!=0) { #eaFeatures must be a gene list with log fold changes.
+ if (odaObj$parameters$eaDB!='no') {
+ eaPath=file.path(odaObj$eaPath,paste0(odaObj$parameters$eaDB,'_',odaObj$parameters$qeaMethod),odaObj$parameters$eaName)
+ if (file.exists(eaPath)&&!rlang::is_empty(dir(eaPath))) {
+ message('CAUTION: QEA folder is not empty.')
+ }
+ {
+ dir.create(eaPath,recursive=T,showWarnings=F)
+ clusterProfiler_EA(file.path(eaPath,'clusterprofiler_qea'),odaObj$features$eaFeatures,idType=odaObj$parameters$idType,dbType=odaObj$parameters$eaDB,species=odaObj$parameters$species,eaFile=odaObj$parameters$eaFile,method='QEA',showTop=odaObj$parameters$eaShowTop)
+ }
+ }
+ }
+}
+##############################End QEA Analysis#####################################
+
+##############################Begin Differential Tests#####################################
+if (odaObj$parameters$statTest!='no'&&!is.null(odaObj$comparisons)) {
+ message('##########Begin Differential Tests.##########')
+ summary=NULL
+##############################Begin Analysis of dePairs#####################################
+ if (!is.null(odaObj$comparisons$dePairs)) {
+ if (odaObj$parameters$visual)
+ plotPosition=plotPosition+1
+ for (i in 1:length(odaObj$comparisons$dePairs)) {
+ if (odaObj$parameters$statTest==COMMON_TESTS[4]) { #Ordinary t-test.
+ res=t_test(dataList,odaObj$comparisons$dePairs[[i]],odaObj$parameters$groupMeanLowerBound,odaObj$parameters$logTransform,normal=T,var.equal=T)
+ } else if (odaObj$parameters$statTest==COMMON_TESTS[5]) { #Welch's t-test; unpaired only. If data are paired var.equal is not applicable.
+ res=t_test(dataList,odaObj$comparisons$dePairs[[i]],odaObj$parameters$groupMeanLowerBound,odaObj$parameters$logTransform,normal=T,var.equal=F)
+ } else if (odaObj$parameters$statTest==COMMON_TESTS[6]) { #Nonparametric t-test.
+ res=t_test(dataList,odaObj$comparisons$dePairs[[i]],odaObj$parameters$groupMeanLowerBound,odaObj$parameters$logTransform,normal=F,var.equal=F) #When normal is F var.equal is not applicable.
+ } else if (odaObj$parameters$statTest==COMMON_TESTS[2]) { #glm
+ res=glm_test(dataList,odaObj$comparisons$dePairs[[i]],odaObj$parameters$groupMeanLowerBound,odaObj$parameters$logTransform,odaObj$attributes$formulaStr,odaObj$attributes$familyStr)
+ } else if (odaObj$parameters$statTest==COMMON_TESTS[3]) { #cpglm
+ res=glm_test(dataList,odaObj$comparisons$dePairs[[i]],odaObj$parameters$groupMeanLowerBound,odaObj$parameters$logTransform,odaObj$attributes$formulaStr,odaObj$attributes$familyStr,cp=T)
+ } else if (odaObj$parameters$statTest=='deseq2') { #Added by ZZY on 10/03/24.
+ res=deseq2_test(odaObj$rawDataList,odaObj$transformedDataList,odaObj$comparisons$dePairs[[i]],odaObj$parameters$groupMeanLowerBound,odaObj$parameters$logTransform,odaObj$attributes$formulaStr,odaObj$samples)
+ } else {
+ stop('Unknown statistical test method.')
+ }
+ fcName=paste0('fold_change_',odaObj$comparisons$dePairs[[i]][1],'/',odaObj$comparisons$dePairs[[i]][2])
+ if (odaObj$parameters$visual) {
+ cols=c(ifelse(odaObj$parameters$volcanoP==VALID_OPTIONS$volcanoP[1],'FDR','pValue'),fcName)
+ wbObj=writeVolcanoPlot(wbObj,'Visual',odaObj$comparisons$dePairs[[i]],res[,cols],odaObj$features$interested,odaObj$parameters,plotPosition,i,odaObj$figuresPath)
+ }
+ res=res[order(res$FDR,res[,fcName]),]
+ odaObj$comparisons$dePairsRes[[i]]=res #Added by zzy on 12/29/23 for saving the odaObj into an rdata file.
+ wbObj=writeTable(wbObj,paste0('Comparison',i),res,paste(odaObj$comparisons$dePairs[[i]],collapse='_vs_'),odaObj$featureDescription,0,0,2,ifelse(is.null(odaObj$featureDescription),2,3))
+ if (odaObj$attributes$nInterestedFeatures>0) {
+ rowOffset=rowOffset+odaObj$attributes$nInterestedFeatures+3
+ wbObj=writeTable(wbObj,'Selected_Features',res[odaObj$features$interested,,drop=F],paste(odaObj$comparisons$dePairs[[i]],collapse='_vs_'),odaObj$featureDescription,rowOffset,0)
+ }
+ summary=rbind(summary,summarizeDiffTest(res,odaObj$comparisons$dePairs[[i]],odaObj$presentGroups>=odaObj$parameters$groupCountFilter,odaObj$parameters))
+ } #End of for (i)
+ }
+##############################End Analysis of dePairs#####################################
+
+##############################Begin Analysis of deANOVAs#####################################
+ if (!is.null(odaObj$comparisons$deANOVAs)) {
+ for (i in 1:length(odaObj$comparisons$deANOVAs)) {
+ if (odaObj$parameters$statTest==COMMON_TESTS[4]) { #Ordinary ANOVA.
+ res=anova_test(dataList,odaObj$comparisons$deANOVAs[[i]],odaObj$parameters$groupMeanLowerBound,odaObj$parameters$logTransform,normal=T,var.equal=T)
+ } else if (odaObj$parameters$statTest==COMMON_TESTS[5]) { #Welch's ANOVA; unpaired only. If data are paired var.equal is not applicable.
+ res=anova_test(dataList,odaObj$comparisons$deANOVAs[[i]],odaObj$parameters$groupMeanLowerBound,odaObj$parameters$logTransform,normal=T,var.equal=F)
+ } else if (odaObj$parameters$statTest==COMMON_TESTS[6]) { #Nonparametric "ANOVA".
+ res=anova_test(dataList,odaObj$comparisons$deANOVAs[[i]],odaObj$parameters$groupMeanLowerBound,odaObj$parameters$logTransform,normal=F,var.equal=F) #When normal is F var.equal is not applicable.
+ } else if (odaObj$parameters$statTest==COMMON_TESTS[2]) { #glm
+ res=glm_test(dataList,odaObj$comparisons$deANOVAs[[i]],odaObj$parameters$groupMeanLowerBound,odaObj$parameters$logTransform,odaObj$attributes$formulaStr,odaObj$attributes$familyStr)
+ } else if (odaObj$parameters$statTest==COMMON_TESTS[3]) { #cpglm
+ res=glm_test(dataList,odaObj$comparisons$deANOVAs[[i]],odaObj$parameters$groupMeanLowerBound,odaObj$parameters$logTransform,odaObj$attributes$formulaStr,odaObj$attributes$familyStr,cp=T)
+ } else if (odaObj$parameters$statTest=='deseq2') { #Added by ZZY on 10/03/24.
+ res=deseq2_test(odaObj$rawDataList,odaObj$transformedDataList,odaObj$comparisons$deANOVAs[[i]],odaObj$parameters$groupMeanLowerBound,odaObj$parameters$logTransform,odaObj$attributes$formulaStr,odaObj$samples)
+ } else {
+ stop('Unknown statistical test method.')
+ }
+ res=res[order(res$Overall_FDR,res$Overall_pValue),]
+ odaObj$comparisons$deANOVAsRes[[i]]=res #Added by zzy on 12/29/23 for saving the odaObj into an rdata file.
+ wbObj=writeTable(wbObj,paste0('Overall',i),res,paste(odaObj$comparisons$deANOVAs[[i]],collapse='_vs_'),odaObj$featureDescription,0,0,2,ifelse(is.null(odaObj$featureDescription),2,3))
+ if (odaObj$attributes$nInterestedFeatures>0) {
+ rowOffset=rowOffset+odaObj$attributes$nInterestedFeatures+3
+ wbObj=writeTable(wbObj,'Selected_Features',res[odaObj$features$interested,,drop=F],paste(odaObj$comparisons$deANOVAs[[i]],collapse='_vs_'),odaObj$featureDescription,rowOffset,0)
+ }
+ for (j in 1:length(odaObj$comparisons$deANOVAs[[i]])) {
+ others=setdiff(odaObj$comparisons$deANOVAs[[i]],odaObj$comparisons$deANOVAs[[i]][j])
+ presentGroups=odaObj$presentGroups>=odaObj$parameters$groupCountFilter
+ presentGroups=rowSums(presentGroups[,others])>0
+ presentGroups=cbind(odaObj$presentGroups[,odaObj$comparisons$deANOVAs[[i]][j]]>=odaObj$parameters$groupCountFilter,presentGroups)
+ colnames(presentGroups)=c(odaObj$comparisons$deANOVAs[[i]][j],'Others')
+ summary=rbind(summary,summarizeDiffTest(res,colnames(presentGroups),presentGroups,odaObj$parameters))
+ }
+ }
+ wbObj=writeTable(wbObj,'Summary',summary,'DiffTestSummary',NULL,0,13)
+ }
+##############################End Analysis of deANOVAs#####################################
+ message('##########End of Differential Tests.##########')
+}
+##############################End Differential Tests#####################################
+if (file.exists(file.path(outputPath,'ODA_Result.xlsx')))
+ message('CAUTION: ODA_Result.xlsx exists and will be overwritten.')
+saveWorkbook(wbObj$wb,file.path(outputPath,'ODA_Result.xlsx'),overwrite=T)
+if (file.exists(file.path(outputPath,'ODA_Result.rdata')))
+ message('CAUTION: ODA_Result.rdata exists and will be overwritten.')
+save(odaObj,wbObj,file=file.path(outputPath,'ODA_Result.rdata'),precheck=F)
+unlink('Rplots.pdf')
+message('######################Analysis finished.######################')
+
+#############################End Main#############################
diff --git a/V2.2/ODA/clusterProfiler.R b/V2.2/ODA/clusterProfiler.R
new file mode 100644
index 0000000000000000000000000000000000000000..ecea5c8168db2142683138d228491e1b2299233b
--- /dev/null
+++ b/V2.2/ODA/clusterProfiler.R
@@ -0,0 +1,253 @@
+#Note: for KEGG, supported key types are"kegg, ncbi-geneid, ncbi-proteinid and uniprot. For GO and enricher, supported key types are ENTREZID, SYMBOL, ENSEMBL, and UNIPROT. kegg=ncbi-geneid=ENTREZID.
+#############################Begin Source Files#############################
+initial.options=commandArgs(trailingOnly=F)
+scriptPath=file.path(dirname(sub("--file=","",initial.options[grep("--file=",initial.options)])))
+if (length(scriptPath)==0)
+ scriptPath='.'
+source(file.path(scriptPath,'libraries.R'))
+#############################End Source Files#############################
+
+options(bitmapType='cairo')
+
+##########################################################
+clusterProfile=function(filePrefix,species,orgDb,markers,universe=NULL,idType='SYMBOL',enrichType='kegg',categoryOrSets=NULL,pvalueCutoff=0.05,qvalueCutoff=0.05,showTop=10,minSetSize=5,method='ORA') {
+ enrichTable=NULL
+ type=enrichType
+ if (method=='ORA') {
+ genes=markers$gene
+ } else {
+ fc=grep('log_FC',colnames(markers))
+ markers=markers[order(-markers[,fc]),] #For gsea analysis, clusterProfiler requires a list of gene scores sorted in the decreasing order.
+ genes=markers[,fc]
+ names(genes)=markers$gene
+ }
+ for (cluster in unique(markers$cluster)) { #When markers$cluster is NA, unique(markers$cluster) is NA as well, and its length is 1.)
+ if (!is.na(cluster)) {
+ if (method=='ORA') {
+ genes=markers$gene[markers$cluster==cluster,drop=F]
+ } else {
+ genes=markers[markers$cluster==cluster,2]
+ names(genes)=markers$gene[markers$cluster==cluster]
+ }
+ }
+ if (length(genes)>2) {
+ if (enrichType=='kegg'&&method=='ORA') {
+ temp=enrichKEGG(gene=genes,universe=universe,organism=species,pvalueCutoff=pvalueCutoff,qvalueCutoff=qvalueCutoff,keyType=idType,use_internal_data=F,maxGSSize=1000,minGSSize=minSetSize)
+ } else if (enrichType=='kegg'&&method=='QEA') {
+ temp=gseKEGG(geneList=genes,organism=species,pvalueCutoff=pvalueCutoff,keyType=idType,use_internal_data=F,maxGSSize=1000,minGSSize=minSetSize)
+ } else if (enrichType=='go'&&method=='ORA') {
+ temp=enrichGO(gene=genes,universe=universe,OrgDb=orgDb,pvalueCutoff=pvalueCutoff,qvalueCutoff=qvalueCutoff,ont=categoryOrSets,keyType=idType,maxGSSize=1000,minGSSize=minSetSize)
+ } else if (enrichType=='go'&&method=='QEA') {
+ temp=gseGO(geneList=genes,OrgDb=orgDb,pvalueCutoff=pvalueCutoff,ont=categoryOrSets,keyType=idType,maxGSSize=1000,minGSSize=minSetSize)
+ } else if ((enrichType=='cellmarker' || enrichType=='msigdb' || enrichType=='customized')&&method=='ORA') {
+ temp=enricher(gene=genes,universe=universe,TERM2GENE=categoryOrSets,TERM2NAME=NA,pvalueCutoff=pvalueCutoff,qvalueCutoff=qvalueCutoff,maxGSSize=1000,minGSSize=minSetSize)
+ } else if ((enrichType=='cellmarker' || enrichType=='msigdb' || enrichType=='customized')&&method=='QEA') {
+ temp=GSEA(geneList=genes,TERM2GENE=categoryOrSets,TERM2NAME=NA,pvalueCutoff=pvalueCutoff,maxGSSize=1000,minGSSize=minSetSize)
+ }
+# temp=temp%>%filter(Count>1) #Disabled because the GSEA results don't have Count.
+ if (method=='QEA'&&dim(temp)[1]>0)
+ for (i in 1:min(showTop,dim(temp)[1]))
+ ggsave(paste0(filePrefix,'_',ifelse(is.na(cluster),'',cluster),i,'.pdf'),gseaplot2(temp,title=temp$Description[i],geneSetID=i),height=10,width=10)
+ if (!is.null(temp)&&dim(temp)[1]>0) {
+ if (enrichType=='kegg') {
+ if (idType=='ncbi-geneid'||idType=='kegg') {
+ temp=setReadable(temp,OrgDb=orgDb,keyType="ENTREZID")
+ } else {
+ temp=setReadable(temp,OrgDb=orgDb,keyType=toupper(idType))
+ }
+ } else if (idType!='SYMBOL') {
+ temp=setReadable(temp,OrgDb=orgDb,keyType=idType)
+ }
+ if (enrichType=='go') {
+ if (categoryOrSets=='ALL') {
+ temp=temp%>%mutate(Description=paste0(ONTOLOGY,'_',Description))
+ } else {
+ temp=simplify(temp) #Simplify is not supported for GO_ALL.
+ temp=temp%>%mutate(Description=paste0(categoryOrSets,'_',Description))
+ }
+ }
+ if (dim(temp)[1]>0) {
+ if (method=='ORA')
+ temp=temp%>%arrange(qvalue,-Count)
+ else
+ temp=temp%>%arrange(-NES,qvalue)
+ if (is.na(cluster)) {
+ p=dotplot(temp,showCategory=showTop)+ggtitle(paste0('Enriched ',type,' Terms for Markers'))
+ ggsave(paste0(filePrefix,'.pdf'),p,height=10,width=16)
+ } else {
+ p=dotplot(temp,showCategory=showTop)+ggtitle(paste0('Enriched ',type,' Terms for Markers of Cluster ',cluster))
+ ggsave(paste0(filePrefix,'_',cluster,'.pdf'),p,height=10,width=16)
+ }
+ temp=data.frame(temp,Cluster=cluster)
+ enrichTable=rbind(enrichTable,temp)
+ }
+ }
+ }
+ }
+ if (!is.null(enrichTable)) {
+ if (is.na(unique(enrichTable$Cluster)))
+ enrichTable$Cluster=NULL
+ if (method=='ORA') {
+ geneRatio=enrichTable[,'GeneRatio',drop=F]
+ geneRatio=apply(geneRatio,1,function(x) eval(parse(text=x)))
+ bgRatio=enrichTable[,'BgRatio',drop=F]
+ bgRatio=apply(bgRatio,1,function(x) eval(parse(text=x)))
+ enrichTable$richFactor=geneRatio/bgRatio
+ enrichTable=enrichTable%>%arrange(qvalue,-Count,-richFactor)
+ }
+ write.csv(enrichTable,paste0(filePrefix,'.csv'),quote=T,row.names=F)
+ }
+}
+##########################################################
+saveClusterProfiles=function(filePrefix,markers,universe=NULL,idType='SYMBOL',species='mouse',enrichType='kegg',categoryOrSets=NULL,pvalueCutoff=0.05,qvalueCutoff=0.05,showTop=10,minSetSize=5,method='ORA'){
+#markers: A dataframe with the "gene" column, or a csv file with a "gene" column of gene symbols.
+#species: human|mouse
+#enrichType: kegg|go|cellmarker|msigdb, or customized.
+#categoryOrSets: NULL for kegg, ALL|BP|CC|MF for go, file name for cellmarker, NULL|H|C* for msigdb, or file name for a user-defined enrichType.
+#method: ORA|QEA
+ if (species=='mouse'||species=='Mouse') {
+ species='mmu'
+ orgDb='org.Mm.eg.db'
+ } else if (species=='human'||species=='Human') {
+ species='hsa'
+ orgDb='org.Hs.eg.db'
+ } else {
+ if (enrichType!='customized')
+ stop('Unknown species.')
+ }
+ if (idType=='KEGG')
+ idType='ENTREZID'
+ if (method=='ORA') {
+ if (idType!='SYMBOL') {
+ genes=try(bitr(markers$gene,fromType=idType,toType='SYMBOL',OrgDb=orgDb,drop=F))
+ } else {
+ genes=markers[,'gene',drop=F]
+ }
+ write.csv(genes,paste0(filePrefix,'_gene_symbols.csv'),quote=T,row.names=F)
+ }
+ if (!is.null(universe))
+ universe=as.character(universe[,1])
+ if (enrichType=='go') {
+ if (method=='ORA') {
+ enrichTable=try(compareCluster(gene~cluster,fun="enrichGO",data=markers,universe=universe,OrgDb=orgDb,ont=categoryOrSets,pvalueCutoff=pvalueCutoff,qvalueCutoff=qvalueCutoff,keyType=idType,maxGSSize=1000,minGSSize=minSetSize))
+ if (class(enrichTable)!='try-error'&&dim(enrichTable)[1]>0&&categoryOrSets=='ALL') {
+ enrichTable=simplify(enrichTable)%>%filter(Count>1)
+ enrichTable=enrichTable%>%mutate(Description=paste0(ONTOLOGY,'_',Description))
+ p=NULL
+ for (go in c('BP','CC','MF')) {
+ temp=enrichTable%>%filter(grepl(paste0('^',go,'_'),Description))
+ if (dim(temp)[1]>0) {
+ temp=temp%>%arrange(qvalue,-Count)
+ p[[go]]=dotplot(temp,showCategory=showTop)+ggtitle(paste0('Enriched ',go,' Terms of Markers'))
+ }
+ }
+ ggsave(paste0(filePrefix,'_by_Categories.pdf'),wrap_plots(p,ncol=1,nrow=length(p)),height=length(p)*10,width=20)
+ }
+ }
+ clusterProfile(filePrefix,species,orgDb,markers,universe,idType,'go',categoryOrSets,pvalueCutoff=pvalueCutoff,qvalueCutoff=qvalueCutoff,showTop=showTop,minSetSize=minSetSize,method=method)
+ } else if (enrichType=='kegg') { #Supported types are kegg, ncbi-geneid (=ENTREZID), ncbi-proteinid and uniprot.
+ if (idType=='SYMBOL'||idType=='ENSEMBL') {
+ genes=try(bitr(markers$gene,fromType=idType,toType='ENTREZID',OrgDb=orgDb,drop=F))
+ if (class(genes)!='try-error'&&dim(genes)[1]>2) {
+ markers=merge(markers,genes,by.x='gene',by.y=idType)
+ colnames(markers)[1]=idType
+ colnames(markers)[dim(markers)[2]]='gene'
+ genes=try(bitr(universe,fromType=idType,toType='ENTREZID',OrgDb=orgDb,drop=F))
+ if (class(genes)!='try-error'&&dim(genes)[1]>2)
+ universe=as.character(genes$ENTREZID)
+ idType='ncbi-geneid'
+ }
+ } else if (idType=='ENTREZID') {
+ idType='ncbi-geneid'
+ } else {
+ idType=tolower(idType)
+ }
+ if (method=='ORA') {
+ enrichTable=try(compareCluster(gene~cluster,fun="enrichKEGG",data=markers,universe=universe,organism=species,pvalueCutoff=pvalueCutoff,qvalueCutoff=qvalueCutoff,keyType=idType,use_internal_data=F,maxGSSize=1000,minGSSize=minSetSize))
+ if (!is.null(enrichTable)&&class(enrichTable)!='try-error'&&dim(enrichTable)[1]>0) { #KEGG has no subcategories, so
+ enrichTable=enrichTable%>%filter(Count>1)
+ if (dim(enrichTable)[1]>0) {
+ enrichTable=enrichTable%>%arrange(qvalue,-Count)
+ p=dotplot(enrichTable,showCategory=showTop)+ggtitle('Enriched KEGG Pathways of Markers')
+ ggsave(paste0(filePrefix,'.pdf'),p,height=10,width=20)
+ }
+ }
+ }
+ clusterProfile(filePrefix,species,orgDb,markers,universe,idType,'kegg',NULL,pvalueCutoff=pvalueCutoff,qvalueCutoff=qvalueCutoff,showTop=showTop,minSetSize=minSetSize,method=method)
+ } else if (enrichType=='cellmarker') { #Not finished.
+ cellMarkerDB=read.table(categoryOrSets,header=T,sep='\t')
+ if (species=='hsa')
+ cellMarkerDB=cellMarkerDB[cellMarkerDB$speciesType=='Human',]
+ if (species=='mmu')
+ cellMarkerDB=cellMarkerDB[cellMarkerDB$speciesType=='Mouse',]
+ cellMarkerDB$cellIdentity=paste(cellMarkerDB$speciesType,cellMarkerDB$tissueType,cellMarkerDB$cancerType,cellMarkerDB$cellName,sep='_')
+ cellMarkerDB=cellMarkerDB%>%dplyr::select(cellIdentity,geneID)%>%mutate(geneID=strsplit(geneID,', ')) %>% tidyr::unnest()
+ clusterProfile(filePrefix,species,orgDb,markers,universe,idType,'cellmarker',cellMarkerDB,pvalueCutoff=pvalueCutoff,qvalueCutoff=qvalueCutoff,showTop=showTop,minSetSize=minSetSize,method=method)
+ } else if (enrichType=='msigdb') {
+ if (categoryOrSets=='ALL')
+ categoryOrSets=NULL
+ if (idType=='SYMBOL') {
+ term2Gene=msigdbr(species=ifelse(species=='hsa','Homo sapiens','Mus musculus'),category=categoryOrSets)%>%dplyr::select(gs_cat,gs_name,gene_symbol)
+ } else if (idType=='ENSEMBL') {
+ term2Gene=msigdbr(species=ifelse(species=='hsa','Homo sapiens','Mus musculus'),category=categoryOrSets)%>%dplyr::select(gs_cat,gs_name,ensembl_gene)
+ } else if (idType=='ENTREZID'||idType=='KEGG') {
+ term2Gene=msigdbr(species=ifelse(species=='hsa','Homo sapiens','Mus musculus'),category=categoryOrSets)%>%dplyr::select(gs_cat,gs_name,entrez_gene)
+ } else {
+ genes=try(bitr(markers$gene,fromType=idType,toType='SYMBOL',OrgDb=orgDb,drop=F))
+ if (class(genes)!='try-error'&&dim(genes)[1]>2) {
+ markers=merge(markers,genes,by.x='gene',by.y=idType)
+ colnames(markers)[1]=idType
+ colnames(markers)[dim(markers)[2]]='gene'
+ genes=try(bitr(universe,fromType=idType,toType='SYMBOL',OrgDb=orgDb,drop=F))
+ if (class(genes)!='try-error'&&dim(genes)[1]>2)
+ universe=as.character(genes$SYMBOL)
+ }
+ idType='SYMBOL'
+ term2Gene=msigdbr(species=ifelse(species=='hsa','Homo sapiens','Mus musculus'),category=categoryOrSets)%>%dplyr::select(gs_cat,gs_name,gene_symbol)
+ }
+ term2Gene$gs_name=paste0(term2Gene$gs_cat,'_',term2Gene$gs_name)
+ term2Gene$gs_cat=NULL
+ if (method=='ORA') {
+ enrichTable=try(compareCluster(gene~cluster,fun="enricher",data=markers,universe=universe,TERM2GENE=term2Gene,TERM2NAME=NA,pvalueCutoff=pvalueCutoff,qvalueCutoff=qvalueCutoff,maxGSSize=1000,minGSSize=minSetSize))
+ if (class(enrichTable)!='try-error'&&dim(enrichTable)[1]>0&&is.null(categoryOrSets)) {
+ p=NULL
+ for (mc in c('H','C1','C2','C3','C4','C5','C6','C7','C8')) {
+ temp=enrichTable%>%filter(grepl(paste0('^',mc,'_'),Description))
+ if (dim(temp)[1]>0) {
+ temp=temp%>%arrange(qvalue,-Count)
+ p[[mc]]=dotplot(temp,showCategory=showTop)+ggtitle(paste0('Enriched MSigDB ',mc,' Terms of Markers'))
+ }
+ }
+ ggsave(paste0(filePrefix,'_by_Categories.pdf'),wrap_plots(p,ncol=1,nrow=length(p)),height=min(40,length(p)*10),width=20)
+ }
+ }
+ clusterProfile(filePrefix,species,orgDb,markers,universe,idType,'msigdb',term2Gene,pvalueCutoff=pvalueCutoff,qvalueCutoff=qvalueCutoff,showTop=showTop,minSetSize=minSetSize,method=method)
+ } else if (enrichType=='customized') {
+ categoryOrSets=read.gmt(categoryOrSets)
+ clusterProfile(filePrefix,species,orgDb,markers,universe,idType,'customized',categoryOrSets,pvalueCutoff=pvalueCutoff,qvalueCutoff=qvalueCutoff,showTop=showTop,minSetSize=minSetSize,method=method)
+ }
+}
+##########################################################
+
+#############################Begin clusterProfiler_EA()#############################
+clusterProfiler_EA=function(filePrefix,eaFeatures,refFeatures=NULL,idType='symbol',dbType='go-all',species='mouse',eaFile=NA,method='ORA',showTop=10) { #eaFeatures is a list of genes with or without log fold changes.
+#idType: symbol|uniprot|entrezid|ensembl|kegg
+#dbType: kegg|go-all|go-bp|go-cc|go-mf|msigdb-all|h|c1-c8|customized
+message(paste0('##########Begin clusterProfiler-',method,' Analysis.##########'))
+ eaFeatures$gene=rownames(eaFeatures)
+ eaFeatures$cluster=NA
+ dbType=strsplit(dbType,'-')[[1]]
+ if (method=='QEA')
+ refFeatures=NULL
+ if (dbType[1]=='customized') {
+ if (!is.na(eaFile)&&file.exists(eaFile))
+ saveClusterProfiles(filePrefix,eaFeatures,refFeatures,toupper(idType),species,enrichType=dbType[1],categoryOrSets=eaFile,pvalueCutoff=0.05,qvalueCutoff=0.05,showTop=showTop,minSetSize=3,method=method)
+ else
+ stop('Please supply a valid eaFile for the customized enrichment analysis.')
+ } else {
+ saveClusterProfiles(filePrefix,eaFeatures,refFeatures,toupper(idType),species,enrichType=dbType[1],categoryOrSets=toupper(dbType[2]),pvalueCutoff=0.05,qvalueCutoff=0.05,showTop=showTop,minSetSize=3,method=method)
+ }
+message(paste0('##########End clusterProfiler-',method,' Analysis.##########'))
+}
+#############################End clusterProfiler_EA()#############################
+
diff --git a/V2.2/ODA/constants.R b/V2.2/ODA/constants.R
new file mode 100644
index 0000000000000000000000000000000000000000..fac5530de9470e65acda53768ba7f51bb841a006
--- /dev/null
+++ b/V2.2/ODA/constants.R
@@ -0,0 +1,72 @@
+####################################Begin Global Constants#####################################
+DEBUGGING=F
+VERSION='V2.2'
+METABOANALYST='MetaboAnalyst_3.0.3'
+YES_NO=c('yes','no')
+YES='yes'
+NO='no'
+COMMON_NORMS=c('no','rle','bysize','bymedian','byupperquantile','bysum','byquantile')
+COMMON_TESTS=c('no','glm','cpglm','student\'s t/one-way anova','welch\'s t/one-way anova','nonparametric t/one-way anova')
+COMMON_IMPUTATIONS=c('half minimum','value filter','mean','median','no','na')
+METABOLOMICS_IDS=c('hmdb','kegg','name','other')
+GENE_IDS=c('symbol','ensembl','entrezid','other')
+PROTEIN_IDS=c('uniprot','ensembl','other')
+GSEA_DBS=c('no','kegg','go-all','go-bp','go-cc','go-mf','msigdb-all','msigdb-h','msigdb-c1','msigdb-c2','msigdb-c3','msigdb-c4','msigdb-c5','msigdb-c6','msigdb-c7','msigdb-c8','customized')
+VALID_OPTIONS=list(
+ experiment=c('metabolomics','rna_seq','proteomics','microarray','other'),
+ species=c('mouse','human','other'),
+ dataFormat=c('list','table','table with feature description'),
+ groupCountFilter=3,
+ pCutoffs=0.05,
+ fcCutoffs=2,
+ logOffset='',
+ visual=YES_NO,
+ volcanoP=c('adjusted p-value','raw p-value'),
+ hclustSamples=YES_NO,
+ hclusterFeatures=YES_NO,
+ heatmapColors=c('red and blue','red and green','black and white'),
+ pcaLabels=YES_NO,
+ pcaEllipses=YES_NO,
+ scaling=YES_NO,
+ metabolomics=list(
+ featureType=c('metabolite','lipid','other'),
+ idType=METABOLOMICS_IDS,
+ normalization=COMMON_NORMS,
+ logTransform=YES_NO,
+ statTest=COMMON_TESTS,
+ dataImputation=COMMON_IMPUTATIONS,
+ eaDB_metabolite=c('no','smpdb_pathway','kegg_pathway','drug','blood','urine','csf','fecal','super_class','main_class','sub_class','snp','predicted','location','customized'),
+ eaDB_lipid=c('no','super_class','main_class','sub_class','snp','customized')
+ ),
+ RNA_seq=list(
+ featureType=c('gene','transcript','other'),
+ idType=GENE_IDS,
+ normalization=c('no','deseq2'),
+ logTransform=YES_NO,
+ statTest=c('no','deseq2'),
+ dataImputation=NO,
+ eaDB=GSEA_DBS
+ ),
+ Proteomics=list(
+ featureType=c('protein','other'),
+ idType=PROTEIN_IDS,
+ normalization=COMMON_NORMS,
+ logTransform=YES_NO,
+ statTest=COMMON_TESTS,
+ dataImputation=COMMON_IMPUTATIONS,
+ eaDB=GSEA_DBS
+ ),
+ Microarray=list(
+ featureType=c('gene','probe','other'),
+ idType_gene=GENE_IDS,
+ idType_probe='name',
+ normalization=COMMON_NORMS,
+ logTransform=YES_NO,
+ statTest=COMMON_TESTS,
+ dataImputation=COMMON_IMPUTATIONS,
+ eaDB=GSEA_DBS
+ )
+)
+COMPARISON_TYPES=c('group1 vs. group2','group1 vs. others','all combinations','overall')
+####################################End Global Constants#####################################
+
diff --git a/V2.2/ODA/getData.R b/V2.2/ODA/getData.R
new file mode 100644
index 0000000000000000000000000000000000000000..bc0cf01d57f70c779fb864326e2419f20c09961b
--- /dev/null
+++ b/V2.2/ODA/getData.R
@@ -0,0 +1,188 @@
+#############################Begin Source Files#############################
+initial.options=commandArgs(trailingOnly=F)
+scriptPath=file.path(dirname(sub("--file=","",initial.options[grep("--file=",initial.options)])))
+if (length(scriptPath)==0)
+ scriptPath='.'
+source(file.path(scriptPath,'libraries.R'))
+#############################End Source Files#############################
+
+#############################Begin getData()#############################
+getData=function(inputFile,samples,features,parameters) {
+ message('Reading data ...')
+ featureDescription=NULL
+ if (parameters$dataFormat=='list') {
+ rawDataList=read.xlsx(inputFile,sheet='RawData',colNames=T)[,c(1,2,5)]
+ if (dim(rawDataList)[1]==0||is.null(rawDataList)) {
+ message('Data sheet is empty.')
+ return(NULL)
+ }
+ } else if (parameters$dataFormat=='table') {
+ rawDataTable=read.xlsx(inputFile,sheet='RawData',colNames=T,rowNames=F)
+ if (dim(rawDataTable)[1]==0||is.null(rawDataTable)) {
+ message('Data sheet is empty.')
+ return(NULL)
+ }
+ rawDataList=reshape2::melt(rawDataTable,id.vars=1)
+ rawDataList[,2]=as.character(rawDataList[,2])
+ rawDataList[,3]=as.numeric(rawDataList[,3])
+ } else if (parameters$dataFormat=='table with feature description') {
+ rawDataTable=read.xlsx(inputFile,sheet='RawData',colNames=T,rowNames=F)
+ if (dim(rawDataTable)[1]==0||is.null(rawDataTable)) {
+ message('Data sheet is empty.')
+ return(NULL)
+ }
+ featureDescription=rawDataTable[,1:2]
+ rawDataTable=rawDataTable[,-2]
+ rawDataList=reshape2::melt(rawDataTable,id.vars=1)
+ rawDataList[,2]=as.character(rawDataList[,2])
+ rawDataList[,3]=as.numeric(rawDataList[,3])
+ } else {
+ stop('Only list, table, and table with description are supported data formats. Check your Parameters sheet.')
+ }
+ colnames(rawDataList)=c('Feature','Sample','Value')
+ if (sum(is.na(rawDataList$Feature))>0) {
+ message('Empty feature IDs detected and lines removed. If you do not want to remove those lines please fix those IDs.')
+ rawDataList=rawDataList[!is.na(rawDataList$Feature),]
+ }
+ features$interested=features$interested[features$interested %in% rawDataList$Feature]
+ features$excluded=features$excluded[features$excluded %in% rawDataList$Feature]
+ if (!is.null(features$excluded))
+ rawDataList=rawDataList[!(rawDataList$Feature %in% features$excluded),] #If speficied, features are excluded.
+ rawDataList=rawDataList[!is.na(samples[rawDataList$Sample,1]),] #Samples with empty group IDs are excluded.
+ if (sum(is.na(rawDataList$Value)))
+ message('Missing values are detected.')
+ #rawDataList[is.na(rawDataList$Value),'Value']=0
+ if(sum(rawDataList$Value<0,na.rm=T)&&(parameters$normalization!='no'||parameters$logTransform))
+ stop('Negative value(s) are not allowed when you normalize or log-transform your data.')
+ #The following code is to generate automatic feature IDs in case they are not unique.
+ if (length(unique(rawDataList$Feature))*length(unique(rawDataList$Sample))!=dim(rawDataList)[1]) {
+ rowNames=rawDataList$Feature
+ ind=data.frame()
+ for (i in 1:dim(rawDataList)[1]) {
+ r=which(rownames(ind)==rawDataList$Feature[i])
+ c=which(colnames(ind)==rawDataList$Sample[i])
+ if (is.na(r==0||c==0)||is.na(ind[r,c])) {
+
+ ind[rawDataList$Feature[i],rawDataList$Sample[i]]=1
+ } else {
+ #Currently the auto-ID function is disabled so that problems caused by mistakes are not ignored. If preferred, comment the following line to enable this function.
+ stop(paste0('Duplicated feature or sample name(s) found at (row ',r,', column ',c,'). Please check your data.'))
+ rowNames[i]=paste0(rowNames[i],'.',ind[r,c])
+ ind[r,c]=ind[r,c]+1
+ }
+ }
+ rawDataList$Feature=rowNames #In case there are duplicated feature names, they are replaced by name.1, name.2, and so on.
+ }
+
+ rawDataList[,colnames(samples)]=samples[rawDataList$Sample,]
+ rawDataList$Feature=factor(rawDataList$Feature,levels=unique(rawDataList$Feature))
+ rawDataList$BatchID=factor(rawDataList$BatchID,levels=unique(rawDataList$BatchID))
+ rawDataList$GroupID=factor(rawDataList$GroupID,levels=unique(rawDataList$GroupID))
+ rawDataList$SubjectID=factor(rawDataList$SubjectID,levels=unique(rawDataList$SubjectID))
+ rawDataList=aggregate(Value~Feature+BatchID+GroupID+SubjectID,FUN=mean,data=rawDataList) #Data are stored in a list. Technical replicates are averaged if present.
+ rawDataList$Sample=paste(rawDataList$BatchID,rawDataList$GroupID,rawDataList$SubjectID,sep='_')
+ rawDataTable=reshape2::dcast(rawDataList,Feature~BatchID+GroupID+SubjectID,value.var='Value') #Data are also stored in a table with features in rows and samples in columns.
+ if (sum(!is.na(samples$Size)))
+ samples=aggregate(Size~BatchID+GroupID+SubjectID,FUN=mean,data=samples)
+ else
+ samples=unique(samples) #Bug fix: added the if lines above on 12/14/2021, so that sizes are averaged for technical replicates.
+ samples$ID=rownames(samples)
+ rownames(samples)=paste(samples$BatchID,samples$GroupID,samples$SubjectID,sep='_')
+ rownames(rawDataTable)=rawDataTable[,1]
+ rawDataTable=rawDataTable[,-1]
+ rawDataTable=as.matrix(rawDataTable)
+ class(rawDataTable)='numeric'
+ samples=samples[colnames(rawDataTable),]
+ if (!is.null(featureDescription)) {
+ colnames(featureDescription)=c('ID','Description')
+ rownames(featureDescription)=featureDescription[,1]
+ featureDescription=featureDescription[rownames(featureDescription)%in%rownames(rawDataTable),]
+ featureDescription=featureDescription[rownames(rawDataTable),-1,drop=F]
+ }
+
+ attributes=NULL
+ attributes$nSamples=dim(rawDataTable)[2] #Bug fixed on 8/5/19.
+ attributes$nFeatures=dim(rawDataTable)[1]
+ attributes$groups=levels(samples$GroupID)
+ attributes$nGroups=length(attributes$groups)
+ attributes$nSubjects=length(levels(samples$SubjectID))
+ attributes$nBatches=length(levels(samples$BatchID))
+ if (parameters$statTest=='glm'||parameters$statTest=='cpglm'||parameters$statTest=='deseq2') { #DESeq2 was added on 10/3/24.
+ if (parameters$formulaStr=='') {
+ attributes$formulaStr='Value'
+ if (attributes$nGroups>1) {
+ if (attributes$formulaStr=='Value')
+ attributes$formulaStr=paste(attributes$formulaStr,'GroupID',sep='~')
+ else
+ attributes$formulaStr=paste(attributes$formulaStr,'GroupID',sep='+')
+ }
+ if (attributes$nBatches>1) {
+ if (attributes$formulaStr=='Value')
+ attributes$formulaStr=paste(attributes$formulaStr,'BatchID',sep='~')
+ else
+ attributes$formulaStr=paste(attributes$formulaStr,'BatchID',sep='+')
+ }
+ if (attributes$nSubjects>1&&attributes$nSubjects<attributes$nSamples) {
+ if (attributes$formulaStr=='Value') {
+ if (parameters$statTest=='deseq2')
+ attributes$formulaStr=paste(attributes$formulaStr,'SubjectID',sep='~')
+ else
+ attributes$formulaStr=paste(attributes$formulaStr,'(1|SubjectID)',sep='~')
+ } else {
+ if (parameters$statTest=='deseq2')
+ attributes$formulaStr=paste(attributes$formulaStr,'SubjectID',sep='+')
+ else
+ attributes$formulaStr=paste(attributes$formulaStr,'(1|SubjectID)',sep='+')
+ }
+ }
+ } else {
+ attributes$formulaStr=parameters$formulaStr #For DESeq2, GroupID must be the last variable in the formula.
+ }
+ }
+ if (parameters$statTest=='glm'||parameters$statTest=='cpglm') {
+ if (parameters$familyStr=='') {
+ if (parameters$statTest=='glm') {
+ attributes$familyStr='gaussian(link=\'identity\')'
+ } else if (parameters$statTest=='cpglm') {
+ attributes$familyStr='identity'
+ }
+ } else {
+ attributes$familyStr=parameters$familyStr
+ }
+ }
+ presentSamples=(rawDataTable>parameters$valueFilter)
+ presentSamples[presentSamples]=1
+ presentSamples[!presentSamples]=0
+ presentSamples[is.na(presentSamples)]=0 #Bug fix: this line added on 12/14/2021.
+ sampleSummary=as.data.frame(colSums(presentSamples,na.rm=T),drop=F) #Bug fix: na.rm=T added on 12/14/2021.
+ names(sampleSummary)='nFeatures'
+ presentGroups=matrix(nrow=attributes$nFeatures,ncol=attributes$nGroups)
+ colnames(presentGroups)=attributes$groups
+ rownames(presentGroups)=rownames(rawDataTable)
+ groupSummary=matrix(nrow=attributes$nGroups,ncol=2)
+ colnames(groupSummary)=c('nSamples','nFeatures')
+ rownames(groupSummary)=attributes$groups
+ for (i in attributes$groups) {
+ presentGroups[,i]=rowSums(presentSamples[,samples$GroupID==i,drop=F],na.rm=T)
+ groupSummary[i,1]=sum(samples$GroupID==i)
+ }
+ temp=presentGroups>=parameters$groupCountFilter
+ groupSummary[,2]=colSums(temp,na.rm=T) #Bug fix: na.rm=T added on 12/14/2021.
+ presentGroups=cbind(rowSums(temp,na.rm=T),presentGroups) #Bug fix: na.rm=T added on 12/14/2021.
+ colnames(presentGroups)[1]='Present'
+ presentSamples=cbind(rowSums(presentSamples,na.rm=T),presentSamples) #Bug fix: na.rm=T added on 12/14/2021.
+ colnames(presentSamples)[1]='Present'
+ attributes$nFeaturesPresentInAnySample=sum(presentSamples[,'Present']>0,na.rm=T) #Bug fix: na.rm=T added on 12/14/2021.
+ attributes$nFeaturesPresentInAnyGroup=sum(presentGroups[,'Present']>0,na.rm=T) #Bug fix: na.rm=T added on 12/14/2021.
+ if (!attributes$nFeaturesPresentInAnySample)
+ stop('No features are present in at least one sample! Consider decreasing the valueFilter threshold.')
+ if (!attributes$nFeaturesPresentInAnyGroup)
+ stop('No features are present in at least one group! Consider decreasing the groupCountFilter threshold.')
+ message(paste0(attributes$nFeaturesPresentInAnySample,' features are present in at least one sample. If the number is low, consider decreasing the valueFilter threshold.'))
+ message(paste0(attributes$nFeaturesPresentInAnyGroup,' features are present in at least one group. If the number is low, consider decreasing the groupCountFilter threshold.'))
+ message('Finished reading data.')
+
+ return(list(rawDataList=rawDataList,rawDataTable=rawDataTable,featureDescription=featureDescription,samples=samples,presentSamples=presentSamples,sampleSummary=sampleSummary,presentGroups=presentGroups,groupSummary=groupSummary,attributes=attributes,features=features))
+}
+#############################End getData()#############################
+
diff --git a/V2.2/ODA/getSettings.R b/V2.2/ODA/getSettings.R
new file mode 100755
index 0000000000000000000000000000000000000000..89ddc9d89e5c4fbfe5c86f45214a7da6cae1e66d
--- /dev/null
+++ b/V2.2/ODA/getSettings.R
@@ -0,0 +1,305 @@
+#############################Begin Source Files#############################
+initial.options=commandArgs(trailingOnly=F)
+scriptPath=file.path(dirname(sub("--file=","",initial.options[grep("--file=",initial.options)])))
+if (length(scriptPath)==0)
+ scriptPath='.'
+source(file.path(scriptPath,'libraries.R'))
+#############################End Source Files#############################
+
+#############################Begin Local Constants#############################
+COLOR_PALETTES=list('red and blue'=colorRampPalette(c('blue','white','red'))(256),'red and green'=colorRampPalette(c('green','black','red'))(256),'black and white'=gray.colors(256,0,1))
+LOGIC_OPTIONS=c('yes'=T,'no'=F)
+#############################End Local Constants#############################
+
+#############################Begin Default Parameters#############################
+#Below are default parameter settings. DO NOT change them here.
+#Use the data_template.xlsx file accompanying this program to generate your input data. All the parameters can be changed using the spreadsheets. Please read the instructions there.
+ EXPERIMENT='metabolomics'
+ SPECIES='mouse'
+ FEATURE_TYPE='metabolite' #Added on 3/17/2021.
+ ID_TYPE='hmdb' #Added on 3/17/2021.
+ DATA_FORMAT='table with feature description' #Available options: list; table; table with feature description.
+ VALUE_FILTER=0 #A cutoff-value used to count the number of features in a sample. If feature value <= valueFilter, the feature is taken as absent from the sample.
+ GROUP_COUNT_FILTER=3 #A cutoff-value used to count the number of features in a group. If the number of samples < groupCountFilter for a feature, the feature is taken as absent from the group.
+ GROUP_MEAN_LOWER_BOUND='' #A cutoff-value used as group mean when it's lower than the cutoff. This is for the adjustment of fold change when a group has a very low mean value.
+ P_CUTOFFS=0.05 #P-value cutoff for the differential expression (DE) analysis. Multiple values are allowed.
+ FC_CUTOFFS=2 #Fold change cutoff for the DE analysis. Multiple values are allowed.
+ NORMALIZATION='rle' #Available options: No; RLE; BySize; ByMedian; BySum; ByUpperQuantile.
+ UQ_PROB=0.75 #If normalization=ByUpperQuantile, this value is used as the quantile cutoff.
+ LOG_TRANSFORM=T #Whether to log2-transform the data for statistical tests.
+ LOG_OFFSET='' #An offset-value added to the data before the log-transformation. Devault value is to be determined later.
+ STAT_TEST='glm' #Statistical test method for DE. Available options: t-test; cpglm-glm; glm.
+ DATA_IMPUTATION='half minimum' #Method to impute missing values and those less than or equal to the value filter. It affects statistical tests but not visualizations. See data template for details.
+ VISUAL=T #Whether to visualize data using graphs.
+ VOLCANO_P='adjusted p-value' #Which p-value as the y-axis of volcano plots.
+ HCLUSTER_SAMPLES=T #Whether to cluster samples on the heatmap.
+ HCLUSTER_FEATURES=T #Whether to cluster features on the heatmap.
+ DRP_LABELS=T
+ DRP_ELLIPSES=T
+ HEATMAP_COLORS=COLOR_PALETTES[['red and blue']]
+ SCALING=T #Added on 3/17/2021.
+ EA_DB='kegg_pathway' #Added on 3/17/2021.
+ JOINT_PA='metab_integ' #Added on 7/21/2021.
+ EA_SHOW_TOP=10 #Added on 10/24/2024.
+ COR_METHOD='pearson' #Added on 10/5/2024.
+ DRP_METHOD='pca' #Added on 10/7/2024.
+#############################End Default Parameters#############################
+
+#############################Begin getSamples()#############################
+getSamples=function(inputFile) {
+ message('Reading samples sheet ...')
+ sheetNames=getSheetNames(inputFile)
+ if ('Samples' %in% sheetNames) {
+ samples=read.xlsx(inputFile,sheet='Samples',colNames=T,rowNames=T,skipEmptyRows=T,skipEmptyCols=T,cols=c(1:5))
+ if (dim(samples)[1]==0||is.null(samples)) {
+ message('Samples sheet is empty.')
+ return(NULL)
+ }
+ if (!is.null(samples)&&dim(samples)[1]>0) {
+ for (i in 1:dim(samples)[1])
+ if (grepl('\\s',rownames(samples)[i]))
+ stop(paste0('Sample ',i,': ',rownames(samples)[i],' has white space(s). Please remove them.'))
+ samples=samples[!is.na(samples[,1]),1:4] #Excluding samples without group ID.
+ }
+ nSamples=dim(samples)[1]
+ if (nSamples<2)
+ stop('At least 2 samples should have group IDs.')
+ if (sum(!is.na(samples[,2]))==0) #No biological replicate IDs. Automatic IDs will be generated.
+ samples[,2]=c(1:nSamples)
+ else if (sum(!is.na(samples[,2]))!=nSamples)
+ stop('If you provide biological replicate IDs, they should be present for all samples.')
+ if (sum(!is.na(samples[,3]))==0) #No batch IDs. Automatic IDs will be generated.
+ samples[,3]='Batch1'
+ else if (sum(!is.na(samples[,3]))!=nSamples)
+ stop('If you provide batch IDs, they should be present for all samples.')
+ if (sum(!is.na(samples[,4]))&&sum(!is.na(samples[,4]))!=nSamples)
+ stop('If you provide size factors, they should be present for all samples.')
+ samples[,1]=as.factor(samples[,1])
+ samples[,2]=as.factor(samples[,2])
+ samples[,3]=as.factor(samples[,3])
+ samples[,4]=as.numeric(samples[,4])
+ } else
+ stop('Samples sheet is missing.')
+ message('Finished reading samples sheet.')
+ return(samples)
+}
+#############################End getSamples()#############################
+
+#############################Begin getFeatures()#############################
+getFeatures=function(inputFile) {
+ message('Reading features sheet ...')
+ sheetNames=getSheetNames(inputFile)
+ if ('Features' %in% sheetNames) {
+ tempFeatures=read.xlsx(inputFile,sheet='Features',colNames=T,rowNames=F,startRow=3,cols=c(1:8))
+ if (dim(tempFeatures)[1]==0||is.null(tempFeatures)) {
+ message('Features sheet is empty.')
+ return(NULL)
+ }
+ interested=tempFeatures[!is.na(tempFeatures[,1]),1]
+ if (length(interested)==0)
+ interested=NULL
+ excluded=tempFeatures[!is.na(tempFeatures[,2]),2]
+ if (length(excluded)==0)
+ excluded=NULL
+ eaFeatures=tempFeatures[!is.na(tempFeatures[,3]),3:4,drop=F]
+ if (dim(eaFeatures)[1]==0)
+ eaFeatures=NULL
+ refFeatures=tempFeatures[!is.na(tempFeatures[,5]),5,drop=F]
+ names(refFeatures)=tolower(sub('Background_','',colnames(tempFeatures)[5]))
+ if (dim(refFeatures)[1]==0)
+ refFeatures=NULL
+ eaGenes=tempFeatures[!is.na(tempFeatures[,6]),6:7,drop=F]
+ if (dim(eaGenes)[1]==0)
+ eaGenes=NULL
+ refGenes=tempFeatures[!is.na(tempFeatures[,8]),8,drop=F]
+ names(refGenes)=tolower(sub('Background_','',colnames(tempFeatures)[8]))
+ if (dim(refGenes)[1]==0)
+ refGenes=NULL
+# if ((!is.null(eaFeatures)&&is.null(eaGenes))||(is.null(eaFeatures)&&!is.null(eaGenes)))
+# stop('Both joint metabolites and joint genes must be present.')
+ if (!is.null(eaFeatures)&&sum(is.na(eaFeatures[,2]))>0&&sum(is.na(eaFeatures[,2]))<dim(eaFeatures)[1])
+ warning('Empty fold changes are replaced by zeros for the eaFeatures.')
+ if (!is.null(eaFeatures))
+ eaFeatures[is.na(eaFeatures[,2]),2]=0
+ if (!is.null(eaFeatures)) {
+ rownames(eaFeatures)=eaFeatures[,1]
+ eaFeatures=eaFeatures[,-1,drop=F]
+ }
+ if (!is.null(eaGenes)&&sum(is.na(eaGenes[,2]))>0&&sum(is.na(eaGenes[,2]))<dim(eaGenes)[1])
+ warning('Empty fold changes are replaced by zeros for the eaGenes.')
+ if (!is.null(eaGenes))
+ eaGenes[is.na(eaGenes[,2]),2]=0
+ if (!is.null(eaGenes)) {
+ rownames(eaGenes)=eaGenes[,1]
+ eaGenes=eaGenes[,-1,drop=F]
+ }
+ } else
+ stop('Features sheet is missing.')
+ message('Finished reading features sheet.')
+ return(list(interested=interested,excluded=excluded,eaFeatures=eaFeatures,eaGenes=eaGenes,refFeatures=refFeatures,refGenes=refGenes,eaFeatureIDType=tolower(sub('^.*_','',colnames(tempFeatures)[3])),eaGeneIDType=tolower(sub('Gene_','',colnames(tempFeatures)[6]))))
+}
+#############################End getFeatures()#############################
+
+#############################Begin getPamameters()#############################
+getParameters=function(inputFile) {
+ message('Reading parameters sheet ...')
+ sheetNames=getSheetNames(inputFile)
+ if ('Parameters' %in% sheetNames) {
+ if (read.xlsx(inputFile,sheet='Parameters',colNames=F,rows=4,cols=1,startRow=4)!=VERSION)
+ stop(paste0('Please use data template ',version,' for this analysis.'))
+ paramTable=read.xlsx(inputFile,sheet='Parameters',colNames=T,rowNames=T,startRow=4,na.strings=NULL)
+ if (dim(paramTable)[1]==0||is.null(paramTable)) {
+ message('Parameters sheet is empty.')
+ return(NULL)
+ }
+ parameters=c(odaVersion=VERSION,setNames(as.list(tolower(paramTable$Value)),rownames(paramTable)))
+ if (is.na(parameters$experiment)||is.null(parameters$experiment))
+ parameters$experiment=EXPERIMENT
+ if (is.na(parameters$species)||is.null(parameters$species))
+ parameters$species=SPECIES
+ if (is.na(parameters$featureType)||is.null(parameters$featureType))
+ parameters$featureType=FEATURE_TYPE
+ if (is.na(parameters$idType)||is.null(parameters$idType))
+ parameters$idType=ID_TYPE
+ if (is.na(parameters$dataFormat)||is.null(parameters$dataFormat))
+ parameters$dataFormat=DATA_FORMAT
+# parameters$valueFilter=0#Disabled on 7/5/2021.
+ parameters$valueFilter=ifelse(is.na(parameters$valueFilter)||is.null(parameters$valueFilter),VALUE_FILTER,as.numeric(parameters$valueFilter))
+ parameters$groupCountFilter=ifelse(is.na(parameters$groupCountFilter)||is.null(parameters$groupCountFilter),GROUP_COUNT_FILTER,as.integer(parameters$groupCountFilter))
+# parameters$groupMeanLowerBound=ifelse(is.na(parameters$groupMeanLowerBound)||is.null(parameters$groupMeanLowerBound),GROUP_MEAN_LOWER_BOUND,as.numeric(parameters$groupMeanLowerBound))
+#Disabled on 3/15/2021. Now it's always the default value determined after the normalization and transformation step.
+ parameters$groupMeanLowerBound=-Inf
+ parameters$pCutoffs=as.numeric(paramTable['pCutoffs',2:dim(paramTable)[2]])
+ if (sum(!is.na(parameters$pCutoffs)))
+ parameters$pCutoffs=parameters$pCutoffs[!is.na(parameters$pCutoffs)]
+ else
+ parameters$pCutoffs=P_CUTOFFS
+ parameters$fcCutoffs=as.numeric(paramTable['fcCutoffs',2:dim(paramTable)[2]])
+ if(sum(!is.na(parameters$fcCutoffs)))
+ parameters$fcCutoffs=parameters$fcCutoffs[!is.na(parameters$fcCutoffs)]
+ else
+ parameters$fcCutoffs=FC_CUTOFFS
+ if (is.na(parameters$normalization)||is.null(parameters$normalization))
+ parameters$normalization=NORMALIZATION
+ parameters$uqProb=ifelse(is.na(paramTable['normalization',3])||is.null(paramTable['normalization',3]),UQ_PROB,as.numeric(paramTable['normalization',3]))
+ parameters$logTransform=ifelse(is.na(parameters$logTransform)||is.null(parameters$logTransform),LOG_TRANSFORM,LOGIC_OPTIONS[parameters$logTransform])
+ parameters$logOffset=ifelse(is.na(parameters$logOffset)||is.null(parameters$logOffset)||(as.numeric(parameters$logOffset)<0),LOG_OFFSET,as.numeric(parameters$logOffset))
+ if (is.na(parameters$statTest)||is.null(parameters$statTest))
+ parameters$statTest=STAT_TEST
+ if ((parameters$normalization=='deseq2'&¶meters$statTest!='deseq2')||(parameters$normalization!='deseq2'&¶meters$statTest=='deseq2')) #Added by ZZY on 10/4/24.
+ stop('Normalization and stat test method must both be DESeq2.')
+ if (is.na(parameters$formulaStr)||is.null(parameters$formulaStr))
+ parameters$formulaStr=''
+ else
+ parameters$formulaStr=paramTable['formulaStr',2]
+ if (is.na(parameters$familyStr)||is.null(parameters$familyStr))
+ parameters$familyStr=''
+ else
+ parameters$familyStr=paramTable['familyStr',2]
+ if (is.na(parameters$dataImputation)||is.null(parameters$dataImputation))
+ parameters$dataImputation=DATA_IMPUTATION
+ parameters$visual=ifelse(is.na(parameters$visual)||is.null(parameters$visual),VISUAL,LOGIC_OPTIONS[parameters$visual])
+ if (is.na(parameters$volcanoP)||is.null(parameters$volcanoP))
+ parameters$volcanoP=VOLCANO_P
+ parameters$hclustSamples=ifelse(is.na(parameters$hclustSamples)||is.null(parameters$hclustSamples),HCLUST_SAMPLES,LOGIC_OPTIONS[parameters$hclustSamples])
+ parameters$hclustFeatures=ifelse(is.na(parameters$hclustFeatures)||is.null(parameters$hclustFeatures),HCLUS_FEATURES,LOGIC_OPTIONS[parameters$hclustFeatures])
+ if (is.na(parameters$heatmapColors)||is.null(parameters$heatmapColors)) {
+ parameters$heatmapColorsStr='red and blue'
+ parameters$heatmapColors=HEATMAP_COLORS
+ } else {
+ parameters$heatmapColorsStr=parameters$heatmapColors
+ parameters$heatmapColors=COLOR_PALETTES[[parameters$heatmapColors]]
+ }
+ parameters$drpLabels=ifelse(is.na(parameters$drpLabels)||is.null(parameters$drpLabels),DRP_LABELS,LOGIC_OPTIONS[parameters$drpLabels])
+ parameters$drpEllipses=ifelse(is.na(parameters$drpEllipses)||is.null(parameters$drpEllipses),DRP_ELLIPSES,LOGIC_OPTIONS[parameters$drpEllipses])
+ parameters$scaling=ifelse(is.na(parameters$scaling)||is.null(parameters$scaling),SCALING,LOGIC_OPTIONS[parameters$scaling])
+ if (!is.na(paramTable['eaName','Value'])&&!is.null(paramTable['eaName','Value']))
+ parameters$eaName=paramTable['eaName','Value']
+ else
+ parameters$eaName=''
+ if (!is.na(paramTable['eaFile','Value'])&&!is.null(paramTable['eaFile','Value']))
+ parameters$eaFile=paramTable['eaFile','Value']
+ else
+ parameters$eaFile=NA
+ if (is.na(parameters$eaDB)||is.null(parameters$eaDB))
+ parameters$eaDB=EA_DB
+ if (parameters$eaDB=='customized'&&is.na(parameters$eaFile))
+ stop('eaFile cannot be blank when eaDB is \"Customized\".')
+ if (parameters$eaDB=='customized'&&!is.na(parameters$eaFile)&&!file.exists(parameters$eaFile))
+ stop('eaDB is \"Customized\" but eaFile does not exist.')
+ if (is.na(parameters$jointPA)||is.null(parameters$jointPA))
+ parameters$jointPA=JOINT_PA
+ parameters$eaShowTop=ifelse(is.na(parameters$eaShowTop)||is.null(parameters$eaShowTop),EA_SHOW_TOP,as.integer(parameters$eaShowTop))
+ if (is.na(parameters$corMethod)||is.null(parameters$corMethod)) #Added on 10/5/2024.
+ parameters$corMethod=COR_METHOD
+ if (is.na(parameters$drpMethod)||is.null(parameters$drpMethod)) #Added on 10/7/2024.
+ parameters$drpMethod=DRP_METHOD
+ } else
+ stop('Parameters sheet is missing.')
+ message('Finished reading parameters sheet.')
+ return(parameters)
+}
+#############################End getPamameters()#############################
+
+#############################Begin getComparisons()#############################
+getComparisons=function(inputFile) {
+ message('Reading comparisons sheet ...')
+ comparisons=NULL
+ sheetNames=getSheetNames(inputFile)
+ if ('Comparisons' %in% sheetNames) {
+ deTable=read.xlsx(inputFile,sheet='Comparisons',colNames=T,rowNames=F,startRow=4)
+ if (dim(deTable)[1]==0||is.null(deTable)) {
+ message('Comparisons sheet is empty.')
+ return(NULL)
+ }
+ dePairs=NULL
+ deANOVAs=NULL
+ for (i in 1:dim(deTable)[1]) {
+ n=dim(deTable)[2]
+ temp=deTable[i,2:n]
+ temp=as.character(temp[!is.na(temp)])
+ if (length(temp)!=length(unique(temp)))
+ stop(paste0('Comparison ',i,': Group IDs are not unique.'))
+ if (deTable[i,1]=='Group1 vs. Group2')
+ if (sum(is.na(deTable[i,2:3])))
+ stop(paste0('Comparison ',i,': Groups 1 and 2 cannot be empty.'))
+ else
+ dePairs[[paste0('c',i,'_2v3')]]=as.character(deTable[i,2:3])
+ if (deTable[i,1]=='Group1 vs. Others') {
+ if (is.na(deTable[i,2]))
+ stop(paste0('Comparison ',i,': Group1 cannot be empty.'))
+ if (sum(!is.na(deTable[i,3:n]))<2)
+ stop(paste0('Comparison ',i,': At least two other groups should be specified.'))
+ for (j in 3:n)
+ if (!is.na(deTable[i,j]))
+ dePairs[[paste0('c',i,'_2v',j)]]=as.character(deTable[i,c(2,j)])
+ }
+ if ((deTable[i,1]=='All Combinations'||deTable[i,1]=='Overall') && length(temp)<3)
+ stop(paste0('Comparison ',i,': At least three groups should be specified.'))
+ if (deTable[i,1]=='All Combinations')
+ for (j in 2:(n-1))
+ for (k in (j+1):n)
+ if (!sum(is.na(deTable[i,c(j,k)])))
+ dePairs[[paste0('c',i,'_',j,'v',k)]]=as.character(deTable[i,c(j,k)])
+ if (deTable[i,1]=='All Combinations' || deTable[i,1]=='Overall')
+ deANOVAs[[paste0('c',i)]]=temp
+ }
+ if (!is.null(dePairs)) { #Bug fix: order of groups is kept if no duplicated comparisons. 12/14/2021.
+ temp=unique(lapply(dePairs,sort))
+ if (length(temp)<length(dePairs)) #Duplicated comparisons; only one copy is kept.
+ dePairs=temp
+ }
+ if (!is.null(deANOVAs)) { #Bug fix: order of groups is kept if no duplicated comparisons. 12/14/2021.
+ temp=unique(lapply(deANOVAs,sort))
+ if (length(temp)<length(deANOVAs)) #Duplicated comparisons; only one copy is kept.
+ deANOVAs=temp
+ }
+ comparisons$dePairs=dePairs
+ comparisons$deANOVAs=deANOVAs
+ } else
+ stop('Comparisons sheet is missing.')
+ message('Finished reading comparisons sheet.')
+ return(comparisons)
+}
+#############################End getComparisons()#############################
+
diff --git a/V2.2/ODA/libraries.R b/V2.2/ODA/libraries.R
new file mode 100755
index 0000000000000000000000000000000000000000..fb6543ccd55bdf8d10fb59e08235fa9191891baf
--- /dev/null
+++ b/V2.2/ODA/libraries.R
@@ -0,0 +1,123 @@
+#############################Begin Local Constants#############################
+#MY_LIB_PATH='~/R/4.0.2-gccmkl' #Change this to your own library path if necessary, or NULL if no need to customize the path.
+#MY_LIB_PATH=NULL
+#############################End Local Constants#############################
+
+#############################Begin Installing/Loading Libraries#############################
+#if (!is.null(MY_LIB_PATH)) {
+# dir.create(MY_LIB_PATH,recursive=T,showWarnings=F)
+# .libPaths(c(MY_LIB_PATH,.libPaths()))
+#}
+#This program was tested under R version 4.0.2 with the following required libraries. #R version changed from 3.5.1 to 4.0.2 on 8/4/2020.
+if (!requireNamespace("BiocManager", quietly = TRUE))
+ install.packages("BiocManager",repos='https://cran.r-project.org/')
+if (!require(limma)) {
+ BiocManager::install("limma")
+ library(limma)
+}
+if (!require(preprocessCore)) {
+ BiocManager::install("preprocessCore")
+ library(preprocessCore)
+}
+if (!require(globaltest)) {
+ BiocManager::install("globaltest")
+ library(globaltest)
+}
+if (!require(DESeq2)) {
+ BiocManager::install("DESeq2")
+ library(DESeq2)
+}
+if (!require(openxlsx)) {
+ install.packages('openxlsx',repos='https://cran.r-project.org/')
+ library(openxlsx)
+}
+if (!require(data.table)) {
+ install.packages('data.table',repos='https://cran.r-project.org/')
+ library(data.table)
+}
+if (!require(dplyr)) {
+ install.packages('dplyr',repos='https://cran.r-project.org/')
+ library(dplyr)
+}
+if (!require(gtools)) {
+ install.packages('gtools',repos='https://cran.r-project.org/')
+ library(gtools)
+}
+if (!require(matrixStats)) {
+ install.packages('matrixStats',repos='https://cran.r-project.org/')
+ library(matrixStats)
+}
+if (!require(lme4)) { #For glmer
+ install.packages('lme4',repos='https://cran.r-project.org/')
+ library(lme4)
+}
+if (!require(cplm)) {
+ install.packages('cplm',repos='https://cran.r-project.org/')
+ library(cplm)
+}
+if (!require(nlme)) { #For lme and nlme.
+ install.packages('nlme',repos='https://cran.r-project.org/')
+ library(nlme)
+}
+if (!require(lmtest)) { #For waldtest.
+ install.packages('lmtest',repos='https://cran.r-project.org/')
+ library(lmtest)
+}
+if (!require(ggplot2)) {
+ install.packages('ggplot2',repos='https://cran.r-project.org/')
+ library(ggplot2)
+}
+if (!require(Cairo)) {
+ install.packages('Cairo',repos='https://cran.r-project.org/')
+ library(Cairo)
+}
+if (!require(pheatmap)) {
+ install.packages('pheatmap',repos='https://cran.r-project.org/')
+ library(pheatmap)
+}
+if (!require(ggcorrplot)) {
+ install.packages('ggcorrplot',repos='https://cran.r-project.org/')
+ library(ggcorrplot)
+}
+if (!require(eulerr)) {
+ install.packages('eulerr',repos='https://cran.r-project.org/')
+ library(eulerr)
+}
+if (!require(patchwork)) { #For the plots combination.
+ install.packages('patchwork',repos='https://cran.r-project.org/')
+ library(patchwork)
+}
+if (!require(ggforce)) { #For ellipses in the PCA plot.
+ install.packages('ggforce',repos='https://cran.r-project.org/')
+ library(ggforce)
+}
+if (!require(scales)) { #For the hue_pal() function.
+ install.packages('scales',repos='https://cran.r-project.org/')
+ library(scales)
+}
+if (!require(qs)) { #For MetaboAnalyst.
+ install.packages('qs',repos='https://cran.r-project.org/')
+ library(qs)
+}
+if (!require(Rserve)) { #For MetaboAnalyst.
+ install.packages('Rserve',repos='https://cran.r-project.org/')
+ library(Rserve)
+}
+if (!require(pls)) { #For PLS-DA.
+ install.packages('pls',repos='https://cran.r-project.org/')
+ library(pls)
+}
+if (!require(clusterProfiler)) {
+ BiocManager::install("clusterProfiler")
+ library(clusterProfiler)
+}
+if (!require(enrichplot)) { #For gseaplot2.
+ BiocManager::install("enrichplot")
+ library(enrichplot)
+}
+if (!require(msigdbr)) {
+ install.packages('msigdbr',repos='https://cran.r-project.org/')
+ library(msigdbr)
+}
+#############################End Installing/Loading Libraries#############################
+
diff --git a/V2.2/ODA/odaObject.R b/V2.2/ODA/odaObject.R
new file mode 100644
index 0000000000000000000000000000000000000000..839db49739666675b87abcd90238b5bf6505691a
--- /dev/null
+++ b/V2.2/ODA/odaObject.R
@@ -0,0 +1,68 @@
+#############################Begin Source Files#############################
+#This script was developed by zhiyu.zhao@utsouthwestern.edu .
+initial.options=commandArgs(trailingOnly=F)
+scriptPath=file.path(dirname(sub("--file=","",initial.options[grep("--file=",initial.options)])))
+if (length(scriptPath)==0)
+ scriptPath='.'
+source(file.path(scriptPath,'getSettings.R'))
+source(file.path(scriptPath,'getData.R'))
+source(file.path(scriptPath,'transformData.R'))
+#############################End Source Files#############################
+
+#############################Begin creatODAObject()#############################
+createODAObject=function(inputFile,outputPath) {
+ message('Creating the ODA object ...')
+ samples=getSamples(inputFile)
+ features=getFeatures(inputFile)
+ parameters=getParameters(inputFile)
+ comparisons=getComparisons(inputFile)
+ rawData=getData(inputFile,samples,features,parameters)
+ presentFeatures=rownames(rawData$presentGroups)[rawData$presentGroups[,'Present']>0]
+ rawData$rawDataTable=rawData$rawDataTable[presentFeatures,] #Raw data is filtered before normalization/transformation.
+ rawData$rawDataList=rawData$rawDataList[rawData$rawDataList[,'Feature']%in%presentFeatures,] #Raw data is filtered before normalization/transformation.
+# rawData$featureDescription=rawData$featureDescription[presentFeatures]
+ parameters$groupMeanLowerBound=min(rawData$rawDataTable[!is.na(rawData$rawDataTable)&rawData$rawDataTable>parameters$valueFilter])/2 #Added on 7/6/2021.
+ rawData$features$interested=rawData$features$interested[rawData$features$interested %in% presentFeatures] #Added on 10/17/2024.
+ samples=rawData$samples
+ features=rawData$features
+ rawData$attributes$nInterestedFeatures=length(features$interested)
+ rawData$attributes$nExcludedFeatures=length(features$excluded)
+ transformedData=NULL
+ if (parameters$normalization!='no' || parameters$logTransform || parameters$dataImputation!='no') {
+ transform=T
+ transformedData=transformData(rawData$rawDataTable,parameters,rawData$samples)
+ parameters=transformedData$parameters
+ samples=transformedData$samples
+ } else {
+ transform=F
+ transformedData$transformedDataTable=NULL
+ transformedData$transformedDataList=NULL
+ }
+
+ if (parameters$visual) {
+ figuresPath=file.path(outputPath,'Figures')
+ if (file.exists(figuresPath)&&!rlang::is_empty(dir(figuresPath))) {
+ message('CAUTION: Figures folder is not empty.')
+ } else {
+ dir.create(figuresPath,recursive=T,showWarnings=F)
+ }
+ } else {
+ figuresPath=NULL
+ dir.create(outputPath,recursive=T,showWarnings=F)
+ }
+# if (parameters$eaDB!='no'&&((parameters$oraMethod!='no'&&rawData$attributes$nInterestedFeatures>1)||(parameters$qeaMethod!='no'&&!is.null(comparisons$dePairs)))) {
+ eaPath=file.path(outputPath,'EnrichmentAnalysis')
+ if (file.exists(eaPath)&&!rlang::is_empty(dir(eaPath))) {
+ message('CAUTION: Enrichment analysis folder is not empty.')
+ } else {
+ dir.create(eaPath,recursive=T,showWarnings=F)
+ }
+# } else {
+# eaPath=NULL
+# }
+ message('The ODA object is created.')
+
+ return(list(samples=samples,features=features,parameters=parameters,comparisons=comparisons,rawDataTable=rawData$rawDataTable,rawDataList=rawData$rawDataList,featureDescription=rawData$featureDescription,presentSamples=rawData$presentSamples,sampleSummary=rawData$sampleSummary,presentGroups=rawData$presentGroups,groupSummary=rawData$groupSummary,attributes=rawData$attributes,transform=transform,transformedDataTable=transformedData$transformedDataTable,transformedDataList=transformedData$transformedDataList,sizeRatiosTable=transformedData$sizeRatiosTable,sizeRatiosList=transformedData$sizeRatiosList,trTitle=transformedData$trTitle,figuresPath=figuresPath,eaPath=eaPath))
+}
+#############################End creatODAObject()#############################
+
diff --git a/V2.2/ODA/statTests.R b/V2.2/ODA/statTests.R
new file mode 100644
index 0000000000000000000000000000000000000000..7e3f629a0ed39b00c8d134e7ca5856e688f041f4
--- /dev/null
+++ b/V2.2/ODA/statTests.R
@@ -0,0 +1,393 @@
+#############################Begin Source Files#############################
+initial.options=commandArgs(trailingOnly=F)
+scriptPath=file.path(dirname(sub("--file=","",initial.options[grep("--file=",initial.options)])))
+if (length(scriptPath)==0)
+ scriptPath='.'
+source(file.path(scriptPath,'libraries.R'))
+#############################End Source Files#############################
+
+dropFactor=function(formulaStr,factor) {
+ if (!is.null(formulaStr)) {
+ cat(paste0('\033[0;33mWarning: ',factor,' is all unique for the comparison and it will be dropped. If this is not desired, check the ',factor,' column.\033[0m\n'))
+ formulaStr=gsub(paste0('([+*:]?|[01]?\\|)',factor,'[+*:]?'),'',formulaStr)
+ formulaStr=gsub('[+*:]?\\(\\)[+*:]?','',formulaStr)
+ }
+ return(formulaStr)
+}
+#############################Begin prepare_data()#############################
+prepare_data=function(dataList,groups,formulaStr=NULL) {
+ if (!is.null(formulaStr))
+ formulaStr=gsub(' ','',formulaStr)
+ data=droplevels(dataList[dataList$GroupID %in% groups,])
+ nSamples=length(unique(data$Sample))
+ if (length(groups)>=nSamples) {
+ stop('Too few samples or too many groups. Check your sample sheet.')
+ }
+ if (length(unique(data$SubjectID))<nSamples) {
+ paired=T
+ data=data[order(data$Feature,data$GroupID,data$SubjectID),]
+ for (i in 2:length(groups))
+ if (sum(data$SubjectID[data$GroupID==groups[1]]!=data$SubjectID[data$GroupID==groups[i]])) {
+ cat('\033[0;33mWarning: Incomplete pairing. Please make sure the subject IDs in your sample sheet are all correct.\033[0m\n')
+ }
+ }else {
+ paired=F
+ formulaStr=dropFactor(formulaStr,'SubjectID')
+ }
+ if (length(unique(data$BatchID))>=nSamples) {
+ formulaStr=dropFactor(formulaStr,'BatchID')
+ }
+ dataTable=reshape2::dcast(data,Feature~Sample,value.var='Value')
+ rownames(dataTable)=dataTable[,1]
+ dataTable=dataTable[,-1]
+ return(list(data=data,dataTable=dataTable,paired=paired,formulaStr=formulaStr))
+}
+#############################End prepare_data()#############################
+
+#############################Begin fold_change()#############################
+fold_change=function(dataList,groups,groupMeanLowerBound,logTransform) {
+ res=NULL
+ for (g in groups) {
+ temp=dataList
+ temp$GroupID=as.character(temp$GroupID)
+ temp$GroupID[temp$GroupID!=g]='Rest'
+ names1=paste0(ifelse(logTransform,'log2_',''),c('mean','sd','adjusted_mean'),'_',g)
+ names2=paste0(ifelse(logTransform,'log2_',''),c('mean','sd','adjusted_mean'),'_non_',g)
+ fcName=paste0('fold_change_',g,'/',setdiff(groups,g))
+ for (i in as.character(unique(temp$Feature))) {
+ featureData=temp[temp$Feature==i,]
+ res[[names1[1]]][i]=mean(featureData$Value[featureData$GroupID==g],na.rm=T)
+ if (!is.nan(res[[names1[1]]][i])) { #Added on 5/16/23 for cases where the group is empty and no imputation is used.
+ res[[names1[2]]][i]=sd(featureData$Value[featureData$GroupID==g],na.rm=T)
+ res[[names1[3]]][i]=res[[names1[1]]][i]
+ if (res[[names1[3]]][i]<groupMeanLowerBound)
+ res[[names1[3]]][i]=groupMeanLowerBound
+ } else {
+ res[[names1[1]]][i]=NA
+ res[[names1[2]]][i]=NA
+ res[[names1[3]]][i]=NA
+ }
+ res[[names2[1]]][i]=mean(featureData$Value[featureData$GroupID!=g],na.rm=T)
+ if (!is.nan(res[[names2[1]]][i])) { #Added on 5/16/23 for cases where the group is empty and no imputation is used.
+ res[[names2[2]]][i]=sd(featureData$Value[featureData$GroupID!=g],na.rm=T)
+ res[[names2[3]]][i]=res[[names2[1]]][i]
+ if (res[[names2[3]]][i]<groupMeanLowerBound)
+ res[[names2[3]]][i]=groupMeanLowerBound
+ } else {
+ res[[names2[1]]][i]=NA
+ res[[names2[2]]][i]=NA
+ res[[names2[3]]][i]=NA
+ }
+ if (logTransform) {
+ res[[paste0('log2_',fcName)]][i]=res[[names1[3]]][i]-res[[names2[3]]][i]
+ res[[fcName]][i]=2^res[[paste0('log2_',fcName)]][i]
+ } else {
+ res[[fcName]][i]=res[[names1[3]]][i]/res[[names2[3]]][i]
+ }
+ }
+ }
+ res=as.data.frame(res,check.names=F)
+ res=res[,c(paste0(ifelse(logTransform,'log2_',''),'adjusted_mean_',groups[1]),paste0(ifelse(logTransform,'log2_',''),'adjusted_mean_',groups[2]),paste0('fold_change_',groups[1],'/',groups[2]),paste0('fold_change_',groups[2],'/',groups[1]))]
+ return(res)
+}
+#############################End fold_change()#############################
+
+#############################Begin t_test()#############################
+t_test=function(dataList,groups,groupMeanLowerBound,logTransform,normal=T,var.equal=F) {
+ message(paste0('Testing ',paste0(groups,collapse=' vs. '),' by t or alternative test...'))
+ temp=prepare_data(dataList,groups)
+ data=temp$data
+ dataTable=temp$dataTable
+ paired=temp$paired
+ rm(temp)
+ if (length(unique(data$SubjectID[data$GroupID==groups[1]]))<2 || length(unique(data$SubjectID[data$GroupID==groups[2]]))<2) {
+ stop('Too few samples. Check your sample sheet.')
+ }
+ res=NULL
+ for (i in rownames(dataTable)) {
+ featureData=data[data$Feature==i,]
+ if (normal) {
+ if (paired) {
+ res$statMethod[i]='Paired t-test'
+ } else {
+ if (var.equal)
+ res$statMethod[i]='Unpaired t-test'
+ else
+ res$statMethod[i]='Welch\'s t-test'
+ }
+ res$pValue[i]=try(t.test(Value~GroupID,data=featureData,paired=paired,var.equal=var.equal,na.action=na.omit)$p.value,silent=T)
+ } else {
+ if (paired) {
+ res$statMethod[i]='Wilcoxon signed-rank test'
+ } else {
+ res$statMethod[i]='Mann-Whitney test'
+ }
+ res$pValue[i]=try(wilcox.test(Value~GroupID,data=featureData,paired=paired,na.action=na.omit)$p.value,silent=T)
+ }
+ if (grepl('^Error|^NaN',res$pValue[i]))
+ res$pValue[i]=NA
+ }
+ res$FDR=p.adjust(res$pValue,method='fdr')
+ res=as.data.frame(list(res,fold_change(data,groups,groupMeanLowerBound,logTransform)),check.names=F)
+ message(paste0('Normality assumption: ',normal,' ; Equal variability assumption: ',var.equal,' ; Pairing: ',paired,' . Test finished.'))
+ return(res)
+}
+#############################Begin t_test()#############################
+
+#############################Begin makeDataForOthers()#############################
+makeDataForOthers=function(data,group,paired=F) {
+ res=data
+ res$GroupID=as.character(res$GroupID)
+ res$GroupID[res$GroupID!=group]='Others'
+ if (paired) {
+ res=res%>%group_by(Feature,GroupID,SubjectID)%>%summarize(Value=mean(Value,na.rm=T))
+ res$Sample=paste0('Sample_',res$GroupID,'_',res$SubjectID)
+ }
+ return(res)
+}
+#############################End makeDataForOthers()#############################
+
+#############################Begin anova_test()#############################
+anova_test=function(dataList,groups,groupMeanLowerBound,logTransform,normal=T,var.equal=F) {
+ message(paste0('Testing ',paste0(groups,collapse=' vs. '),' by ANOVA or alternative test...'))
+ temp=prepare_data(dataList,groups)
+ data=temp$data
+ dataTable=temp$dataTable
+ paired=temp$paired
+ rm(temp)
+ res=NULL
+ for (i in rownames(dataTable)) {
+ featureData=data[data$Feature==i,]
+ if (normal) {
+ if (paired) { #lme
+ res$statMethod[i]='lme'
+ res$Overall_pValue[i]=try(anova(lme(Value~GroupID,random=~1|SubjectID,data=featureData,na.action=na.omit))$'p-value'[2],silent=T)
+ } else {
+ if (var.equal) { #aov
+ res$statMethod[i]='One-way ANOVA'
+ res$Overall_pValue[i]=try(summary(aov(Value~GroupID,data=featureData,na.action=na.omit))[[1]]$'Pr(>F)',silent=T)
+ } else { #oneway.test i.e. Welch's anova
+ res$statMethod[i]='Welch\'s one-way ANOVA'
+ res$Overall_pValue[i]=try(oneway.test(Value~GroupID,data=featureData,var.equal=var.equal,na.action=na.omit)$p.value,silent=T)
+ }
+ }
+ } else {
+ if (paired) { #Friedman
+ res$statMethod[i]='Friedman test'
+ res$Overall_pValue[i]=try(friedman.test(Value~GroupID|SubjectID,data=featureData,na.action=na.omit)$p.value,silent=T)
+ } else { #KW
+ res$statMethod[i]='Kruskal-Wallis test'
+ res$Overall_pValue[i]=try(kruskal.test(Value~GroupID,data=featureData,na.action=na.omit)$p.value,silent=T)
+ }
+ }
+ if (grepl('^Error|^NaN',res$Overall_pValue[i]))
+ res$Overall_pValue[i]=NA
+ }
+ res$Overall_FDR=p.adjust(res$Overall_pValue,method='fdr')
+ res=as.data.frame(res,check.names=F)
+ if (length(groups)>2) {
+ for (i in 1:length(groups)) {
+ others=makeDataForOthers(data,groups[i])
+ temp=t_test(others,c(groups[i],'Others'),groupMeanLowerBound,logTransform,normal=normal,var.equal=var.equal)
+ colnames(temp)[1:3]=paste0(groups[i],'_',colnames(temp)[1:3])
+ res=cbind(res,temp)
+ }
+ } else {
+ res=as.data.frame(list(res,fold_change(data,groups,groupMeanLowerBound,logTransform)),check.names=F)
+ colnames(res)[c(1:3)]=c('statMethod','pValue','FDR')
+ }
+ message(paste0('Normality assumption: ',normal,' ; Equal variability assumption: ',var.equal,' ; Pairing: ',paired,' . Test finished.'))
+ return(res)
+}
+#############################End anova_test()#############################
+
+#############################Begin glmPerFeature()#############################
+glmPerFeature=function(featureData,formula,familyStr,testStr) {
+ statMethod='No test'
+ pValue=NA
+ if (sd(featureData$Value,na.rm=T)==0) { #Bug fix: na.rm=T added on 12/14/2021.
+ statMethod='No test (SD=0)'
+ } else {
+ if (testStr=='glm')
+ testMod=try(glm(formula,data=featureData,family=eval(parse(text=familyStr)),na.action=na.omit),silent=T)
+ if (testStr=='glmer') {
+ testMod=try(glmer(formula,data=featureData,family=eval(parse(text=familyStr)),na.action=na.omit),silent=T)
+ if (class(testMod)[1]=='lmerMod')
+ testMod=update(testMod,REML=F) #ML should be used here, because REML is based on fixed effects. When the fixed variables are changed, REML is changed, too. So it shouldn't be used on the models w/wo a fixed variable. glmer doesn't have the REML parameter, but when familyStr is gaussian(link='identity') it defaults to use REML and there's no way to change it. So here the update() is used to change this behavior.
+ }
+ if (testStr=='cpglm')
+ testMod=try(cpglm(formula,data=featureData,link=familyStr,na.action=na.omit),silent=T)
+ if (testStr=='cpglmm') { #Formula TBD
+ testMod=try(cpglmm(formula,data=featureData,link=familyStr,na.action=na.omit),silent=T)
+ }
+ testModConverged=ifelse('converged'%in%names(testMod),testMod$converged,ifelse(testStr=='glmer',class(testMod)[1]=='lmerMod'||class(testMod)[1]=='glmerMod',class(testMod)==testStr))
+ if (testModConverged) {
+ reducedMod=try(update(testMod,.~.-GroupID),silent=T)
+ if (grepl('GroupID:|:GroupID',deparse(formula(reducedMod)))) {
+ reducedMod=try(update(reducedMod,sub('GroupID:|:GroupID','',deparse(formula(reducedMod)))),silent=T)
+ }
+ reducedModConverged=ifelse('converged'%in%names(reducedMod),reducedMod$converged,ifelse(testStr=='glmer',class(reducedMod)[1]=='lmerMod'||class(testMod)[1]=='glmerMod',class(reducedMod)==testStr))
+ if (reducedModConverged) {
+ if (testStr=='glmer'||testStr=='cpglmm')
+ pValue=try(anova(testMod,reducedMod,test='LRT')$'Pr(>Chisq)'[2],silent=T) #anova() doesn't work with cpglm but works with cpglmm.
+ if (testStr=='glm'||testStr=='cpglm') {
+ pValue=try(waldtest(testMod,reducedMod,test='Chisq')[2,4],silent=F) #waldtest() from the lmtest package works with cpglm, and glm's Wald p-values highly correlate with Wald p-values of cpglm. However, Wald test is said to not be very good for small sample sizes. See https://stats.stackexchange.com/questions/193643/likelihood-ratio-vs-wald-test . waldtest() doesn't work with glmer or cpglmm.
+# vals=(sum(residuals(reducedMod)^2)-sum(residuals(testMod)^2))/sum(residuals(testMod)^2)*testMod$df.residual #This is equivalent to anova(...,test='LRT/Chisq'). See https://stats.stackexchange.com/questions/155474/why-does-lrtest-not-match-anovatest-lrt .
+# pValue=pchisq(vals,reducedMod$df.residual-testMod$df.residual,lower.tail=F) #Use this if LRT is desired for cpglm. It works with cpglm but sometimes gets extra small/large p-values that don't look quite reliable.
+ }
+ if (grepl('^Error|^NaN',pValue)) {
+ pValue=NA
+ statMethod='No test (LRT/waldtest() error)'
+ } else {
+ statMethod=paste0(testStr,': ',deparse(formula(formula)))
+ }
+ } else {
+ statMethod='No test (reduced model error or not converged)'
+ }
+ } else {
+ statMethod='No test (test model error or not converged)'
+ }
+ }
+ return(list(statMethod=statMethod,pValue=pValue))
+}
+#############################End glmPerFeature()#############################
+
+#############################Begin glm_test()#############################
+glm_test=function(dataList,groups,groupMeanLowerBound,logTransform,formulaStr='Value~GroupID',familyStr='gaussian()',cp=F) {
+ temp=prepare_data(dataList,groups,formulaStr)
+ data=temp$data
+ dataTable=temp$dataTable
+ formulaStr=temp$formulaStr
+ rm(temp)
+ testStr=ifelse(grepl('\\|',formulaStr),ifelse(cp,'cpglmm','glmer'),ifelse(cp,'cpglm','glm'))
+ message(paste0('Testing ',paste0(groups,collapse=' vs. '),' by ',testStr,' with formula: ',formulaStr,' and family/link: ',familyStr,' ...'))
+ formula=as.formula(formulaStr)
+ res=NULL
+ for (i in rownames(dataTable)) {
+ featureData=data[data$Feature==i,]
+ temp=glmPerFeature(featureData,formula,familyStr,testStr)
+ if (is.na(temp$pValue)&&testStr=='cpglm') {
+ temp=glmPerFeature(featureData,formula,familyStr,'glm')
+ } else if (is.na(temp$pValue)&&testStr=='cpglmm') {
+ temp=glmPerFeature(featureData,formula,familyStr,'glmer')
+ }
+ res$statMethod[i]=temp$statMethod
+ res$Overall_pValue[i]=temp$pValue
+ }
+ res$Overall_FDR=p.adjust(res$Overall_pValue,method='fdr')
+ if (length(groups)>2) {
+ for (i in 1:length(groups)) {
+ others=makeDataForOthers(data,groups[i])
+ for (j in rownames(dataTable)) {
+ featureData=others[others$Feature==j,]
+ temp=glmPerFeature(featureData,formula,familyStr,testStr)
+ if (is.na(temp$pValue)&&testStr=='cpglm') {
+ temp=glmPerFeature(featureData,formula,familyStr,'glm')
+ } else if (is.na(temp$pValue)&&testStr=='cpglmm') {
+ temp=glmPerFeature(featureData,formula,familyStr,'glmer')
+ }
+ res[[paste0(groups[i],'_statMethod')]][j]=temp$statMethod
+ res[[paste0(groups[i],'_pValue')]][j]=temp$pValue
+ }
+ res[[paste0(groups[i],'_FDR')]]=p.adjust(res[[paste0(groups[i],'_pValue')]],method='fdr')
+ res=list(res,fold_change(others,c('Others',groups[i]),groupMeanLowerBound,logTransform))
+ }
+ res=as.data.frame(res,check.names=F)
+ } else {
+ res=as.data.frame(list(res,fold_change(data,groups,groupMeanLowerBound,logTransform)),check.names=F)
+ colnames(res)[c(1:3)]=c('statMethod','pValue','FDR')
+ }
+ message('Test finished.')
+ return(res)
+}
+#############################End glm_test()#############################
+
+#############################Begin deseq2_test()#############################
+deseq2_test=function(rawDataList,transformedDataList,groups,groupMeanLowerBound,logTransform,formulaStr='~GroupID',samples) {
+ g=length(groups)
+ if (g<2)
+ stop('At least 2 groups should be selected.')
+ denominatorGroup=groups[1] #The first level will be the denominator group.
+ numeratorGroup=groups[2] #The second level will be the numerator group.
+ temp=prepare_data(rawDataList,groups,formulaStr)
+ data=temp$data
+ dataTable=temp$dataTable
+ samples=samples[colnames(dataTable),]
+ samples$GroupID=factor(samples$GroupID,levels=c(denominatorGroup,numeratorGroup,groups[!groups %in% c(denominatorGroup,numeratorGroup)])) #Denominator group must be the first in the groups.
+ fullFormula=dropFactor(temp$formulaStr,'Value')
+ if (dropFactor(fullFormula,'GroupID')=='~')
+ reducedFormula=formula('~1')
+ else
+ reducedFormula=formula(dropFactor(fullFormula,'GroupID'))
+ fullFormula=formula(fullFormula)
+ temp=prepare_data(transformedDataList,groups,formulaStr)
+ transformedData=temp$data
+ rm(temp)
+ message(paste0('Testing ',paste0(groups,collapse=' vs. '),' by DESeq2 with full formula ',deparse(fullFormula),' and reduced formula ',deparse(reducedFormula),' ...'))
+ dataSet=DESeqDataSetFromMatrix(dataTable,samples,fullFormula)
+ sizeFactors(dataSet)=samples$Size
+ dataSet=estimateDispersions(dataSet)
+ if (g>2) {
+ message("Performing the nbinomLRT test...")
+ dataSet=nbinomLRT(dataSet,full=fullFormula,reduced=reducedFormula)
+ }
+ if (g==2) {
+ message("Performing the nbinomWaldTest test...")
+ dataSet=nbinomWaldTest(dataSet)
+ }
+ message('Result names:')
+ print(resultsNames(dataSet))
+ if (g>2)
+ tempRes=results(dataSet,cooksCutoff=F,independentFiltering=F)
+ if (g==2)
+ tempRes=results(dataSet,cooksCutoff=F,contrast=c('GroupID',numeratorGroup,denominatorGroup),independentFiltering=F)
+ res=NULL
+ res$statMethod=paste0("DESeq2:",formulaStr)
+ res$Overall_pValue=tempRes$pvalue
+ res$Overall_FDR=p.adjust(res$Overall_pValue,method='fdr')
+ if (g>2) {
+ for (i in 1:g) {
+ tempSamples=samples
+ levels(tempSamples$GroupID)[levels(tempSamples$GroupID)!=groups[i]]='Others'
+ tempSamples$GroupID=factor(tempSamples$GroupID,levels=c('Others',groups[i])) #Denominator group must be the first in the groups.
+ dataSet=DESeqDataSetFromMatrix(dataTable,tempSamples,fullFormula)
+ sizeFactors(dataSet)=tempSamples$Size
+ dataSet=estimateDispersions(dataSet)
+ dataSet=nbinomWaldTest(dataSet)
+ tempRes=results(dataSet,cooksCutoff=F,contrast=c('GroupID',groups[i],'Others'),independentFiltering=F)
+ tempRes=lfcShrink(dataSet,coef=paste('GroupID',groups[i],'vs','Others',sep='_'),type="apeglm")
+ res[[paste0(groups[i],'_pValue')]]=tempRes$pvalue
+ res[[paste0(groups[i],'_FDR')]]=p.adjust(tempRes$pvalue,method='fdr')
+ res[[paste0(groups[i],'_DESeq2_log2FC')]]=tempRes$log2FoldChange
+ tempTransformedData=transformedData
+ levels(tempTransformedData$GroupID)[levels(tempTransformedData$GroupID)!=groups[i]]='Others'
+ res=list(res,fold_change(tempTransformedData,c('Others',groups[i]),groupMeanLowerBound,logTransform))
+ }
+ res=as.data.frame(res,check.names=F)
+ } else {
+ tempRes=lfcShrink(dataSet,coef=paste('GroupID',numeratorGroup,'vs',denominatorGroup,sep='_'),type="apeglm")
+ res$DESeq2_log2FC=tempRes$log2FoldChange
+ res=as.data.frame(list(res,fold_change(transformedData,groups,groupMeanLowerBound,logTransform)),check.names=F)
+ colnames(res)[c(1:4)]=c('statMethod','pValue','FDR',paste0('DESeq2_log2FC(',numeratorGroup,'/',denominatorGroup,')'))
+ }
+ message('Test finished.')
+ return(res)
+}
+#############################End deseq2_test()#############################
+
+#############################Begin summarizeDiffTest()#############################
+summarizeDiffTest=function(resDT,groups,presentGroups,parameters) { #res is the output of a differential test in this file.
+ res=matrix(nrow=0,ncol=11)
+ colnames(res)=c('Control','Treatment','Control_Only','Treatment_Only','Absent_in_Both','Present_in_Both','Up_in_Treatment','Down_in_Treatment','Up_or_Down','FDR_Cutoff','FC_Cutoff')
+ for (pc in parameters$pCutoffs) {
+ for (fcc in parameters$fcCutoffs) {
+ p=resDT$FDR
+ fc=resDT[,paste0('fold_change_',groups[1],'/',groups[2])]
+ rfc=1/fc
+ res=rbind(res,c(groups,sum(presentGroups[,groups[1]]&!presentGroups[,groups[2]]),sum(!presentGroups[,groups[1]]&presentGroups[,groups[2]]),sum(!presentGroups[,groups[1]]&!presentGroups[,groups[2]]),sum(presentGroups[,groups[1]]&presentGroups[,groups[2]]),sum(!is.na(p)&rfc>fcc&p<pc),sum(!is.na(p)&fc>fcc&p<pc),sum(!is.na(p)&(rfc>fcc|fc>fcc)&p<pc),pc,fcc))
+ }
+ }
+ return(as.data.frame(res))
+}
+#############################End summarizeDiffTest()#############################
+
diff --git a/V2.2/ODA/transformData.R b/V2.2/ODA/transformData.R
new file mode 100644
index 0000000000000000000000000000000000000000..65c0271757dd242ffca63c040ba1c4a037648e36
--- /dev/null
+++ b/V2.2/ODA/transformData.R
@@ -0,0 +1,128 @@
+#############################Begin Source Files#############################
+initial.options=commandArgs(trailingOnly=F)
+scriptPath=file.path(dirname(sub("--file=","",initial.options[grep("--file=",initial.options)])))
+if (length(scriptPath)==0)
+ scriptPath='.'
+source(file.path(scriptPath,'libraries.R'))
+#############################End Source Files#############################
+
+#############################Begin deseq2Norm()#############################
+deseq2Norm=function(rawDataTable,samples){ #Added by ZZY on 10/03/24.
+ dataSet=DESeqDataSetFromMatrix(rawDataTable,samples,as.formula("~1"))
+ dataSet=estimateSizeFactors(dataSet)
+ return(sizeFactors(dataSet))
+}
+#############################Begin deseq2Norm()#############################
+
+#############################Begin transformData()#############################
+transformData=function(rawDataTable,parameters,samples){
+ message ('Normalizing and transforming data ...')
+ #normData=rawData #Long-list Disabled on 3/18/2021.
+ transformedDataTable=rawDataTable
+ sizeRatiosTable=NULL
+ sizeRatiosList=NULL
+ sizeRatios=rawDataTable
+ sizeRatios=sizeRatios[rowSums(sizeRatios,na.rm=T)!=0,] #All-zero rows are not used for normalization.
+ trTitle='Data'
+ sizeFactors=NULL
+ if (parameters$normalization!='no') {
+ if (parameters$normalization=='rle') {
+ sizeRatios[sizeRatios<=parameters$valueFilter]=NA #Very low values are ignored.
+# sizeRatios=sizeRatios/exp(rowMeans(log(sizeRatios),na.rm=T)) #Buggy, don't use: Each row is divided by its geometric mean.
+ sizeRatios=sweep(sizeRatios,1,exp(rowMeans(log(sizeRatios),na.rm=T)),'/') #Each row is divided by its geometric mean.
+ sizeRatiosTable=sizeRatios
+ sizeFactors=colMedians(sizeRatios,na.rm=T) #Median of ratios within each sample is taken as its size factor.
+ sizeRatios=reshape2::melt(log2(sizeRatios),varnames=c('Feature','Sample'), value.name ='Value')
+ sizeRatios$Sample=as.character(sizeRatios$Sample)
+ sizeRatios[,colnames(samples)]=samples[sizeRatios$Sample,]
+ sizeRatiosList=sizeRatios
+ }
+ else {
+ if (parameters$normalization=='bysize')
+ sizeFactors=samples$Size #If normalize by size, size factors are taken from the input file. Size factors can be e.g. cell counts, spike-in amount etc.
+ if (parameters$normalization=='bymedian') #If normalize by median, the median feature value of each sample is taken as its size factor.
+ sizeFactors=colMedians(sizeRatios)
+ if (parameters$normalization=='byupperquantile') #If normalize by upper quantile, the (uqProb*100)-th quantile value of each sample is taken as its size factor. uqProb is taken from the input file or defaults to 0.75 i.e. the upper quartile.
+ sizeFactors=colQuantiles(sizeRatios,probs=parameters$uqProb,na.rm=T)
+ if (parameters$normalization=='bysum') #If normalize by sum, the sum of feature values of each sample is taken as its size factor.
+ sizeFactors=colSums(sizeRatios,na.rm=T)
+ if (parameters$normalization=='byquantile') {
+ transformedDataTable=normalize.quantiles(rawDataTable)
+ rownames(transformedDataTable)=rownames(rawDataTable)
+ colnames(transformedDataTable)=colnames(rawDataTable)
+ sizeFactors=1
+ }
+ if (parameters$normalization=='deseq2') #Added by ZZY on 10/03/24.
+ sizeFactors=deseq2Norm(rawDataTable,samples)
+ sizeRatiosTable=NULL
+ sizeRatiosList=NULL
+ }
+ if (sum(sizeFactors==0)==0) {
+ if (parameters$normalization!='byquantile') {
+ if (parameters$normalization!='deseq2') #For DESeq2, just keep its original size factors. Added by ZZY on 10/03/24.
+ sizeFactors=sizeFactors/median(sizeFactors) #To make all size factors close to 1
+ transformedDataTable=sweep(rawDataTable,2,sizeFactors,'/') #Raw data are normalized by the size factor per sample. A bug regarding this line is fixed.
+ # names(sizeFactors)=colnames(rawDataTable)
+ # normData$Value=normData$Value/sizeFactors[normData$Sample] #Disabled on 3/18/2021.
+ }
+ samples$Size=sizeFactors
+ trTitle=paste0(parameters$normalization,'-normalized_',trTitle)
+ }
+ else {
+ stop('Size factor(s)=0. No normalization is applied.')
+ }
+ }
+
+# if (sum(rawDataTable>parameters$valueFilter,na.rm=T)>0 && parameters$groupMeanLowerBound=='')
+ parameters$groupMeanLowerBound=min(transformedDataTable[!is.na(transformedDataTable)&transformedDataTable>parameters$valueFilter])/2 #Moved here from the overall report part on 3/15/2021.
+
+ #Data imputation was moved here on 3/15/2021.
+ if (parameters$dataImputation!='no') {
+ transformedDataTable[transformedDataTable<=parameters$valueFilter]=NA
+ trTitle=paste0(parameters$dataImputation,'-imputed_',trTitle)
+ }
+ if (parameters$dataImputation=='value filter')
+ transformedDataTable[is.na(transformedDataTable)]=parameters$valueFilter
+ if (parameters$dataImputation=='mean')
+ tempData=rowMeans(transformedDataTable,na.rm=T)
+ if (parameters$dataImputation=='median')
+ tempData=rowMedians(transformedDataTable,na.rm=T)
+ if (parameters$dataImputation=='half minimum') {
+ tempData=rowMins(transformedDataTable,na.rm=T)/2 #When a row is all NAs, rowMins() returns Inf.
+ }
+ if (parameters$dataImputation=='mean' || parameters$dataImputation=='median' || parameters$dataImputation=='half minimum') {
+ parameters$logOffset=0 #Added on 3/15/2021.
+ tempData[tempData==Inf]=parameters$groupMeanLowerBound
+ tempData[is.nan(tempData)]=parameters$groupMeanLowerBound
+ tempData[is.na(tempData)]=parameters$groupMeanLowerBound
+ tempData=replicate(dim(transformedDataTable)[2],tempData)
+ transformedDataTable[is.na(transformedDataTable)]=tempData[is.na(transformedDataTable)]
+ }
+
+ if (parameters$logTransform) {
+ if (parameters$logOffset=='')
+ parameters$logOffset=min(transformedDataTable[!is.na(transformedDataTable)&transformedDataTable>parameters$valueFilter])/2 #Added on 3/14/2021.
+ transformedDataTable=transformedDataTable+parameters$logOffset
+ if (sum(transformedDataTable<=0,na.rm=T))
+ stop('Offset of log2-transformation is too small to make all values positive.')
+ transformedDataTable=log2(transformedDataTable)
+# if (sum(transformedDataTable>parameters$valueFilter,na.rm=T)>0 && parameters$groupMeanLowerBound=='')
+ parameters$groupMeanLowerBound=log2(parameters$groupMeanLowerBound) #Added on 3/15/2021.
+ trTitle=paste0('Log2(x+',sprintf('%.2e',parameters$logOffset),')_',trTitle)
+ }
+
+ if (trTitle=='Data') {
+ transformedDataList=NULL
+ } else {
+ transformedDataList=reshape2::melt(transformedDataTable,id.vars=1)
+ transformedDataList[,2]=as.character(transformedDataList[,2])
+ transformedDataList[,3]=as.numeric(transformedDataList[,3])
+ colnames(transformedDataList)=c('Feature','Sample','Value')
+ transformedDataList[,colnames(samples)]=samples[transformedDataList$Sample,]
+ }
+ message ('Finished normalizing and transforming data.')
+
+ return(list(transformedDataTable=transformedDataTable,transformedDataList=transformedDataList,sizeRatiosTable=sizeRatiosTable,sizeRatiosList=sizeRatiosList,samples=samples,trTitle=trTitle,parameters=parameters))
+}
+#############################End transformData()#############################
+
diff --git a/V2.2/ODA/workBook.R b/V2.2/ODA/workBook.R
new file mode 100644
index 0000000000000000000000000000000000000000..5e5e01f2b56bd03ec73f435fd9a8da2361934471
--- /dev/null
+++ b/V2.2/ODA/workBook.R
@@ -0,0 +1,290 @@
+#############################Begin Source Files#############################
+initial.options=commandArgs(trailingOnly=F)
+scriptPath=file.path(dirname(sub("--file=","",initial.options[grep("--file=",initial.options)])))
+if (length(scriptPath)==0)
+ scriptPath='.'
+source(file.path(scriptPath,'libraries.R'))
+#############################End Source Files#############################
+
+#############################Begin createWBObject()#############################
+createWBObject=function(parameters){
+ message('Creating the workbook object ...')
+ wb=createWorkbook()
+ style1=createStyle(textDecoration='Bold')
+ style2=createStyle(textDecoration='Bold',wrapText=T)
+ message('Workbook object is created.')
+ return(list(wb=wb,style1=style1,style2=style2))
+}
+#############################End createWBObject()#############################
+
+#############################Begin writeDataSheet()"#############################
+writeDataSheet=function(wbObj,sheetName,dataTable,samples,parameters,title='Data',featureDescription=NULL,rowOffset=0,freezePane=T){ #Data must be 2-dimensional. Use drop=F when calling this function if dataTable is subsetted.
+ message(paste0('Writing the ',title,' sheet ...'))
+ if (!sheetName %in% names(wbObj$wb))
+ addWorksheet(wbObj$wb,sheetName)
+ if (parameters$dataFormat=='table with feature description'&&!is.null(featureDescription)) {
+ writeData(wbObj$wb,sheetName,t(rbind(NA,samples)),rowNames=T,colNames=T,keepNA=F,startRow=rowOffset+1)
+ writeData(wbObj$wb,sheetName,'',startRow=rowOffset+1,startCol=2)
+ writeData(wbObj$wb,sheetName,'Description',startRow=rowOffset+6,startCol=2)
+ if (freezePane)
+ freezePane(wbObj$wb,sheetName,firstActiveRow=7,firstActiveCol=3)
+ featureDescription=featureDescription[rownames(dataTable),,drop=F]
+ writeData(wbObj$wb,sheetName,data.frame(Description=featureDescription,dataTable,stringsAsFactors=F,check.names=F),startRow=rowOffset+7,rowNames=T,colNames=F)
+ } else {
+ writeData(wbObj$wb,sheetName,t(samples),rowNames=T,colNames=T,startRow=rowOffset+1)
+ if (freezePane)
+ freezePane(wbObj$wb,sheetName,firstActiveRow=7,firstActiveCol=2)
+ writeData(wbObj$wb,sheetName,dataTable,startRow=rowOffset+7,rowNames=T,colNames=F)
+ }
+ writeData(wbObj$wb,sheetName,title,startRow=rowOffset+1,startCol=1)
+ addStyle(wbObj$wb,sheetName,wbObj$style1,rows=rowOffset+1,cols=1)
+ message('Finished writing the data sheet.')
+ return(wbObj)
+}
+#############################End writeDataSheet()#############################
+
+#############################Begin writeTable()#############################
+writeTable=function(wbObj,sheetName,data,title='',featureDescription=NULL,rowOffset=0,colOffset=0,firstActiveRow=0,firstActiveCol=0){ #Data must be 2-dimensional. Use drop=F when calling this function if dataTable is subsetted.
+ message(paste0('Writing the ',sheetName,' sheet.'))
+ if (rowOffset==0 && colOffset==0)
+ addWorksheet(wbObj$wb,sheetName)
+ if (typeof(data)=='list'&&is.null(dim(data))) {
+ for (i in 1:length(data)) {
+ if (is.logical(data[[i]]))
+ data[[i]]=ifelse(data[[i]],'yes','no')
+ else
+ data[[i]]=paste(data[[i]],collapse=', ')
+ }
+ dataTable=t(as.data.frame(data))
+ colnames(dataTable)='Value'
+ } else {
+ dataTable=data
+ }
+ if (!is.null(featureDescription)) {
+ featureDescription=featureDescription[rownames(dataTable),,drop=F]
+ dataTable=cbind(featureDescription,dataTable)
+ }
+ writeData(wbObj$wb,sheetName,dataTable,rowNames=T,startRow=rowOffset+1,startCol=colOffset+1,borders='surrounding')
+ writeData(wbObj$wb,sheetName,title,startRow=rowOffset+1,startCol=colOffset+1)
+ addStyle(wbObj$wb,sheetName,wbObj$style2,rows=rowOffset+1,cols=(colOffset+1):(colOffset+1+dim(dataTable)[2]))
+ if (firstActiveRow>0&&firstActiveCol>0)
+ freezePane(wbObj$wb,sheetName,firstActiveRow=firstActiveRow,firstActiveCol=firstActiveCol)
+ message(paste0('Finished writing the ',sheetName,' sheet for ',title,'.'))
+ return(wbObj)
+}
+#############################End writeTable()#############################
+
+#############################Begin writeGeneralFigures()#############################
+writeGeneralFigures=function(wbObj,sheetName,dataTable,dataList,samples,parameters,plotType,plotPosition,figuresPath=NULL){ #Data must be 2-dimensional. Use drop=F when calling this function if dataTable is subsetted.
+ message(paste0('Generating figures for ',plotType,'...'))
+ nonZeroFeatures=rownames(dataTable)[rowSums(dataTable,na.rm=T)!=0]
+ if (length(nonZeroFeatures)<2) {
+ message('At least 2 non-zero features are required. No figures are generated.')
+ return(wbObj)
+ } else {
+ dataList=dataList[dataList$Feature %in% nonZeroFeatures,] #All-zero features are excluded from visualization.
+ }
+ if (!sheetName%in%names(wbObj$wb))
+ addWorksheet(wbObj$wb,sheetName)
+ plotPosition=plotPosition-1 #For position 1, plotting starts at row offset 0.
+ pdfFile=file.path(figuresPath,paste0(plotType,'.pdf'))
+ pngFile=file.path(figuresPath,paste0(plotType,'.png'))
+ options(warn=-1)
+ p1=ggplot(dataList,aes(x=Sample,y=Value,color=GroupID,fill=GroupID))+geom_violin(color='black',alpha=0.5)+geom_jitter(position=position_jitter(0.2),size=0.1)+geom_boxplot(color='black',outlier.size=-1,width=0.1)+facet_grid(.~Sample,scales='free_x',space='free_x')+theme(strip.text=element_blank(),axis.text.x = element_text(angle = 90, hjust = 1),legend.position = "none")+ggtitle(paste0('Violin-Boxplot of ',plotType))
+ p2=ggplot(dataList,aes(x=Value,color=GroupID,fill=GroupID,alpha=0.5))+geom_histogram(aes(y=..density..),bins=20)+geom_vline(aes(xintercept=mean(Value,na.rm=T)))+geom_vline(aes(xintercept=median(Value,na.rm=T)),linetype='longdash')+geom_density(color='black')+facet_grid(.~Sample)+ggtitle(paste0('Histogram of ',plotType))+theme(strip.text=element_blank(),axis.text.x=element_text(angle=90,hjust=1),legend.position = "none") #Added mean and median vertical lines on 10/5/24.
+ statsData=reshape2::melt(do.call(data.frame,aggregate(Value~Sample,FUN=function(x) c(Median=median(x),Quantile=quantile(x,parameters$uqProb),Sum=sum(x)),data=dataList)),id.vars='Sample')
+ colnames(statsData)=c('Sample','Stat','Value')
+ statsData$Sample=as.character(statsData$Sample)
+ statsData$GroupID=samples[statsData$Sample,1]
+ statsData$BatchID=samples[statsData$Sample,3]
+ p3=ggplot(statsData,aes(x=Sample,y=Value,color=GroupID,fill=GroupID,alpha=0.5))+geom_bar(stat='identity')+facet_grid(Stat~BatchID,scales='free',space='free_x')+theme(axis.text.x = element_text(angle = 90, hjust = 1),legend.position = "none")+ggtitle(paste0('Statistics of ',plotType))
+ p=wrap_plots(p1,p2,nrow=2,heights=c(3,2))
+ p=wrap_plots(p,p3,widths=c(3,1))
+# ggsave(pdfFile,plot=p,width=min(50,max(dim(dataTable)[2],12)),height=8,units='in',limitsize=F)
+# ggsave(pngFile,plot=p,width=min(50,max(dim(dataTable)[2],12)),height=8,units='in',limitsize=F)
+# insertImage(wbObj$wb,sheetName,pngFile, width=dim(dataTable)[2], height=8, unit='in',startRow=plotPosition*45+1,startCol=1)
+# plotPosition=plotPosition+1
+ dataTable[is.na(dataTable)|dataTable==-Inf]=parameters$groupMeanLowerBound #Clustering doesn't work with NAs/Infs. Added on 3/16/2021.
+ dataTable=dataTable[apply(dataTable,1,sd)>0,] #Scaling doesn't work with zero-sd rows. Added on 3/16/2021.
+ if (!is.null(dim(dataTable))&&dim(dataTable)[1]>1) { #At least 2 features are required.
+# pdfFile=file.path(figuresPath,paste0(plotType,'_heatmap.pdf'))
+# pngFile=file.path(figuresPath,paste0(plotType,'_heatmap.png'))
+ p4=pheatmap(dataTable,main=paste0('Heatmap of ',plotType),border_color=NA,show_rownames=grepl('Selected',plotType),treeheight_row=0,annotation_col=samples[colnames(dataTable),c('BatchID','GroupID')],annotation_legend=T,na_col='gray',scale=ifelse(parameters$scaling,'row','none'),col=parameters$heatmapColors,cluster_rows=parameters$hclustFeatures,cluster_cols=parameters$hclustSamples)$gtable
+# ggsave(pdfFile,plot=p$gtable,width=min(50,max(dim(dataTable)[2],12)),height=8,units='in',limitsize=F)
+# ggsave(pngFile,plot=p$gtable,width=min(50,max(dim(dataTable)[2],12)),height=8,units='in',limitsize=F)
+# insertImage(wbObj$wb,sheetName,pngFile, width=min(50,max(dim(dataTable)[2]/3,4)), height=8, unit='in',startRow=plotPosition*45+1,startCol=1)
+# pdfFile=file.path(figuresPath,paste0(plotType,'_scaled_heatmap.pdf'))
+# pngFile=file.path(figuresPath,paste0(plotType,'_scaled_heatmap.png'))
+# p=pheatmap(dataTable,main=paste0('Scaled Heatmap of ',plotType),border_color=NA,show_rownames=grepl('features',plotType),treeheight_row=0,annotation_col=samples[colnames(dataTable),c('BatchID','GroupID')],annotation_legend=T,na_col='gray',scale='row',col=heatmapColors,cluster_rows=hclustFeatures,cluster_cols=hclustSamples)
+# ggsave(pdfFile,plot=p$gtable,width=min(50,max(dim(dataTable)[2],12)),height=8,units='in',limitsize=F)
+# ggsave(pngFile,plot=p$gtable,width=min(50,max(dim(dataTable)[2],12)),height=8,units='in',limitsize=F)
+# insertImage(wbObj$wb,sheetName,pngFile, width=min(50,max(dim(dataTable)[2]/3,4)), height=8, unit='in',startRow=plotPosition*45+1,startCol=ceiling(max(dim(dataTable)[2]/3,4)*2))
+# pdfFile=file.path(figuresPath,paste0(plotType,'_pca_cor.pdf'))
+# pngFile=file.path(figuresPath,paste0(plotType,'_pca_cor.png'))
+ if (parameters$drpMethod=='pca') {
+ drRes=prcomp(t(dataTable),center=parameters$scaling,scale=parameters$scaling) #prcomp doesn't use the response variable.
+ dataList=data.frame(drRes$x,samples)
+ drRes=summary(drRes)
+ p5=ggplot(dataList,aes(x=PC1,y=PC2,color=GroupID))+geom_point(aes(shape=BatchID,size=1))+ggtitle(paste0(toupper(parameters$drpMethod),' of ',plotType))+theme_light()+xlab(paste0('Comp1 (',sprintf('%.2f',drRes$importance[2,1]*100),'%)'))+ylab(paste0('Comp2 (',sprintf('%.2f',drRes$importance[2,2]*100),'%)'))
+ }
+ if (parameters$drpMethod=='pls-da') { #Added on 10/7/24.
+ GroupID=factor(samples$GroupID)
+ Y=model.matrix(~GroupID-1) #Y must be a dummy-coded matrix for the categorical response variable.
+ colnames(Y)=levels(GroupID)
+ rownames(Y)=rownames(samples)
+ ncomp=3
+ set.seed(123) #To ensure the result is reproducible.
+# if (parameters$drpMethod=='pca') #Disabled because the pcr function in the pls package takes the response variable into account.
+# drRes=pcr(Y~as.matrix(t(dataTable)),ncomp=ncomp,validation='CV',segments=3,center=parameters$scaling,scale=parameters$scaling)
+ drRes=plsr(Y~as.matrix(t(dataTable)),ncomp=ncomp,validation='CV',segments=3,center=parameters$scaling,scale=parameters$scaling)
+ dataList=cbind(drRes$scores[,1:ncomp],samples)
+ colnames(dataList)[1:2]=c('Comp1','Comp2')
+ explVar=explvar(drRes) #% of explained variance
+ p5=ggplot(dataList,aes(x=Comp1,y=Comp2,color=GroupID))+geom_point(aes(shape=BatchID),size=2)+ggtitle(paste0(toupper(parameters$drpMethod),' of ',plotType))+theme_light()+xlab(paste0('Comp1 (',sprintf('%.2f',explVar[1]),'%)'))+ylab(paste0('Comp2 (',sprintf('%.2f',explVar[2]),'%)'))
+ }
+ if (parameters$drpLabels)
+ p5=p5+geom_text(aes(label=rownames(dataList),vjust = "inward", hjust = "inward"))
+ if (parameters$drpEllipses)
+# p5=p5+stat_ellipse(type="norm") #Doesn't work with too few points
+ p5=p5+ggforce::geom_mark_ellipse(aes(fill=GroupID,color=GroupID))
+ if (dim(dataTable)[1]>2)
+ pMat=cor_pmat(dataTable)
+ else
+ pMat=NULL
+ if (sum(is.na(cor(dataTable,method=parameters$corMethod)))>0)
+ hClust=F
+ else
+ hClust=T
+ if (parameters$scaling)
+ dataTable=as.data.frame(t(scale(t(dataTable)))) #Added on 3/17/2021.
+ p6=ggcorrplot(cor(dataTable,method=parameters$corMethod), hc.order = hClust, outline.col = "white",p.mat=pMat,lab=F,insig='blank')+theme(axis.text.x = element_text(angle = 90, hjust = 1))+ggtitle(paste0(toupper(substring(parameters$corMethod,1,1)),substring(parameters$corMethod,2),' Correlation of ',plotType)) #Correlation method was added on 10/5/2024.
+ p=wrap_plots(p,p4,p5,p6,widths=c(2,1,1,1))
+# p2=ggpairs(as.data.frame(dataTable),lower=list(continuous='smooth'),title=paste0('Scatter Plot of ',plotType))
+# p=plot_grid(p1,ggmatrix_gtable(p2),ncol=2,rel_widths=c(1/3,2/3))
+# ggsave(pdfFile,plot=p,width=min(50,max(dim(dataTable)[2]*2,16)),height=8,units='in',limitsize=F)
+# ggsave(pngFile,plot=p,width=min(50,max(dim(dataTable)[2]*2,16)),height=8,units='in',limitsize=F)
+# insertImage(wbObj$wb,sheetName,pngFile, width=min(50,max(dim(dataTable)[2]*2,16)), height=8, unit='in',startRow=plotPosition*45+1,startCol=ceiling(max(dim(dataTable)[2]/3,4)*2))
+ ggsave(pdfFile,plot=p,width=48,height=8,units='in',limitsize=F,device=cairo_ps)
+ ggsave(pngFile,plot=p,width=48,height=8,units='in',limitsize=F,type='cairo')
+ insertImage(wbObj$wb,sheetName,pngFile,width=48, height=8, unit='in',startRow=plotPosition*48+2,startCol=1)
+ writeData(wbObj$wb,sheetName,plotType,startRow=plotPosition*48+1,startCol=1)
+ addStyle(wbObj$wb,sheetName,wbObj$style2,rows=plotPosition*48+1,cols=1)
+ }
+ options(warn=0)
+ message('Finished generating figures.')
+ return(wbObj)
+}
+#############################End writeGeneralFigures()#############################
+
+#############################Begin writeFeatureFigures()#############################
+writeFeatureFigures=function(wbObj,sheetName,dataTable,dataList,plotType,plotPosition,figuresPath=NULL){ #Data must be 2-dimensional. Use drop=F when calling this function if dataTable is subsetted.
+ message(paste0('Generating feature figures for ',plotType,'...'))
+ nonZeroFeatures=rownames(dataTable)[rowSums(dataTable,na.rm=T)!=0]
+ if (length(nonZeroFeatures)<1) {
+ message('At least one non-zero features is required. No figures are generated.')
+ return(wbObj)
+ } else {
+ dataList=dataList[dataList$Feature %in% nonZeroFeatures,] #All-zero features are excluded from visualization.
+ }
+ if (!sheetName%in%names(wbObj$wb))
+ addWorksheet(wbObj$wb,sheetName)
+ plotPosition=plotPosition-1 #For position 1, plotting starts at row offset 0.
+ pdfFile=file.path(figuresPath,paste0(plotType,'.pdf'))
+ pngFile=file.path(figuresPath,paste0(plotType,'.png'))
+ nGroups=length(unique(dataList$GroupID))
+ nBatches=length(unique(dataList$BatchID))
+ options(warn=-1)
+ p1=ggplot(dataList,aes(x=Feature,y=Value))+geom_violin(color='black',alpha=0.5)+geom_jitter(position=position_jitter(0.2),size=1)+geom_boxplot(color='black',outlier.size=-1,width=0.1)+facet_grid(.~Feature,scales='free_x',space='free_x')+theme(strip.text=element_blank(),axis.text.x = element_text(angle = 90, hjust = 1),legend.position = "none")+ggtitle(paste0('Violin-Boxplot of ',plotType))
+ p2=ggplot(dataList,aes(x=Value,alpha=0.5))+geom_histogram(aes(y=..density..),bins=10,color='black')+geom_vline(aes(xintercept=mean(Value)))+geom_vline(aes(xintercept=median(Value)),linetype='longdash')+geom_density(color='black')+facet_grid(.~Feature)+ggtitle(paste0('Histogram of ',plotType))+theme(strip.text=element_blank(),legend.position = "none")
+ p=wrap_plots(p1,p2,nrow=2,heights=c(3,2))
+ if (nGroups>1) {
+ p3=ggplot(dataList,aes(x=GroupID,y=Value,color=GroupID,fill=GroupID))+geom_violin(color='black',alpha=0.5)+geom_jitter(position=position_jitter(0.2),size=0.5)+geom_boxplot(color='black',outlier.size=-1,width=0.1)+facet_grid(.~Feature)+theme(axis.text.x = element_text(angle = 90, hjust = 1),legend.position = "none")+ggtitle(paste0('Violin-Boxplot of ',plotType,' by GroupID'))
+ p4=ggplot(dataList,aes(x=Value,color=GroupID,fill=GroupID,alpha=0.5))+geom_histogram(aes(y=..density..),bins=10)+geom_vline(aes(xintercept=mean(Value)))+geom_vline(aes(xintercept=median(Value)),linetype='longdash')+geom_density(color='black')+facet_grid(.~Feature+GroupID)+ggtitle(paste0('Histogram of ',plotType,' by GroupID'))+theme(legend.position = "none") #strip.text=element_blank() doesn't work with facet grid of >1 variables.
+ p5=wrap_plots(p3,p4,nrow=2,heights=c(3,2))
+ p=wrap_plots(p,p5,ncol=2,widths=c(1,nGroups))
+ }
+ if (nBatches>1) {
+ p6=ggplot(dataList,aes(x=BatchID,y=Value,color=BatchID,fill=BatchID))+geom_violin(color='black',alpha=0.5)+geom_jitter(position=position_jitter(0.2),size=0.5)+geom_boxplot(color='black',outlier.size=-1,width=0.1)+facet_grid(.~Feature)+theme(axis.text.x = element_text(angle = 90, hjust = 1),legend.position = "none")+ggtitle(paste0('Violin-Boxplot of ',plotType,' by BatchID'))
+ p7=ggplot(dataList,aes(x=Value,color=BatchID,fill=BatchID,alpha=0.5))+geom_histogram(aes(y=..density..),bins=10)+geom_vline(aes(xintercept=mean(Value)))+geom_vline(aes(xintercept=median(Value)),linetype='longdash')+geom_density(color='black')+facet_grid(.~Feature+BatchID)+ggtitle(paste0('Histogram of ',plotType,' by BatchID'))+theme(legend.position = "none") #strip.text=element_blank() doesn't work with facet grid of >1 variables.
+ p8=wrap_plots(p6,p7,nrow=2,heights=c(3,2))
+ p=wrap_plots(p,p8,ncol=2,widths=c(1+nGroups,nBatches))
+ }
+ if (nGroups>1&&nBatches>1) {
+ p9=ggplot(dataList,aes(x=GroupID:BatchID,y=Value,color=GroupID:BatchID,fill=GroupID:BatchID))+geom_violin(color='black',alpha=0.5)+geom_jitter(position=position_jitter(0.2),size=0.5)+geom_boxplot(color='black',outlier.size=-1,width=0.1)+facet_grid(.~Feature)+theme(axis.text.x = element_text(angle = 90, hjust = 1),legend.position = "none")+ggtitle(paste0('Violin-Boxplot of ',plotType,' by GroupID:BatchID'))
+ p10=ggplot(dataList,aes(x=Value,color=GroupID:BatchID,fill=GroupID:BatchID,alpha=0.5))+geom_histogram(aes(y=..density..),bins=10)+geom_vline(aes(xintercept=mean(Value)))+geom_vline(aes(xintercept=median(Value)),linetype='longdash')+geom_density(color='black')+facet_grid(.~Feature+GroupID+BatchID)+ggtitle(paste0('Histogram of ',plotType,' by GroupID:BatchID'))+theme(legend.position = "none") #strip.text=element_blank() doesn't work with facet grid of >1 variables.
+ p11=wrap_plots(p9,p10,nrow=2,heights=c(3,2))
+ p=wrap_plots(p,p11,ncol=2,widths=c(1+nGroups+nBatches,length(unique(paste0(dataList$GroupID,'_',dataList$BatchID)))))
+ }
+ ggsave(pdfFile,plot=p,width=48,height=8,units='in',limitsize=F,device=cairo_ps)
+ ggsave(pngFile,plot=p,width=48,height=8,units='in',limitsize=F,type='cairo')
+ insertImage(wbObj$wb,sheetName,pngFile,width=48, height=8, unit='in',startRow=plotPosition*48+2,startCol=1)
+ writeData(wbObj$wb,sheetName,plotType,startRow=plotPosition*48+1,startCol=1)
+ addStyle(wbObj$wb,sheetName,wbObj$style2,rows=plotPosition*48+1,cols=1)
+
+ options(warn=0)
+ message('Finished generating feature figures.')
+ return(wbObj)
+}
+#############################End writeFeatureFigures()#############################
+
+#############################Begin writeEulerDiagrams()#############################
+writeEulerDiagrams=function(wbObj,sheetName,presentGroups,presentSamples,samples,parameters,attributes,plotPosition=1,figuresPath=NULL) {
+ message('Generating Euler diagrams...')
+ if (!sheetName%in%names(wbObj$wb))
+ addWorksheet(wbObj$wb,sheetName)
+ plotPosition=plotPosition-1 #For position 1, plotting starts at row offset 0.
+ p=NULL
+ presentGroups=presentGroups[,colnames(presentGroups)!='Present']>=parameters$groupCountFilter
+ options(warn=-1)
+ if (attributes$nGroups<=6&&attributes$nGroups>1) {
+ p[['groups']]=plot(euler(presentGroups),quantities=T,fill=hue_pal()(attributes$nGroups),fill_alpha=0.5,legend=list(side="bottom"))
+ }
+ presentSamples=presentSamples[,colnames(presentSamples)!='Present']
+ for (i in attributes$groups) {
+ if (sum(samples$GroupID==i)<=6&&sum(samples$GroupID==i)>1) {
+ p[[i]]=plot(euler(presentSamples[,samples$GroupID==i]),quantities=T,fill=hue_pal()(sum(samples$GroupID==i)),fill_alpha=0.5,legend=list(side="bottom"))
+ }
+ }
+ if (!is.null(p)) {
+ p=wrap_plots(p,ncol=length(p)) #From patchwork
+ ggsave(file.path(figuresPath,'Euler_Venn.pdf'),plot=p,width=48,height=8,units='in',limitsize=F,device=cairo_ps)
+ ggsave(file.path(figuresPath,'Euler_Venn.png'),plot=p,width=48,height=8,units='in',limitsize=F,type='cairo')
+ insertImage(wbObj$wb,sheetName,file.path(figuresPath,'Euler_Venn.png'),width=24, height=4, unit='in',startRow=plotPosition*48+2,startCol=1)
+ writeData(wbObj$wb,sheetName,'Euler Diagrams',startRow=plotPosition*48+1,startCol=1)
+ addStyle(wbObj$wb,sheetName,wbObj$style2,rows=plotPosition*48+1,cols=1)
+ }
+ options(warn=0)
+ message('Finished generating Euler diagrams.')
+ return(wbObj)
+}
+#############################End writeEulerDiagrams()#############################
+
+#############################Begin writeVolcanoPlot()#############################
+writeVolcanoPlot=function(wbObj,sheetName,groups,pAndFC,selectedFeatures,parameters,plotPosition,plotNumber=1,figuresPath=NULL){ #Data must be 2-dimensional. Use drop=F when calling this function if dataTable is subsetted.
+ tempData=data.frame(x=log2(pAndFC[,2]),y=-log(pAndFC[,1],10),F)
+ rownames(tempData)=rownames(pAndFC)
+ plotTitle=paste0('Volcano Plot of ',groups[1],' vs. ',groups[2])
+ if (length(selectedFeatures)>0)
+ tempData[,'Selected']=rownames(tempData) %in% selectedFeatures
+ else
+ tempData$Selected=F
+ p=ggplot(data.frame(tempData),aes(x=x,y=y,color=Selected))+scale_color_manual(values=c('black','blue'))+geom_point()+geom_text(aes(label=ifelse(Selected,rownames(tempData),'')),hjust=0, vjust=0)+xlab('Log2(FC)')+ylab(paste0('-Log10(p)'))+ggtitle(plotTitle)+theme(legend.position="none")
+ for (pc in parameters$pCutoffs) {
+ p=p+geom_hline(yintercept=-log(pc,10),linetype="dashed",color = "blue",linewidth=0.2)
+ for (fcc in parameters$fcCutoffs) {
+ p=p+geom_vline(xintercept=log2(fcc),linetype="dashed",color = "blue",linewidth=0.2)
+ p=p+geom_vline(xintercept=-log2(fcc),linetype="dashed",color = "blue",linewidth=0.2)
+ }
+ }
+ plotFile=file.path(figuresPath,paste0(groups[1],'_vs_',groups[2],'.pdf'))
+ plotFile2=file.path(figuresPath,paste0(groups[1],'_vs_',groups[2],'.png'))
+ ggsave(plotFile,plot=p,width=8,height=8,units='in')
+ ggsave(plotFile2,plot=p,width=8,height=8,units='in')
+ plotPosition=plotPosition-1 #For position 1, plotting starts at row offset 0.
+ insertImage(wbObj$wb,sheetName,plotFile2, width=8, height=8, unit='in',startRow=plotPosition*48+2,startCol=(plotNumber-1)*13+1)
+
+ return(wbObj)
+}
+#############################End writeVolcanoPlot()#############################
+
+
diff --git a/V2.2/data_template_V2.2.xlsx b/V2.2/data_template_V2.2.xlsx
new file mode 100755
index 0000000000000000000000000000000000000000..0bdcdf81eccbdfeb0b0b3eb0b2273613e7cc0017
Binary files /dev/null and b/V2.2/data_template_V2.2.xlsx differ
diff --git a/V2.2/oda_analysis.sh b/V2.2/oda_analysis.sh
new file mode 100755
index 0000000000000000000000000000000000000000..34bb1eb7f3a13fe67a0598f05e3197d2b1e6f839
--- /dev/null
+++ b/V2.2/oda_analysis.sh
@@ -0,0 +1,43 @@
+#!/bin/bash
+if [[ $# < 2 ]]
+then
+ echo "########## ODA Tool Usage ##########"
+ echo "If you are a BioHPC user at UTSW, run the following command from a BioHPC terminal:"
+ echo "sh script_path/oda_analysis.sh (this file) input_path/input_file_name.xlsx output_path optional_BioHPC_queue_name"
+ echo
+ echo "If you are not a BioHPC user and have installed R locally, run the following command from your computer's terminal/shell with Singularity:"
+ echo "Rscript script_path/ODA.R input_path/input_file_name.xlsx output_path"
+ echo
+ echo "Alternatively, you can run the following command if you have bash for the local terminal/shell with Singularity:"
+ echo "sh script_path/oda_analysis.sh (this file) input_path/input_file_name.xlsx output_path local"
+ echo "########## ODA Tool Usage ##########"
+ exit
+fi
+ODA_DIR=`dirname $0`
+INPUT_FILE=$1
+OUTPUT_FOLDER=$2
+QUEUE=$3
+if [ "$QUEUE" == "" ]
+then
+ QUEUE=local
+fi
+
+if [ -d "$OUTPUT_FOLDER" ]
+then
+ echo "Output folder \""$OUTPUT_FOLDER"\" exists. Delete (Y/N)?"
+ read DELETE_FOLDER
+ if [ "$DELETE_FOLDER" == "Y" ]
+ then
+ rm -R $OUTPUT_FOLDER
+ mkdir -p $OUTPUT_FOLDER
+ echo "Output folder is deleted. Analysis under the folder will be rerun."
+ else
+ echo "CAUTION: Output folder is NOT deleted. New analysis result will be saved in the existing folder. Result files will be overwritten if they have the same names with the previous ones."
+ fi
+fi
+if [ "$QUEUE" == "local" ]
+then
+ sh $ODA_DIR/run_analysis.sh $ODA_DIR $INPUT_FILE $OUTPUT_FOLDER
+else
+ sbatch -p $QUEUE $ODA_DIR/run_analysis.sh $ODA_DIR $INPUT_FILE $OUTPUT_FOLDER
+fi
diff --git a/V2.2/r_with_packages_4.3.2.sif b/V2.2/r_with_packages_4.3.2.sif
new file mode 120000
index 0000000000000000000000000000000000000000..98ce91da29a337b431a0360a8d0f5c8d299f5785
--- /dev/null
+++ b/V2.2/r_with_packages_4.3.2.sif
@@ -0,0 +1 @@
+/archive/CRI/shared/Singularity/zzy/r_with_packages_4.3.2.sif
\ No newline at end of file
diff --git a/V2.2/run_analysis.sh b/V2.2/run_analysis.sh
new file mode 100644
index 0000000000000000000000000000000000000000..98225a0c63f5e1480756d5b0c4be276b077013fe
--- /dev/null
+++ b/V2.2/run_analysis.sh
@@ -0,0 +1,9 @@
+#!/bin/bash
+module load singularity/3.9.9
+ODA_DIR=$1
+ODA_MODULE=$ODA_DIR/r_with_packages_4.3.2.sif #Link to: /archive/CRI/shared/Singularity/zzy/r_w_packages_4.3.2.sif
+INPUT_FILE=$2
+OUTPUT_FOLDER=$3
+echo $ODA_MODULE
+singularity exec $ODA_MODULE Rscript $ODA_DIR/ODA/ODA.R $INPUT_FILE $OUTPUT_FOLDER 2>&1 | tee -a "$OUTPUT_FOLDER/ODA_run"$(date +%s"."%N)".log"
+
diff --git a/archived/V2.1/CRI_HMDB_KEGG_IDs.xlsx b/archived/V2.1/CRI_HMDB_KEGG_IDs.xlsx
new file mode 100755
index 0000000000000000000000000000000000000000..65f7dcfceba68514955686a1a034a78b8c89ee9d
Binary files /dev/null and b/archived/V2.1/CRI_HMDB_KEGG_IDs.xlsx differ
diff --git a/V2.1/FileExamples/Customized_DB_for_Enrichment_or_Pathway_Analysis/customized_DB_example_HMDB.csv b/archived/V2.1/FileExamples/Customized_DB_for_Enrichment_or_Pathway_Analysis/customized_DB_example_HMDB.csv
similarity index 100%
rename from V2.1/FileExamples/Customized_DB_for_Enrichment_or_Pathway_Analysis/customized_DB_example_HMDB.csv
rename to archived/V2.1/FileExamples/Customized_DB_for_Enrichment_or_Pathway_Analysis/customized_DB_example_HMDB.csv
diff --git a/V2.1/FileExamples/Customized_DB_for_Enrichment_or_Pathway_Analysis/customized_DB_example_KEGG.csv b/archived/V2.1/FileExamples/Customized_DB_for_Enrichment_or_Pathway_Analysis/customized_DB_example_KEGG.csv
similarity index 100%
rename from V2.1/FileExamples/Customized_DB_for_Enrichment_or_Pathway_Analysis/customized_DB_example_KEGG.csv
rename to archived/V2.1/FileExamples/Customized_DB_for_Enrichment_or_Pathway_Analysis/customized_DB_example_KEGG.csv
diff --git a/V2.1/FileExamples/Customized_DB_for_Enrichment_or_Pathway_Analysis/customized_DB_example_Name.csv b/archived/V2.1/FileExamples/Customized_DB_for_Enrichment_or_Pathway_Analysis/customized_DB_example_Name.csv
similarity index 100%
rename from V2.1/FileExamples/Customized_DB_for_Enrichment_or_Pathway_Analysis/customized_DB_example_Name.csv
rename to archived/V2.1/FileExamples/Customized_DB_for_Enrichment_or_Pathway_Analysis/customized_DB_example_Name.csv
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Data.xlsx b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Data.xlsx
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Data.xlsx
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Data.xlsx
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result.xlsx b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result.xlsx
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result.xlsx
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result.xlsx
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/QC_AB_vs_A_volcano.png b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/QC_AB_vs_A_volcano.png
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/QC_AB_vs_A_volcano.png
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/QC_AB_vs_A_volcano.png
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/QC_AB_vs_A_volcano.ps b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/QC_AB_vs_A_volcano.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/QC_AB_vs_A_volcano.ps
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/QC_AB_vs_A_volcano.ps
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/QC_AB_vs_B_volcano.png b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/QC_AB_vs_B_volcano.png
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/QC_AB_vs_B_volcano.png
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/QC_AB_vs_B_volcano.png
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/QC_AB_vs_B_volcano.ps b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/QC_AB_vs_B_volcano.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/QC_AB_vs_B_volcano.ps
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/QC_AB_vs_B_volcano.ps
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/QC_CD_vs_C_volcano.png b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/QC_CD_vs_C_volcano.png
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/QC_CD_vs_C_volcano.png
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/QC_CD_vs_C_volcano.png
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/QC_CD_vs_C_volcano.ps b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/QC_CD_vs_C_volcano.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/QC_CD_vs_C_volcano.ps
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/QC_CD_vs_C_volcano.ps
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/QC_CD_vs_D_volcano.png b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/QC_CD_vs_D_volcano.png
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/QC_CD_vs_D_volcano.png
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/QC_CD_vs_D_volcano.png
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/QC_CD_vs_D_volcano.ps b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/QC_CD_vs_D_volcano.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/QC_CD_vs_D_volcano.ps
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/QC_CD_vs_D_volcano.ps
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_1.png b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_1.png
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_1.png
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_1.png
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_1.ps b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_1.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_1.ps
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_1.ps
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_2.png b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_2.png
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_2.png
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_2.png
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_2.ps b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_2.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_2.ps
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_2.ps
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_3.png b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_3.png
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_3.png
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_3.png
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_3.ps b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_3.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_3.ps
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_3.ps
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_4.png b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_4.png
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_4.png
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_4.png
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_4.ps b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_4.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_4.ps
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_4.ps
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_5.png b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_5.png
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_5.png
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_5.png
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_5.ps b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_5.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_5.ps
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_5.ps
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_6.png b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_6.png
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_6.png
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_6.png
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_6.ps b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_6.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_6.ps
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_6.ps
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_all.png b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_all.png
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_all.png
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_all.png
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_all.ps b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_all.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_all.ps
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/euler_all.ps
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/log2.png b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/log2.png
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/log2.png
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/log2.png
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/log2.ps b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/log2.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/log2.ps
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/log2.ps
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/log2_heatmap.png b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/log2_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/log2_heatmap.png
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/log2_heatmap.png
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/log2_heatmap.ps b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/log2_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/log2_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/log2_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/log2_pca_cor.png b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/log2_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/log2_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/log2_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/log2_pca_cor.ps b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/log2_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/log2_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/log2_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/log2_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/log2_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/log2_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/log2_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/log2_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/log2_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/log2_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/log2_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/raw.png b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/raw.png
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/raw.png
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/raw.png
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/raw.ps b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/raw.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/raw.ps
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/raw.ps
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/raw_heatmap.png b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/raw_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/raw_heatmap.png
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/raw_heatmap.png
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/raw_heatmap.ps b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/raw_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/raw_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/raw_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/raw_pca_cor.png b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/raw_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/raw_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/raw_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/raw_pca_cor.ps b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/raw_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/raw_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/raw_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/raw_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/raw_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/raw_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/raw_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/raw_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/raw_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/raw_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/1_Raw_Data_QC/Result_Figures/raw_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Data.xlsx b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Data.xlsx
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Data.xlsx
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Data.xlsx
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result.xlsx b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result.xlsx
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result.xlsx
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result.xlsx
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/A_vs_B_volcano.png b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/A_vs_B_volcano.png
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/A_vs_B_volcano.png
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/A_vs_B_volcano.png
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/A_vs_B_volcano.ps b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/A_vs_B_volcano.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/A_vs_B_volcano.ps
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/A_vs_B_volcano.ps
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/C_vs_D_volcano.png b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/C_vs_D_volcano.png
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/C_vs_D_volcano.png
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/C_vs_D_volcano.png
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/C_vs_D_volcano.ps b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/C_vs_D_volcano.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/C_vs_D_volcano.ps
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/C_vs_D_volcano.ps
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_1.png b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_1.png
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_1.png
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_1.png
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_1.ps b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_1.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_1.ps
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_1.ps
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_2.png b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_2.png
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_2.png
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_2.png
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_2.ps b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_2.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_2.ps
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_2.ps
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_3.png b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_3.png
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_3.png
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_3.png
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_3.ps b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_3.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_3.ps
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_3.ps
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_4.png b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_4.png
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_4.png
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_4.png
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_4.ps b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_4.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_4.ps
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_4.ps
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_all.png b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_all.png
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_all.png
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_all.png
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_all.ps b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_all.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_all.ps
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/euler_all.ps
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2.png b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2.png
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2.png
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2.png
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2.ps b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2.ps
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2.ps
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_heatmap.png b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_heatmap.png
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_heatmap.png
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_heatmap.ps b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_norm.png b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_norm.png
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_norm.png
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_norm.png
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_norm.ps b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_norm.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_norm.ps
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_norm.ps
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_norm_heatmap.png b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_norm_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_norm_heatmap.png
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_norm_heatmap.png
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_norm_heatmap.ps b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_norm_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_norm_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_norm_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_norm_pca_cor.png b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_norm_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_norm_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_norm_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_norm_pca_cor.ps b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_norm_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_norm_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_norm_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_norm_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_norm_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_norm_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_norm_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_norm_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_norm_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_norm_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_norm_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_pca_cor.png b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_pca_cor.ps b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/log2_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/norm.png b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/norm.png
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/norm.png
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/norm.png
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/norm.ps b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/norm.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/norm.ps
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/norm.ps
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/norm_heatmap.png b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/norm_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/norm_heatmap.png
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/norm_heatmap.png
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/norm_heatmap.ps b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/norm_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/norm_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/norm_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/norm_pca_cor.png b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/norm_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/norm_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/norm_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/norm_pca_cor.ps b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/norm_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/norm_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/norm_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/norm_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/norm_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/norm_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/norm_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/norm_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/norm_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/norm_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/norm_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/raw.png b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/raw.png
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/raw.png
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/raw.png
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/raw.ps b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/raw.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/raw.ps
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/raw.ps
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/raw_heatmap.png b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/raw_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/raw_heatmap.png
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/raw_heatmap.png
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/raw_heatmap.ps b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/raw_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/raw_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/raw_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/raw_pca_cor.png b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/raw_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/raw_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/raw_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/raw_pca_cor.ps b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/raw_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/raw_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/raw_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/raw_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/raw_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/raw_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/raw_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/raw_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/raw_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/raw_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/raw_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/sizes.png b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/sizes.png
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/sizes.png
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/sizes.png
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/sizes.ps b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/sizes.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/sizes.ps
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/sizes.ps
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/sizes_heatmap.png b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/sizes_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/sizes_heatmap.png
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/sizes_heatmap.png
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/sizes_heatmap.ps b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/sizes_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/sizes_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/sizes_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/sizes_pca_cor.png b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/sizes_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/sizes_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/sizes_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/sizes_pca_cor.ps b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/sizes_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/sizes_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/sizes_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/sizes_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/sizes_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/sizes_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/sizes_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/sizes_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/sizes_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/sizes_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/2_QC_Excluded_Normalized_Data_Differential_Intensities/Result_Figures/sizes_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Data.xlsx b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Data.xlsx
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Data.xlsx
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Data.xlsx
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result.xlsx b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result.xlsx
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result.xlsx
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result.xlsx
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/A_vs_B_volcano.png b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/A_vs_B_volcano.png
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/A_vs_B_volcano.png
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/A_vs_B_volcano.png
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/A_vs_B_volcano.ps b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/A_vs_B_volcano.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/A_vs_B_volcano.ps
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/A_vs_B_volcano.ps
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/C_vs_D_volcano.png b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/C_vs_D_volcano.png
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/C_vs_D_volcano.png
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/C_vs_D_volcano.png
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/C_vs_D_volcano.ps b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/C_vs_D_volcano.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/C_vs_D_volcano.ps
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/C_vs_D_volcano.ps
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_1.png b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_1.png
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_1.png
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_1.png
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_1.ps b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_1.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_1.ps
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_1.ps
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_2.png b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_2.png
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_2.png
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_2.png
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_2.ps b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_2.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_2.ps
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_2.ps
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_3.png b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_3.png
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_3.png
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_3.png
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_3.ps b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_3.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_3.ps
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_3.ps
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_4.png b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_4.png
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_4.png
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_4.png
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_4.ps b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_4.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_4.ps
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_4.ps
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_all.png b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_all.png
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_all.png
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_all.png
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_all.ps b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_all.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_all.ps
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/euler_all.ps
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2.png b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2.png
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2.png
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2.png
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2.ps b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2.ps
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2.ps
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_heatmap.png b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_heatmap.png
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_heatmap.png
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_heatmap.ps b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_norm.png b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_norm.png
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_norm.png
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_norm.png
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_norm.ps b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_norm.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_norm.ps
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_norm.ps
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_norm_heatmap.png b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_norm_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_norm_heatmap.png
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_norm_heatmap.png
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_norm_heatmap.ps b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_norm_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_norm_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_norm_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_norm_pca_cor.png b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_norm_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_norm_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_norm_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_norm_pca_cor.ps b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_norm_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_norm_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_norm_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_norm_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_norm_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_norm_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_norm_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_norm_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_norm_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_norm_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_norm_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_pca_cor.png b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_pca_cor.ps b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/log2_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/norm.png b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/norm.png
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/norm.png
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/norm.png
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/norm.ps b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/norm.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/norm.ps
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/norm.ps
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/norm_heatmap.png b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/norm_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/norm_heatmap.png
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/norm_heatmap.png
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/norm_heatmap.ps b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/norm_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/norm_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/norm_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/norm_pca_cor.png b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/norm_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/norm_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/norm_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/norm_pca_cor.ps b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/norm_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/norm_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/norm_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/norm_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/norm_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/norm_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/norm_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/norm_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/norm_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/norm_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/norm_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/raw.png b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/raw.png
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/raw.png
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/raw.png
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/raw.ps b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/raw.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/raw.ps
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/raw.ps
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/raw_heatmap.png b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/raw_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/raw_heatmap.png
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/raw_heatmap.png
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/raw_heatmap.ps b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/raw_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/raw_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/raw_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/raw_pca_cor.png b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/raw_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/raw_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/raw_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/raw_pca_cor.ps b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/raw_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/raw_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/raw_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/raw_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/raw_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/raw_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/raw_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/raw_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/raw_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/raw_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/raw_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/sizes.png b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/sizes.png
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/sizes.png
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/sizes.png
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/sizes.ps b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/sizes.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/sizes.ps
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/sizes.ps
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/sizes_heatmap.png b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/sizes_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/sizes_heatmap.png
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/sizes_heatmap.png
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/sizes_heatmap.ps b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/sizes_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/sizes_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/sizes_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/sizes_pca_cor.png b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/sizes_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/sizes_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/sizes_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/sizes_pca_cor.ps b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/sizes_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/sizes_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/sizes_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/sizes_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/sizes_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/sizes_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/sizes_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/sizes_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/sizes_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/sizes_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/3_Technical_Replicates/Result_Figures/sizes_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Data.xlsx b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Data.xlsx
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Data.xlsx
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Data.xlsx
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result.xlsx b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result.xlsx
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result.xlsx
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result.xlsx
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/A_vs_B_volcano.png b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/A_vs_B_volcano.png
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/A_vs_B_volcano.png
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/A_vs_B_volcano.png
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/A_vs_B_volcano.ps b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/A_vs_B_volcano.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/A_vs_B_volcano.ps
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/A_vs_B_volcano.ps
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/C_vs_D_volcano.png b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/C_vs_D_volcano.png
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/C_vs_D_volcano.png
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/C_vs_D_volcano.png
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/C_vs_D_volcano.ps b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/C_vs_D_volcano.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/C_vs_D_volcano.ps
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/C_vs_D_volcano.ps
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_1.png b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_1.png
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_1.png
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_1.png
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_1.ps b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_1.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_1.ps
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_1.ps
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_2.png b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_2.png
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_2.png
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_2.png
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_2.ps b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_2.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_2.ps
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_2.ps
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_3.png b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_3.png
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_3.png
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_3.png
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_3.ps b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_3.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_3.ps
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_3.ps
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_4.png b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_4.png
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_4.png
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_4.png
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_4.ps b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_4.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_4.ps
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_4.ps
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_all.png b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_all.png
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_all.png
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_all.png
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_all.ps b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_all.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_all.ps
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/euler_all.ps
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2.png b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2.png
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2.png
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2.png
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2.ps b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2.ps
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2.ps
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_heatmap.png b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_heatmap.png
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_heatmap.png
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_heatmap.ps b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_norm.png b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_norm.png
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_norm.png
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_norm.png
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_norm.ps b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_norm.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_norm.ps
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_norm.ps
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_norm_heatmap.png b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_norm_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_norm_heatmap.png
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_norm_heatmap.png
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_norm_heatmap.ps b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_norm_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_norm_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_norm_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_norm_pca_cor.png b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_norm_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_norm_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_norm_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_norm_pca_cor.ps b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_norm_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_norm_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_norm_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_norm_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_norm_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_norm_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_norm_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_norm_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_norm_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_norm_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_norm_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_pca_cor.png b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_pca_cor.ps b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/log2_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/norm.png b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/norm.png
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/norm.png
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/norm.png
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/norm.ps b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/norm.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/norm.ps
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/norm.ps
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/norm_heatmap.png b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/norm_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/norm_heatmap.png
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/norm_heatmap.png
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/norm_heatmap.ps b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/norm_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/norm_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/norm_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/norm_pca_cor.png b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/norm_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/norm_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/norm_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/norm_pca_cor.ps b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/norm_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/norm_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/norm_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/norm_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/norm_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/norm_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/norm_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/norm_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/norm_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/norm_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/norm_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/raw.png b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/raw.png
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/raw.png
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/raw.png
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/raw.ps b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/raw.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/raw.ps
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/raw.ps
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/raw_heatmap.png b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/raw_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/raw_heatmap.png
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/raw_heatmap.png
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/raw_heatmap.ps b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/raw_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/raw_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/raw_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/raw_pca_cor.png b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/raw_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/raw_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/raw_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/raw_pca_cor.ps b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/raw_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/raw_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/raw_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/raw_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/raw_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/raw_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/raw_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/raw_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/raw_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/raw_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/raw_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/sizes.png b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/sizes.png
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/sizes.png
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/sizes.png
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/sizes.ps b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/sizes.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/sizes.ps
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/sizes.ps
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/sizes_heatmap.png b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/sizes_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/sizes_heatmap.png
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/sizes_heatmap.png
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/sizes_heatmap.ps b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/sizes_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/sizes_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/sizes_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/sizes_pca_cor.png b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/sizes_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/sizes_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/sizes_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/sizes_pca_cor.ps b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/sizes_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/sizes_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/sizes_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/sizes_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/sizes_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/sizes_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/sizes_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/sizes_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/sizes_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/sizes_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/4_Multiple_Batches/Result_Figures/sizes_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Data.xlsx b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Data.xlsx
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Data.xlsx
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Data.xlsx
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result.xlsx b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result.xlsx
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result.xlsx
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result.xlsx
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/A_vs_B_volcano.png b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/A_vs_B_volcano.png
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/A_vs_B_volcano.png
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/A_vs_B_volcano.png
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/A_vs_B_volcano.ps b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/A_vs_B_volcano.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/A_vs_B_volcano.ps
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/A_vs_B_volcano.ps
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/C_vs_D_volcano.png b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/C_vs_D_volcano.png
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/C_vs_D_volcano.png
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/C_vs_D_volcano.png
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/C_vs_D_volcano.ps b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/C_vs_D_volcano.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/C_vs_D_volcano.ps
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/C_vs_D_volcano.ps
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_1.png b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_1.png
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_1.png
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_1.png
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_1.ps b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_1.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_1.ps
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_1.ps
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_2.png b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_2.png
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_2.png
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_2.png
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_2.ps b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_2.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_2.ps
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_2.ps
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_3.png b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_3.png
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_3.png
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_3.png
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_3.ps b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_3.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_3.ps
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_3.ps
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_4.png b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_4.png
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_4.png
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_4.png
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_4.ps b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_4.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_4.ps
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_4.ps
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_all.png b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_all.png
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_all.png
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_all.png
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_all.ps b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_all.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_all.ps
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/euler_all.ps
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2.png b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2.png
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2.png
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2.png
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2.ps b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2.ps
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2.ps
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_heatmap.png b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_heatmap.png
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_heatmap.png
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_heatmap.ps b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_norm.png b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_norm.png
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_norm.png
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_norm.png
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_norm.ps b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_norm.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_norm.ps
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_norm.ps
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_norm_heatmap.png b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_norm_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_norm_heatmap.png
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_norm_heatmap.png
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_norm_heatmap.ps b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_norm_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_norm_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_norm_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_norm_pca_cor.png b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_norm_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_norm_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_norm_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_norm_pca_cor.ps b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_norm_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_norm_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_norm_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_norm_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_norm_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_norm_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_norm_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_norm_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_norm_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_norm_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_norm_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_pca_cor.png b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_pca_cor.ps b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/log2_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/norm.png b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/norm.png
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/norm.png
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/norm.png
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/norm.ps b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/norm.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/norm.ps
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/norm.ps
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/norm_heatmap.png b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/norm_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/norm_heatmap.png
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/norm_heatmap.png
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/norm_heatmap.ps b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/norm_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/norm_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/norm_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/norm_pca_cor.png b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/norm_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/norm_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/norm_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/norm_pca_cor.ps b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/norm_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/norm_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/norm_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/norm_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/norm_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/norm_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/norm_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/norm_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/norm_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/norm_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/norm_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/raw.png b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/raw.png
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/raw.png
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/raw.png
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/raw.ps b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/raw.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/raw.ps
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/raw.ps
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/raw_heatmap.png b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/raw_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/raw_heatmap.png
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/raw_heatmap.png
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/raw_heatmap.ps b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/raw_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/raw_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/raw_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/raw_pca_cor.png b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/raw_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/raw_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/raw_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/raw_pca_cor.ps b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/raw_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/raw_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/raw_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/raw_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/raw_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/raw_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/raw_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/raw_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/raw_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/raw_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/raw_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/sizes.png b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/sizes.png
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/sizes.png
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/sizes.png
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/sizes.ps b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/sizes.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/sizes.ps
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/sizes.ps
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/sizes_heatmap.png b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/sizes_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/sizes_heatmap.png
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/sizes_heatmap.png
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/sizes_heatmap.ps b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/sizes_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/sizes_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/sizes_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/sizes_pca_cor.png b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/sizes_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/sizes_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/sizes_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/sizes_pca_cor.ps b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/sizes_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/sizes_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/sizes_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/sizes_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/sizes_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/sizes_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/sizes_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/sizes_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/sizes_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/sizes_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/5_Paired_or_Matched_Samples/Result_Figures/sizes_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Data.xlsx b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Data.xlsx
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Data.xlsx
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Data.xlsx
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result.xlsx b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result.xlsx
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result.xlsx
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result.xlsx
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/A_vs_B_volcano.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/A_vs_B_volcano.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/A_vs_B_volcano.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/A_vs_B_volcano.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/A_vs_B_volcano.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/A_vs_B_volcano.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/A_vs_B_volcano.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/A_vs_B_volcano.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/C_vs_D_volcano.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/C_vs_D_volcano.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/C_vs_D_volcano.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/C_vs_D_volcano.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/C_vs_D_volcano.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/C_vs_D_volcano.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/C_vs_D_volcano.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/C_vs_D_volcano.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_1.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_1.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_1.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_1.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_1.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_1.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_1.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_1.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_2.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_2.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_2.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_2.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_2.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_2.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_2.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_2.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_3.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_3.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_3.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_3.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_3.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_3.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_3.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_3.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_4.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_4.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_4.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_4.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_4.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_4.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_4.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_4.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_all.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_all.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_all.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_all.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_all.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_all.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_all.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/euler_all.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_features.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_features.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_features.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_features.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_features.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_features.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_features.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_features.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_features_heatmap.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_features_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_features_heatmap.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_features_heatmap.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_features_heatmap.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_features_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_features_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_features_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_features_pca_cor.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_features_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_features_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_features_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_features_pca_cor.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_features_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_features_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_features_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_features_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_features_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_features_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_features_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_features_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_features_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_features_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_features_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_heatmap.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_heatmap.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_heatmap.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_heatmap.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_features.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_features.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_features.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_features.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_features.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_features.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_features.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_features.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_features_heatmap.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_features_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_features_heatmap.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_features_heatmap.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_features_heatmap.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_features_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_features_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_features_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_features_pca_cor.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_features_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_features_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_features_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_features_pca_cor.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_features_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_features_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_features_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_features_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_features_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_features_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_features_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_features_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_features_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_features_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_features_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_heatmap.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_heatmap.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_heatmap.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_heatmap.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_pca_cor.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_pca_cor.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_norm_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_pca_cor.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_pca_cor.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/log2_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_features.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_features.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_features.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_features.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_features.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_features.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_features.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_features.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_features_heatmap.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_features_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_features_heatmap.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_features_heatmap.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_features_heatmap.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_features_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_features_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_features_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_features_pca_cor.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_features_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_features_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_features_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_features_pca_cor.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_features_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_features_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_features_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_features_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_features_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_features_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_features_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_features_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_features_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_features_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_features_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_heatmap.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_heatmap.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_heatmap.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_heatmap.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_pca_cor.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_pca_cor.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/norm_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_features.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_features.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_features.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_features.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_features.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_features.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_features.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_features.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_features_heatmap.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_features_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_features_heatmap.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_features_heatmap.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_features_heatmap.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_features_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_features_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_features_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_features_pca_cor.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_features_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_features_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_features_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_features_pca_cor.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_features_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_features_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_features_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_features_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_features_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_features_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_features_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_features_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_features_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_features_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_features_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_heatmap.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_heatmap.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_heatmap.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_heatmap.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_pca_cor.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_pca_cor.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/raw_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes_features.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes_features.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes_features.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes_features.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes_features.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes_features.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes_features.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes_features.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes_heatmap.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes_heatmap.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes_heatmap.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes_heatmap.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes_pca_cor.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes_pca_cor.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/6_Interested_and_Excluded_Features/Result_Figures/sizes_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Data.xlsx b/archived/V2.1/FileExamples/Examples/7_List_Data/Data.xlsx
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Data.xlsx
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Data.xlsx
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result.xlsx b/archived/V2.1/FileExamples/Examples/7_List_Data/Result.xlsx
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result.xlsx
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result.xlsx
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/A_vs_B_volcano.png b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/A_vs_B_volcano.png
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/A_vs_B_volcano.png
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/A_vs_B_volcano.png
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/A_vs_B_volcano.ps b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/A_vs_B_volcano.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/A_vs_B_volcano.ps
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/A_vs_B_volcano.ps
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/euler_1.png b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/euler_1.png
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/euler_1.png
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/euler_1.png
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/euler_1.ps b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/euler_1.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/euler_1.ps
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/euler_1.ps
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/euler_2.png b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/euler_2.png
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/euler_2.png
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/euler_2.png
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/euler_2.ps b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/euler_2.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/euler_2.ps
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/euler_2.ps
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/euler_all.png b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/euler_all.png
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/euler_all.png
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/euler_all.png
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/euler_all.ps b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/euler_all.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/euler_all.ps
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/euler_all.ps
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2.png b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2.png
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2.png
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2.png
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2.ps b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2.ps
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2.ps
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_heatmap.png b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_heatmap.png
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_heatmap.png
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_heatmap.ps b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_norm.png b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_norm.png
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_norm.png
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_norm.png
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_norm.ps b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_norm.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_norm.ps
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_norm.ps
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_norm_heatmap.png b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_norm_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_norm_heatmap.png
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_norm_heatmap.png
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_norm_heatmap.ps b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_norm_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_norm_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_norm_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_norm_pca_cor.png b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_norm_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_norm_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_norm_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_norm_pca_cor.ps b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_norm_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_norm_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_norm_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_norm_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_norm_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_norm_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_norm_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_norm_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_norm_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_norm_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_norm_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_pca_cor.png b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_pca_cor.ps b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/log2_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/norm.png b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/norm.png
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/norm.png
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/norm.png
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/norm.ps b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/norm.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/norm.ps
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/norm.ps
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/norm_heatmap.png b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/norm_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/norm_heatmap.png
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/norm_heatmap.png
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/norm_heatmap.ps b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/norm_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/norm_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/norm_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/norm_pca_cor.png b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/norm_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/norm_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/norm_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/norm_pca_cor.ps b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/norm_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/norm_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/norm_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/norm_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/norm_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/norm_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/norm_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/norm_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/norm_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/norm_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/norm_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/raw.png b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/raw.png
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/raw.png
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/raw.png
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/raw.ps b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/raw.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/raw.ps
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/raw.ps
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/raw_heatmap.png b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/raw_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/raw_heatmap.png
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/raw_heatmap.png
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/raw_heatmap.ps b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/raw_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/raw_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/raw_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/raw_pca_cor.png b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/raw_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/raw_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/raw_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/raw_pca_cor.ps b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/raw_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/raw_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/raw_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/raw_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/raw_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/raw_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/raw_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/raw_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/raw_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/raw_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/raw_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/sizes.png b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/sizes.png
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/sizes.png
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/sizes.png
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/sizes.ps b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/sizes.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/sizes.ps
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/sizes.ps
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/sizes_heatmap.png b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/sizes_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/sizes_heatmap.png
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/sizes_heatmap.png
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/sizes_heatmap.ps b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/sizes_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/sizes_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/sizes_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/sizes_pca_cor.png b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/sizes_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/sizes_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/sizes_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/sizes_pca_cor.ps b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/sizes_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/sizes_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/sizes_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/sizes_scaled_heatmap.png b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/sizes_scaled_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/sizes_scaled_heatmap.png
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/sizes_scaled_heatmap.png
diff --git a/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/sizes_scaled_heatmap.ps b/archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/sizes_scaled_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/7_List_Data/Result_Figures/sizes_scaled_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/7_List_Data/Result_Figures/sizes_scaled_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/8_Ratio_Data/Data.xlsx b/archived/V2.1/FileExamples/Examples/8_Ratio_Data/Data.xlsx
similarity index 100%
rename from V2.1/FileExamples/Examples/8_Ratio_Data/Data.xlsx
rename to archived/V2.1/FileExamples/Examples/8_Ratio_Data/Data.xlsx
diff --git a/V2.1/FileExamples/Examples/8_Ratio_Data/Result.xlsx b/archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result.xlsx
similarity index 100%
rename from V2.1/FileExamples/Examples/8_Ratio_Data/Result.xlsx
rename to archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result.xlsx
diff --git a/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/E_vs_P_volcano.png b/archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/E_vs_P_volcano.png
similarity index 100%
rename from V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/E_vs_P_volcano.png
rename to archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/E_vs_P_volcano.png
diff --git a/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/E_vs_P_volcano.ps b/archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/E_vs_P_volcano.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/E_vs_P_volcano.ps
rename to archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/E_vs_P_volcano.ps
diff --git a/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/euler_all.png b/archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/euler_all.png
similarity index 100%
rename from V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/euler_all.png
rename to archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/euler_all.png
diff --git a/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/euler_all.ps b/archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/euler_all.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/euler_all.ps
rename to archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/euler_all.ps
diff --git a/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/log2.png b/archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/log2.png
similarity index 100%
rename from V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/log2.png
rename to archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/log2.png
diff --git a/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/log2.ps b/archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/log2.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/log2.ps
rename to archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/log2.ps
diff --git a/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/log2_heatmap.png b/archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/log2_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/log2_heatmap.png
rename to archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/log2_heatmap.png
diff --git a/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/log2_heatmap.ps b/archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/log2_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/log2_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/log2_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/log2_pca_cor.png b/archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/log2_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/log2_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/log2_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/log2_pca_cor.ps b/archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/log2_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/log2_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/log2_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/raw.png b/archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/raw.png
similarity index 100%
rename from V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/raw.png
rename to archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/raw.png
diff --git a/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/raw.ps b/archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/raw.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/raw.ps
rename to archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/raw.ps
diff --git a/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/raw_heatmap.png b/archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/raw_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/raw_heatmap.png
rename to archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/raw_heatmap.png
diff --git a/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/raw_heatmap.ps b/archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/raw_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/raw_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/raw_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/raw_pca_cor.png b/archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/raw_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/raw_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/raw_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/raw_pca_cor.ps b/archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/raw_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/raw_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/raw_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/transformed.png b/archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/transformed.png
similarity index 100%
rename from V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/transformed.png
rename to archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/transformed.png
diff --git a/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/transformed.ps b/archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/transformed.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/transformed.ps
rename to archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/transformed.ps
diff --git a/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/transformed_heatmap.png b/archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/transformed_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/transformed_heatmap.png
rename to archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/transformed_heatmap.png
diff --git a/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/transformed_heatmap.ps b/archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/transformed_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/transformed_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/transformed_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/transformed_pca_cor.png b/archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/transformed_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/transformed_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/transformed_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/transformed_pca_cor.ps b/archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/transformed_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/transformed_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/8_Ratio_Data/Result_Figures/transformed_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/.~Result.xlsx b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/.~Result.xlsx
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/.~Result.xlsx
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/.~Result.xlsx
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Data.xlsx b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Data.xlsx
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Data.xlsx
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Data.xlsx
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result.xlsx b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result.xlsx
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result.xlsx
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result.xlsx
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/A_vs_B_volcano.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/A_vs_B_volcano.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/A_vs_B_volcano.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/A_vs_B_volcano.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/A_vs_B_volcano.ps b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/A_vs_B_volcano.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/A_vs_B_volcano.ps
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/A_vs_B_volcano.ps
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/A_vs_C_volcano.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/A_vs_C_volcano.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/A_vs_C_volcano.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/A_vs_C_volcano.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/A_vs_C_volcano.ps b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/A_vs_C_volcano.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/A_vs_C_volcano.ps
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/A_vs_C_volcano.ps
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/A_vs_D_volcano.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/A_vs_D_volcano.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/A_vs_D_volcano.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/A_vs_D_volcano.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/A_vs_D_volcano.ps b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/A_vs_D_volcano.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/A_vs_D_volcano.ps
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/A_vs_D_volcano.ps
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/C_vs_D_volcano.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/C_vs_D_volcano.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/C_vs_D_volcano.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/C_vs_D_volcano.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/C_vs_D_volcano.ps b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/C_vs_D_volcano.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/C_vs_D_volcano.ps
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/C_vs_D_volcano.ps
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_1.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_1.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_1.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_1.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_1.ps b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_1.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_1.ps
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_1.ps
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_2.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_2.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_2.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_2.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_2.ps b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_2.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_2.ps
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_2.ps
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_3.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_3.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_3.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_3.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_3.ps b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_3.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_3.ps
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_3.ps
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_4.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_4.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_4.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_4.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_4.ps b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_4.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_4.ps
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_4.ps
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_all.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_all.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_all.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_all.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_all.ps b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_all.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_all.ps
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/euler_all.ps
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2.ps b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2.ps
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2.ps
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_features.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_features.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_features.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_features.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_features.ps b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_features.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_features.ps
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_features.ps
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_features_heatmap.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_features_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_features_heatmap.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_features_heatmap.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_features_heatmap.ps b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_features_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_features_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_features_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_features_pca_cor.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_features_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_features_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_features_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_features_pca_cor.ps b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_features_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_features_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_features_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_heatmap.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_heatmap.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_heatmap.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_heatmap.ps b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_pca_cor.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_pca_cor.ps b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/log2_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw.ps b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw.ps
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw.ps
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_features.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_features.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_features.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_features.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_features.ps b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_features.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_features.ps
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_features.ps
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_features_heatmap.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_features_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_features_heatmap.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_features_heatmap.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_features_heatmap.ps b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_features_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_features_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_features_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_features_pca_cor.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_features_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_features_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_features_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_features_pca_cor.ps b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_features_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_features_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_features_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_heatmap.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_heatmap.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_heatmap.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_heatmap.ps b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_pca_cor.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_pca_cor.ps b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/raw_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/sizes.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/sizes.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/sizes.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/sizes.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/sizes.ps b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/sizes.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/sizes.ps
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/sizes.ps
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/sizes_heatmap.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/sizes_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/sizes_heatmap.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/sizes_heatmap.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/sizes_heatmap.ps b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/sizes_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/sizes_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/sizes_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/sizes_pca_cor.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/sizes_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/sizes_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/sizes_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/sizes_pca_cor.ps b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/sizes_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/sizes_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/sizes_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed.ps b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed.ps
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed.ps
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_features.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_features.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_features.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_features.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_features.ps b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_features.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_features.ps
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_features.ps
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_features_heatmap.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_features_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_features_heatmap.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_features_heatmap.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_features_heatmap.ps b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_features_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_features_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_features_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_features_pca_cor.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_features_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_features_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_features_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_features_pca_cor.ps b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_features_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_features_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_features_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_heatmap.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_heatmap.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_heatmap.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_heatmap.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_heatmap.ps b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_heatmap.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_heatmap.ps
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_heatmap.ps
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_pca_cor.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_pca_cor.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_pca_cor.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_pca_cor.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_pca_cor.ps b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_pca_cor.ps
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_pca_cor.ps
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_Figures/transformed_pca_cor.ps
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_ORA/ORA_barplot_dpi300.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_ORA/ORA_barplot_dpi300.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_ORA/ORA_barplot_dpi300.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_ORA/ORA_barplot_dpi300.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_ORA/ORA_barplot_dpi72.pdf b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_ORA/ORA_barplot_dpi72.pdf
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_ORA/ORA_barplot_dpi72.pdf
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_ORA/ORA_barplot_dpi72.pdf
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_ORA/ORA_dotplot_dpi300.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_ORA/ORA_dotplot_dpi300.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_ORA/ORA_dotplot_dpi300.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_ORA/ORA_dotplot_dpi300.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_ORA/ORA_dotplot_dpi72.pdf b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_ORA/ORA_dotplot_dpi72.pdf
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_ORA/ORA_dotplot_dpi72.pdf
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_ORA/ORA_dotplot_dpi72.pdf
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_ORA/msea_ora_result.csv b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_ORA/msea_ora_result.csv
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_ORA/msea_ora_result.csv
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_ORA/msea_ora_result.csv
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_ORA/name_map.csv b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_ORA/name_map.csv
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_ORA/name_map.csv
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_ORA/name_map.csv
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_B/QEA_barplot_dpi300.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_B/QEA_barplot_dpi300.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_B/QEA_barplot_dpi300.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_B/QEA_barplot_dpi300.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_B/QEA_barplot_dpi72.pdf b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_B/QEA_barplot_dpi72.pdf
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_B/QEA_barplot_dpi72.pdf
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_B/QEA_barplot_dpi72.pdf
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_B/QEA_dotplot_dpi300.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_B/QEA_dotplot_dpi300.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_B/QEA_dotplot_dpi300.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_B/QEA_dotplot_dpi300.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_B/QEA_dotplot_dpi72.pdf b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_B/QEA_dotplot_dpi72.pdf
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_B/QEA_dotplot_dpi72.pdf
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_B/QEA_dotplot_dpi72.pdf
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_B/msea_qea_result.csv b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_B/msea_qea_result.csv
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_B/msea_qea_result.csv
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_B/msea_qea_result.csv
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_B/name_map.csv b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_B/name_map.csv
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_B/name_map.csv
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_B/name_map.csv
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_C/QEA_barplot_dpi300.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_C/QEA_barplot_dpi300.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_C/QEA_barplot_dpi300.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_C/QEA_barplot_dpi300.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_C/QEA_barplot_dpi72.pdf b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_C/QEA_barplot_dpi72.pdf
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_C/QEA_barplot_dpi72.pdf
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_C/QEA_barplot_dpi72.pdf
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_C/QEA_dotplot_dpi300.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_C/QEA_dotplot_dpi300.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_C/QEA_dotplot_dpi300.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_C/QEA_dotplot_dpi300.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_C/QEA_dotplot_dpi72.pdf b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_C/QEA_dotplot_dpi72.pdf
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_C/QEA_dotplot_dpi72.pdf
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_C/QEA_dotplot_dpi72.pdf
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_C/msea_qea_result.csv b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_C/msea_qea_result.csv
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_C/msea_qea_result.csv
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_C/msea_qea_result.csv
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_C/name_map.csv b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_C/name_map.csv
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_C/name_map.csv
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_C/name_map.csv
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_D/QEA_barplot_dpi300.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_D/QEA_barplot_dpi300.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_D/QEA_barplot_dpi300.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_D/QEA_barplot_dpi300.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_D/QEA_barplot_dpi72.pdf b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_D/QEA_barplot_dpi72.pdf
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_D/QEA_barplot_dpi72.pdf
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_D/QEA_barplot_dpi72.pdf
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_D/QEA_dotplot_dpi300.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_D/QEA_dotplot_dpi300.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_D/QEA_dotplot_dpi300.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_D/QEA_dotplot_dpi300.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_D/QEA_dotplot_dpi72.pdf b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_D/QEA_dotplot_dpi72.pdf
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_D/QEA_dotplot_dpi72.pdf
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_D/QEA_dotplot_dpi72.pdf
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_D/msea_qea_result.csv b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_D/msea_qea_result.csv
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_D/msea_qea_result.csv
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_D/msea_qea_result.csv
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_D/name_map.csv b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_D/name_map.csv
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_D/name_map.csv
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/A_vs_D/name_map.csv
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/C_vs_D/QEA_barplot_dpi300.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/C_vs_D/QEA_barplot_dpi300.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/C_vs_D/QEA_barplot_dpi300.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/C_vs_D/QEA_barplot_dpi300.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/C_vs_D/QEA_barplot_dpi72.pdf b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/C_vs_D/QEA_barplot_dpi72.pdf
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/C_vs_D/QEA_barplot_dpi72.pdf
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/C_vs_D/QEA_barplot_dpi72.pdf
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/C_vs_D/QEA_dotplot_dpi300.png b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/C_vs_D/QEA_dotplot_dpi300.png
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/C_vs_D/QEA_dotplot_dpi300.png
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/C_vs_D/QEA_dotplot_dpi300.png
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/C_vs_D/QEA_dotplot_dpi72.pdf b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/C_vs_D/QEA_dotplot_dpi72.pdf
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/C_vs_D/QEA_dotplot_dpi72.pdf
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/C_vs_D/QEA_dotplot_dpi72.pdf
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/C_vs_D/msea_qea_result.csv b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/C_vs_D/msea_qea_result.csv
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/C_vs_D/msea_qea_result.csv
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/C_vs_D/msea_qea_result.csv
diff --git a/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/C_vs_D/name_map.csv b/archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/C_vs_D/name_map.csv
similarity index 100%
rename from V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/C_vs_D/name_map.csv
rename to archived/V2.1/FileExamples/Examples/9_MSEA_Analysis/Result_MSEA/kegg_pathway_QEA/C_vs_D/name_map.csv
diff --git a/V2.1/FileExamples/Reference_Metabolites_for_Enrichment_or_Pathway_Analysis/reference_metabolites_example_HMDB.txt b/archived/V2.1/FileExamples/Reference_Metabolites_for_Enrichment_or_Pathway_Analysis/reference_metabolites_example_HMDB.txt
similarity index 100%
rename from V2.1/FileExamples/Reference_Metabolites_for_Enrichment_or_Pathway_Analysis/reference_metabolites_example_HMDB.txt
rename to archived/V2.1/FileExamples/Reference_Metabolites_for_Enrichment_or_Pathway_Analysis/reference_metabolites_example_HMDB.txt
diff --git a/V2.1/FileExamples/Reference_Metabolites_for_Enrichment_or_Pathway_Analysis/reference_metabolites_example_KEGG.txt b/archived/V2.1/FileExamples/Reference_Metabolites_for_Enrichment_or_Pathway_Analysis/reference_metabolites_example_KEGG.txt
similarity index 100%
rename from V2.1/FileExamples/Reference_Metabolites_for_Enrichment_or_Pathway_Analysis/reference_metabolites_example_KEGG.txt
rename to archived/V2.1/FileExamples/Reference_Metabolites_for_Enrichment_or_Pathway_Analysis/reference_metabolites_example_KEGG.txt
diff --git a/V2.1/FileExamples/Reference_Metabolites_for_Enrichment_or_Pathway_Analysis/reference_metabolites_example_Name.txt b/archived/V2.1/FileExamples/Reference_Metabolites_for_Enrichment_or_Pathway_Analysis/reference_metabolites_example_Name.txt
similarity index 100%
rename from V2.1/FileExamples/Reference_Metabolites_for_Enrichment_or_Pathway_Analysis/reference_metabolites_example_Name.txt
rename to archived/V2.1/FileExamples/Reference_Metabolites_for_Enrichment_or_Pathway_Analysis/reference_metabolites_example_Name.txt
diff --git a/V2.1/FileExamples/test_data.xlsx b/archived/V2.1/FileExamples/test_data.xlsx
similarity index 100%
rename from V2.1/FileExamples/test_data.xlsx
rename to archived/V2.1/FileExamples/test_data.xlsx
diff --git a/V2.1/ODA/MetaboAnalyst.R b/archived/V2.1/ODA/MetaboAnalyst.R
similarity index 100%
rename from V2.1/ODA/MetaboAnalyst.R
rename to archived/V2.1/ODA/MetaboAnalyst.R
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/All_generic_utils.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/All_generic_utils.R
new file mode 100755
index 0000000000000000000000000000000000000000..e9ca2a4f5385a84b5e71620234ca89370d9943b7
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/All_generic_utils.R
@@ -0,0 +1,112 @@
+# .onAttatch
+#
+.onAttach <- function (libname, pkgname){
+ k1 <- paste("MetaboAnalystR",utils::packageVersion( "MetaboAnalystR"),"initialized Successfully !")
+ k0 <- "\n"
+ k2 <- paste("https://github.com/xia-lab/MetaboAnalystR")
+
+ packageStartupMessage(c(k1,k0,k2))
+
+}
+
+
+
+### Generic DataClass Defination----------
+# 1. This xcmsSet is defined as refereced to XCMS for CAMERA annotation but not completely same
+##' @references Smith, C.A., Want, E.J., O'Maille, G., Abagyan,R., Siuzdak, G. (2006).
+##' "XCMS: Processing mass spectrometry data for metabolite profiling using nonlinear peak alignment,
+##' matching and identification." Analytical Chemistry, 78, 779-787.
+setClass("xcmsSet",
+ representation = representation(peaks = "matrix",
+ groups = "matrix",
+ groupidx = "list",
+ filled="numeric",
+ phenoData = "data.frame",
+ rt = "list",
+ filepaths = "character",
+ profinfo = "list",
+ dataCorrection="numeric",
+ polarity = "character",
+ progressInfo = "list",
+ progressCallback="function",
+ mslevel = "numeric",
+ scanrange = "numeric"),
+ prototype = prototype(peaks = matrix(nrow = 0, ncol = 0),
+ groups = matrix(nrow = 0, ncol = 0),
+ groupidx = list(),
+ filled = integer(0),
+ phenoData = data.frame(),
+ rt = list(),
+ filepaths = character(0),
+ profinfo = vector("list"),
+ dataCorrection=integer(0),
+ polarity = character(0),
+ progressInfo = list(),
+ mslevel = numeric(0),
+ scanrange= numeric(0),
+ progressCallback = function(progress) NULL),
+ validity = function(object) {
+ msg <- character()
+ ## Check if all slots are present.
+ slNames <- slotNames(object)
+ missingSlots <- character()
+ for (i in 1:length(slNames)) {
+ if (!.hasSlot(object, slNames[i]))
+ missingSlots <- c(missingSlots, slNames[i])
+ }
+ if (length(missingSlots) > 0)
+ msg <- c(msg, paste0("This xcmsSet lacks slot(s): ",
+ paste(missingSlots, collapse = ","),
+ ". Please update the object using",
+ " the 'updateObject' method."))
+ ## Check the .processHistory slot.
+
+ if (length(msg))
+ return(msg)
+ return(TRUE)
+ })
+
+# 2. ruleSet were set for CAMERA processing.
+##' @references Kuhl C, Tautenhahn R, Boettcher C, Larson TR, Neumann S (2012).
+##' "CAMERA: an integrated strategy for compound spectra extraction and annotation of
+##' liquid chromatography/mass spectrometry data sets." Analytical Chemistry, 84, 283-289.
+##' http://pubs.acs.org/doi/abs/10.1021/ac202450g.
+
+setClass("ruleSet",
+ representation(ionlistfile="character",
+ ionlist="data.frame",
+ neutrallossfile="character",
+ neutralloss="data.frame",
+ neutraladditionfile="character",
+ neutraladdition="data.frame",
+ maxcharge="numeric",
+ mol="numeric",
+ nion="numeric",
+ nnloss="numeric",
+ nnadd="numeric",
+ nh="numeric",
+ polarity="character",
+ rules="data.frame",
+ lib.loc="character"),
+ contains=c("Versioned"),
+ prototype=prototype(
+ ionlistfile="",
+ ionlist=data.frame(),
+ neutrallossfile="",
+ neutralloss=data.frame(),
+ neutraladditionfile="",
+ neutraladdition=data.frame(),
+ maxcharge=numeric(),
+ mol=numeric(),
+ nion=numeric(),
+ nnloss=numeric(),
+ nnadd=numeric(),
+ nh=numeric(),
+ polarity=NULL,
+ rules=data.frame(),
+ lib.loc=NULL,
+ new("Versioned", versions=c(ruleSet="0.1.1"))),
+ validity=function(object) {
+ TRUE
+ })
+
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/batch_effect_utils.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/batch_effect_utils.R
new file mode 100755
index 0000000000000000000000000000000000000000..d273cf24b30352ac205ca0cb46250fa71d70d7ba
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/batch_effect_utils.R
@@ -0,0 +1,4772 @@
+#'Data I/O for batch effect checking
+#'@description Read multiple user uploaded CSV data one by one
+#'format: row, col
+#'@param mSetObj Input name of the created mSet Object
+#'@param filePath Input the path to the batch files
+#'@param format Input the format of the batch files
+#'@param label Input the label-type of the files
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+Read.BatchDataBC<-function(mSetObj=NA, filePath, format, label){
+
+ err.vec <<- "";
+
+ dat <- .readDataTable(filePath);
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if (any(class(mSetObj[["dataSet"]][["batch.cls"]]) == "factor")){
+
+ mSetObj[["dataSet"]][["table"]] <-
+ mSetObj[["dataSet"]][["class.cls"]] <-
+ mSetObj[["dataSet"]][["batch.cls"]] <-
+ mSetObj[["dataSet"]][["order.cls"]] <-
+ mSetObj[["dataSet"]][["batch"]] <- NULL;
+
+ if (any(grepl("_edata",names(mSetObj[["dataSet"]])))){
+ mSetObj[["dataSet"]][which(grepl("_edata",names(mSetObj[["dataSet"]])))]<-NULL;
+ }
+ }
+
+ if(class(dat) == "try-error") {
+ AddErrMsg("Data format error. Failed to read in the data!");
+ AddErrMsg("Please check the followings: ");
+ AddErrMsg("Either sample or feature names must in UTF-8 encoding; Latin, Greek letters are not allowed.");
+ AddErrMsg("We recommend to use a combination of English letters, underscore, and numbers for naming purpose");
+ AddErrMsg("Make sure sample names and feature (peak, compound) names are unique;");
+ AddErrMsg("Missing values should be blank or NA without quote.");
+ return("F");
+ }
+
+ if(ncol(dat) == 1){
+ AddErrMsg("Error: Make sure the data table is saved as comma separated values (.csv) format!");
+ AddErrMsg("Please also check the followings: ");
+ AddErrMsg("Either sample or feature names must in UTF-8 encoding; Latin, Greek letters are not allowed.");
+ AddErrMsg("We recommend to use a combination of English letters, underscore, and numbers for naming purpose.");
+ AddErrMsg("Make sure sample names and feature (peak, compound) names are unique.");
+ AddErrMsg("Missing values should be blank or NA without quote.");
+ return("F");
+ }
+
+ if(format=="row"){ # sample in row
+ smpl.nms <-dat[,1];
+ cls.nms <- factor(dat[,2]);
+ conc <- dat[,-c(1,2)];
+ var.nms <- colnames(conc);
+ }else{ # sample in col
+ var.nms <- as.character(dat[-1,1]);
+ cls.nms <- factor(as.character(dat[1,-1]));
+ dat <- dat[-1,-1];
+ smpl.nms <- colnames(dat);
+ conc<-t(dat);
+ }
+
+ #checking and make sure QC labels are unique
+ qc.inx <- toupper(substr(smpl.nms, 0, 2)) == "QC";
+
+ qc.nms <- smpl.nms[qc.inx];
+ qc.len <- sum(qc.inx);
+ if(length(unique(qc.nms))!=length(qc.nms)){
+ smpl.nms[qc.inx] <- paste("QC", length(mSetObj$dataSet$batch) + 1, 1:qc.len, sep="");
+ }
+
+ # check the class labels
+ if(!is.null(mSetObj$dataSet$batch.cls)){
+ if(!setequal(levels(cls.nms), levels(mSetObj$dataSet$batch.cls[[1]])) & !setequal(levels(cls.nms), levels(mSet[["dataSet"]][["class.cls"]]))){
+ AddErrMsg("The class labels in current data is different from the previous!");
+ return("F");
+ }
+ }
+
+ if(length(unique(smpl.nms))!=length(smpl.nms)){
+ dup.nm <- paste(smpl.nms[duplicated(smpl.nms)], collapse=" ");
+ AddErrMsg("Duplicate sample names (except QC) are not allowed!");
+ AddErrMsg(dup.nm);
+ return("F");
+ }
+
+ if(length(unique(var.nms))!=length(var.nms)){
+ dup.nm <- paste(var.nms[duplicated(var.nms)], collapse=" ");
+ AddErrMsg("Duplicate feature names are not allowed!");
+ AddErrMsg(dup.nm);
+ return("F");
+ }
+ # now check for special characters in the data labels
+ if(sum(is.na(iconv(smpl.nms)))>0){
+ AddErrMsg("No special letters (i.e. Latin, Greek) are allowed in sample names!");
+ return("F");
+ }
+
+ if(sum(is.na(iconv(var.nms)))>0){
+ AddErrMsg("No special letters (i.e. Latin, Greek) are allowed in feature names!");
+ return("F");
+ }
+
+ # now assgin the dimension names
+ rownames(conc) <- smpl.nms;
+ colnames(conc) <- var.nms;
+
+ label <- gsub("[/-]", "_", label);
+
+ if(nchar(label) > 10){
+ label <- toupper(paste(substr(label, 0, 5), substr(label, nchar(label)-5, nchar(label)), sep=""));
+ }
+
+ # store the data into list of list with the name order index
+ # first clean the label to get rid of unusually chars
+ if(label %in% names(mSetObj$dataSet$batch) || label=="F"){
+ label <- paste("Dataset", length(mSetObj$dataSet$batch) + 1, sep="");
+ }
+
+ # check numerical matrix
+ int.mat <- conc;
+ rowNms <- rownames(int.mat);
+ colNms <- colnames(int.mat);
+ naNms <- sum(is.na(int.mat));
+ num.mat<-apply(int.mat, 2, as.numeric)
+
+ msg<-NULL;
+ if(sum(is.na(num.mat)) > naNms){
+ # try to remove "," in thousand seperator if it is the cause
+ num.mat <- apply(int.mat,2,function(x) as.numeric(gsub(",", "", x)));
+ if(sum(is.na(num.mat)) > naNms){
+ msg<-c(msg,"<font color=\"red\">Non-numeric values were found and replaced by NA.</font>");
+ }else{
+ msg<-c(msg,"All data values are numeric.");
+ }
+ }else{
+ msg<-c(msg,"All data values are numeric.");
+ }
+
+ int.mat <- num.mat;
+
+ rownames(int.mat)<-rowNms;
+ colnames(int.mat)<-colNms;
+
+ # replace NA by LoD
+ int.mat <- ReplaceMissingByLoD(int.mat);
+
+ mSetObj$dataSet$batch[[label]] <- int.mat;
+ mSetObj$dataSet$batch.cls[[label]] <- cls.nms;
+
+ # free memory
+ gc();
+ if(.on.public.web){
+ .set.mSet(mSetObj);
+ return(label);
+ }else{
+ print(label);
+ return(.set.mSet(mSetObj));
+ }
+}
+
+#'Data I/O for batch effect checking
+#'
+#'@description Read peak data tale.
+#'format: row, col
+#'@param mSetObj Input name of the created mSet Object
+#'@param filePath Input the path to the batch files
+#'@param format Input the format of the batch files
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+Read.BatchDataTB<-function(mSetObj=NA, filePath, format){
+
+ err.vec <<- "";
+
+ dat <- .readDataTable(filePath);
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ mSetObj[["dataSet"]][["table"]]<-
+ mSetObj[["dataSet"]][["class.cls"]]<-
+ mSetObj[["dataSet"]][["batch.cls"]]<-
+ mSetObj[["dataSet"]][["order.cls"]] <- NULL;
+
+ if (any(grepl("_edata",names(mSetObj[["dataSet"]])))){
+
+ mSetObj[["dataSet"]][which(grepl("_edata",names(mSetObj[["dataSet"]])))]<-NULL;
+
+ }
+
+
+ if(class(dat) == "try-error") {
+ AddErrMsg("Data format error. Failed to read in the data!");
+ AddErrMsg("Please check the followings: ");
+ AddErrMsg("Either sample or feature names must in UTF-8 encoding; Latin, Greek letters are not allowed.");
+ AddErrMsg("We recommend to use a combination of English letters, underscore, and numbers for naming purpose");
+ AddErrMsg("Make sure sample names and feature (peak, compound) names are unique;");
+ AddErrMsg("Missing values should be blank or NA without quote.");
+ return("F");
+ }
+
+ if(ncol(dat) == 1){
+ AddErrMsg("Error: Make sure the data table is saved as comma separated values (.csv) format!");
+ AddErrMsg("Please also check the followings: ");
+ AddErrMsg("Either sample or feature names must in UTF-8 encoding; Latin, Greek letters are not allowed.");
+ AddErrMsg("We recommend to use a combination of English letters, underscore, and numbers for naming purpose.");
+ AddErrMsg("Make sure sample names and feature (peak, compound) names are unique.");
+ AddErrMsg("Missing values should be blank or NA without quote.");
+ return("F");
+ }
+
+ if(format=="row"){ # sample in row
+ smpl.nms <-dat[,1];
+ cls.nms <- factor(dat[,2]);
+ order.nms <- factor(dat[,4]);
+ batch.nms <- factor(dat[,3]);
+ conc <- dat[,-c(1:4)];
+ var.nms <- colnames(conc);
+ }else{ # sample in col
+ smpl.nms <-colnames(dat[1,])[-1];
+ cls.nms <- factor(dat[1,][-1]);
+ order.nms <- factor(unname(dat[3,])[-1]);
+ batch.nms <- factor(unname(dat[2,])[-1]);
+ conc <- t(dat[-c(1:3),]);
+ var.nms <- unname(conc[1,]);
+ conc <- conc[-1,]
+ }
+
+ #checking and make sure QC labels are unique
+ # qc.inx <- toupper(substr(smpl.nms, 0, 2)) == "QC"; # Old code, delete !
+ qc.inx <- grepl("QC",smpl.nms)
+
+ qc.nms <- smpl.nms[qc.inx];
+ qc.len <- sum(qc.inx);
+ if(length(unique(qc.nms))!=length(qc.nms)){
+ smpl.nms[qc.inx] <- paste(qc.nms,as.character(batch.nms),as.character(order.nms),sep = "_");
+ }
+
+ # check the class labels
+
+ if(length(unique(smpl.nms))!=length(smpl.nms)){
+ dup.nm <- paste(smpl.nms[duplicated(smpl.nms)], collapse=" ");
+ AddErrMsg("Duplicate sample names (except QC) are not allowed!");
+ AddErrMsg(dup.nm);
+ return("F");
+ }
+
+ if(length(unique(var.nms))!=length(var.nms)){
+ dup.nm <- paste(var.nms[duplicated(var.nms)], collapse=" ");
+ AddErrMsg("Duplicate feature names are not allowed!");
+ AddErrMsg(dup.nm);
+ return("F");
+ }
+ # now check for special characters in the data labels
+ if(sum(is.na(iconv(smpl.nms)))>0){
+ AddErrMsg("No special letters (i.e. Latin, Greek) are allowed in sample names!");
+ return("F");
+ }
+
+ if(sum(is.na(iconv(var.nms)))>0){
+ AddErrMsg("No special letters (i.e. Latin, Greek) are allowed in feature names!");
+ return("F");
+ }
+
+ # now assgin the dimension names
+ rownames(conc) <- smpl.nms;
+ colnames(conc) <- var.nms;
+
+ #label <- gsub("[/-]", "_", label);
+
+ #if(nchar(label) > 10){
+ # label <- toupper(paste(substr(label, 0, 5), substr(label, nchar(label)-5, nchar(label)), sep=""));
+ #}
+
+ # store the data into list of list with the name order index
+ # first clean the label to get rid of unusually chars
+
+ #if(label %in% names(mSetObj$dataSet$batch) || label=="F"){
+ # label <- paste("Dataset", length(mSetObj$dataSet$batch) + 1, sep="");
+ #}
+
+ # check numerical matrix
+ int.mat <- conc;
+ rowNms <- rownames(int.mat);
+ colNms <- colnames(int.mat);
+ naNms <- sum(is.na(int.mat));
+ num.mat<-apply(int.mat, 2, as.numeric)
+
+ msg<-NULL;
+ if(sum(is.na(num.mat)) > naNms){
+ # try to remove "," in thousand seperator if it is the cause
+ num.mat <- apply(int.mat,2,function(x) as.numeric(gsub(",", "", x)));
+ if(sum(is.na(num.mat)) > naNms){
+ msg<-c(msg,"<font color=\"red\">Non-numeric values were found and replaced by NA.</font>");
+ }else{
+ msg<-c(msg,"All data values are numeric.");
+ }
+ }else{
+ msg<-c(msg,"All data values are numeric.");
+ }
+
+ int.mat <- num.mat;
+
+ rownames(int.mat)<-rowNms;
+ colnames(int.mat)<-colNms;
+
+ # replace NA
+ int.mat <- ReplaceMissingByLoD(int.mat);
+
+ mSetObj$dataSet$table <- int.mat;
+ mSetObj$dataSet$class.cls <- cls.nms;
+ mSetObj$dataSet$batch.cls <- batch.nms;
+ mSetObj$dataSet$order.cls <- order.nms;
+
+ # free memory
+ gc();
+ if(.on.public.web){
+ .set.mSet(mSetObj);
+ # return(label);
+ }else{
+ return(.set.mSet(mSetObj));
+ }
+}
+
+#'Data I/O for signal drift checking
+#'
+#'@description Read peak data tale.
+#'format: row, col
+#'@param mSetObj Input name of the created mSet Object
+#'@param filePath Input the path to the batch files
+#'@param format Input the format of the batch files
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+Read.SignalDriftData<-function(mSetObj=NA, filePath, format){
+
+ #dat <- .readDataTable(filePath);
+ dat <- .readDataTable2(filePath);
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(class(dat) == "try-error") {
+ AddErrMsg("Data format error. Failed to read in the data!");
+ AddErrMsg("Please check the followings: ");
+ AddErrMsg("Either sample or feature names must in UTF-8 encoding; Latin, Greek letters are not allowed.");
+ AddErrMsg("We recommend to use a combination of English letters, underscore, and numbers for naming purpose");
+ AddErrMsg("Make sure sample names and feature (peak, compound) names are unique;");
+ AddErrMsg("Missing values should be blank or NA without quote.");
+ return("F");
+ }
+
+ if(ncol(dat) == 1){
+ AddErrMsg("Error: Make sure the data table is saved as comma separated values (.csv) format!");
+ AddErrMsg("Please also check the followings: ");
+ AddErrMsg("Either sample or feature names must in UTF-8 encoding; Latin, Greek letters are not allowed.");
+ AddErrMsg("We recommend to use a combination of English letters, underscore, and numbers for naming purpose.");
+ AddErrMsg("Make sure sample names and feature (peak, compound) names are unique.");
+ AddErrMsg("Missing values should be blank or NA without quote.");
+ return("F");
+ }
+
+ if(format=="row"){ # sample in row
+ smpl.nms <-dat[,1];
+ cls.nms <- factor(dat[,2]);
+ order.nms <- factor(dat[,4]);
+ batch.nms <- factor(dat[,3]);
+ conc <- dat[,-c(1:4)];
+ var.nms <- colnames(conc);
+ }else{ # sample in col
+ smpl.nms <-dat[1,];
+ cls.nms <- factor(dat[2,]);
+ order.nms <- factor(dat[4,]);
+ batch.nms <- factor(dat[3,]);
+ conc <- t(dat[-c(1:4),]);
+ var.nms <- colnames(conc);
+ }
+
+ #checking and make sure QC labels are unique
+ # qc.inx <- toupper(substr(smpl.nms, 0, 2)) == "QC"; # Old code, delete !
+ qc.inx <- grepl("QC",smpl.nms)
+
+ qc.nms <- smpl.nms[qc.inx];
+ qc.len <- sum(qc.inx);
+ if(length(unique(qc.nms))!=length(qc.nms)){
+ smpl.nms[qc.inx] <- paste(qc.nms,as.character(batch.nms),as.character(order.nms),sep = "_");
+ }
+
+ # check the class labels
+ if(!is.null(mSetObj$dataSet$batch.cls)){
+ if(!setequal(levels(cls.nms), levels(mSetObj$dataSet$batch.cls[[1]]))){
+ AddErrMsg("The class labels in current data is different from the previous!");
+ return("F");
+ }
+ }
+
+ if(length(unique(smpl.nms))!=length(smpl.nms)){
+ dup.nm <- paste(smpl.nms[duplicated(smpl.nms)], collapse=" ");
+ AddErrMsg("Duplicate sample names (except QC) are not allowed!");
+ AddErrMsg(dup.nm);
+ return("F");
+ }
+
+ if(length(unique(var.nms))!=length(var.nms)){
+ dup.nm <- paste(var.nms[duplicated(var.nms)], collapse=" ");
+ AddErrMsg("Duplicate feature names are not allowed!");
+ AddErrMsg(dup.nm);
+ return("F");
+ }
+ # now check for special characters in the data labels
+ if(sum(is.na(iconv(smpl.nms)))>0){
+ AddErrMsg("No special letters (i.e. Latin, Greek) are allowed in sample names!");
+ return("F");
+ }
+
+ if(sum(is.na(iconv(var.nms)))>0){
+ AddErrMsg("No special letters (i.e. Latin, Greek) are allowed in feature names!");
+ return("F");
+ }
+
+ # now assgin the dimension names
+ rownames(conc) <- smpl.nms;
+ colnames(conc) <- var.nms;
+
+ #label <- gsub("[/-]", "_", label);
+
+ #if(nchar(label) > 10){
+ # label <- toupper(paste(substr(label, 0, 5), substr(label, nchar(label)-5, nchar(label)), sep=""));
+ #}
+
+ # store the data into list of list with the name order index
+ # first clean the label to get rid of unusually chars
+
+ #if(label %in% names(mSetObj$dataSet$batch) || label=="F"){
+ # label <- paste("Dataset", length(mSetObj$dataSet$batch) + 1, sep="");
+ #}
+
+ # check numerical matrix
+ int.mat <- conc;
+ rowNms <- rownames(int.mat);
+ colNms <- colnames(int.mat);
+ naNms <- sum(is.na(int.mat));
+ num.mat<-apply(int.mat, 2, as.numeric)
+
+ msg<-NULL;
+ if(sum(is.na(num.mat)) > naNms){
+ # try to remove "," in thousand seperator if it is the cause
+ num.mat <- apply(int.mat,2,function(x) as.numeric(gsub(",", "", x)));
+ if(sum(is.na(num.mat)) > naNms){
+ msg<-c(msg,"<font color=\"red\">Non-numeric values were found and replaced by NA.</font>");
+ }else{
+ msg<-c(msg,"All data values are numeric.");
+ }
+ }else{
+ msg<-c(msg,"All data values are numeric.");
+ }
+
+ int.mat <- num.mat;
+
+ rownames(int.mat)<-rowNms;
+ colnames(int.mat)<-colNms;
+
+ # replace NA
+ minConc<-min(int.mat[int.mat>0], na.rm=T)/5;
+ int.mat[is.na(int.mat)] <- minConc;
+
+ mSetObj$dataSet$table <- int.mat;
+ mSetObj$dataSet$class.cls <- cls.nms;
+ mSetObj$dataSet$batch.cls <- batch.nms;
+ mSetObj$dataSet$order.cls <- order.nms;
+
+ # free memory
+ gc();
+ if(.on.public.web){
+ .set.mSet(mSetObj);
+ # return(label);
+ }else{
+ # print(label);
+ return(.set.mSet(mSetObj));
+ }
+}
+
+#'Batch Effect Correction
+#'@description This function is designed to perform the batch effect correction
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input the name of the plot to create
+#'@param Method Batch effect correction method, default is "auto". Specific method, including "Combat",
+#'"WaveICA","EigenMS","QC_RLSC","ANCOVA","RUV_random","RUV_2","RUV_s","RUV_r","RUV_g","NOMIS" and "CCMN".
+#'@param center The center point of the batch effect correction, based on "QC" or "", which means correct
+#'to minimize the distance between batches.
+#'@import data.table
+#'@importFrom plyr join ddply . summarise id
+#'@importFrom dplyr rename mutate select enquo tbl_vars group_vars grouped_df group_vars groups
+#'@import edgeR
+#'@importFrom pcaMethods pca
+#'@importFrom crmn standardsFit
+#'@import impute
+#'@import BiocParallel
+#'@author Zhiqiang Pang, Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PerformBatchCorrection <- function(mSetObj=NA, imgName=NULL, Method=NULL, center=NULL){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ start.time <- Sys.time()
+
+ if(class(mSetObj[["dataSet"]][["batch.cls"]])=="list"){
+
+ nms <- names(mSetObj$dataSet$batch);
+ nm.list <- vector(length=length(mSetObj$dataSet$batch), mode="list");
+ cls.lbls <- batch.lbls <- NULL; # record all batch labels
+
+ for (i in 1:length(mSetObj$dataSet$batch)){
+ batch <- mSetObj$dataSet$batch[[i]];
+ cls <- as.character(mSetObj$dataSet$batch.cls[[i]]);
+ nm.list[[i]] <- colnames(batch);
+ cls.lbls <- c(cls.lbls,cls);
+ batch.lbls <- c(batch.lbls, rep(nms[i], length=nrow(batch)));
+ }
+
+ cm.nms <- Reduce(intersect, nm.list); # get common names
+
+ # now align all the batches
+ mSetObj$dataSet$batch <- lapply(mSetObj$dataSet$batch, function(x){x[,cm.nms]});
+ mSetObj[["dataSet"]][["table"]] <- commonMat2 <- do.call(rbind, mSetObj$dataSet$batch);
+ mSetObj[["dataSet"]][["batch.cls"]] <- batch.lbl2 <- factor(batch.lbls,levels=names(mSetObj$dataSet$batch), ordered=T);
+ mSetObj[["dataSet"]][["class.cls"]] <- class.lbl2 <- factor(cls.lbls);
+
+ working_mode <- "file";
+
+ } else if (class(mSetObj[["dataSet"]][["batch.cls"]])=="factor") {
+
+ commonMat2 <- mSetObj[["dataSet"]][["table"]];
+ batch.lbl2 <- mSetObj[["dataSet"]][["batch.cls"]];
+ class.lbl2 <- mSetObj[["dataSet"]][["class.cls"]];
+ order.lbl2 <- mSetObj[["dataSet"]][["order.cls"]];
+
+ working_mode <- "table";
+
+ } else {
+ AddErrMsg("There is something wrong with your data !")
+ AddErrMsg("Most possible cause: absence of batch infromation !")
+ return(F)
+ }
+
+
+ if (is.null(Method)){
+ Method<-"auto"
+ }
+
+ if (is.null(center)){
+ center<-""
+ }
+
+ if (is.null(imgName)){
+ imgName<-"image_BC"
+ }
+
+ ## Extract the information from the mSetObj Object
+
+ #order.lbl2 <- mSetObj[["dataSet"]][["order.cls"]];
+ QCs<-grep("QC",as.character(class.lbl2));
+
+ pheno2 <- data.frame(cbind(class.lbl2, batch.lbl2));
+ print(paste("Correcting using the", Method, "method !"))
+ modcombat2 <- model.matrix(~1, data=pheno2);
+
+ if (all(is.na(commonMat2)) | all(is.null(commonMat2))){
+ AddErrMsg(paste0("Your data seems like empty !"))
+ return(F)
+ }
+
+
+ try(
+ if (Method=="auto"){
+ #### QCs Independent------------
+ # Correction Method 1 - Combat
+
+ if (all(!is.na(as.character(unique(batch.lbl2)))) & !is.null(batch.lbl2)){
+ print("Correcting with Combat...");
+ Combat_edata<-combat(commonMat2,batch.lbl2,modcombat2);
+ mSetObj$dataSet$Combat_edata<-Combat_edata;
+ }
+
+ # Correction Method 2 - WaveICA
+ if(!.on.public.web){
+ if (all(!is.na(as.character(unique(batch.lbl2)))) & !is.null(batch.lbl2) &
+ all(!is.na(as.character(unique(class.lbl2)))) & !is.null(class.lbl2)){
+ print("Correcting with WaveICA...");#require(WaveICA)
+ WaveICA_edata<-WaveICA(commonMat2,batch.lbl2,class.lbl2);
+ mSetObj$dataSet$WaveICA_edata<-WaveICA_edata;
+ }
+ }
+ # Correction Method 3 - Eigens MS
+ if (all(!is.na(as.character(unique(class.lbl2)))) & !is.null(class.lbl2)){
+ print("Correcting with EigenMS...");
+
+ EigenMS_edata<-suppressWarnings(suppressMessages(EigenMS(commonMat2,class.lbl2)));
+ mSetObj$dataSet$EigenMS_edata<-EigenMS_edata;
+ if (all(is.na(as.character(unique(batch.lbl2)))) | is.null(batch.lbl2)){
+ mSetObj$dataSet$batch.cls <- factor(rep(1,length(mSetObj$dataSet$batch.cls)));
+ }
+ }
+ #### QCs (Quality Control Sample) Dependent---------
+ ## Run QCs dependent methods
+ if (!identical(QCs,integer(0))){
+ #Correction Method 1 - QC-RLSC # Ref:doi: 10.1093/bioinformatics/btp426
+
+ if (working_mode == "table" & (.on.public.web == F | as.numeric(object.size(mSetObj[["dataSet"]][["table"]])/1024/1024) < 0.82)){
+
+ if (all(!is.na(as.character(unique(batch.lbl2)))) & !is.null(batch.lbl2) &
+ all(!is.na(as.character(unique(class.lbl2)))) & !is.null(class.lbl2) &
+ !(is.null(order.lbl2) | all(is.na(as.character(unique(order.lbl2)))) | any(is.na(order.lbl2)))){
+ print("Correcting with QC-RLSC...");
+
+ QC_RLSC_edata<-QC_RLSC(commonMat2,batch.lbl2,class.lbl2,order.lbl2,QCs);
+
+ mSetObj$dataSet$QC_RLSC_edata <- QC_RLSC_edata;
+ }
+ }
+ # Correction Method 2 - QC-SVRC or QC-RFSC # Ref:https://doi.org/10.1016/j.aca.2018.08.002
+ # Future Options to make this script more powerful
+
+ # Correction Method 4 - ANCOVA # Ref:doi: 10.1007/s11306-016-1015-8
+ if (all(!is.na(as.character(unique(batch.lbl2)))) & !is.null(batch.lbl2)){
+ print("Correcting with ANCOVA...");
+ ANCOVA_edata<-ANCOVA(commonMat2,batch.lbl2,QCs);
+ mSetObj$dataSet$ANCOVA_edata <- ANCOVA_edata;
+ }
+ }
+
+ #### QCm (Quality Control Metabolites) Dependent---------
+ QCms<-grep("IS",colnames(commonMat2));
+ if (!identical(QCms,integer(0))){
+ # Correction Method 1 - RUV_random # Ref:doi/10.1021/ac502439y
+ print("Correcting with RUV-random...");
+ RUV_random_edata<-RUV_random(commonMat2);
+ mSetObj$dataSet$RUV_random_edata <- RUV_random_edata;
+
+ # Correction Method 2 - RUV2 # Ref:De Livera, A. M.; Bowne, J. Package metabolomics for R, 2012.
+ if (all(!is.na(as.character(unique(class.lbl2)))) & !is.null(class.lbl2)){
+ print("Correcting with RUV-2...");
+ RUV_2_edata<-RUV_2(commonMat2,class.lbl2);
+ mSetObj$dataSet$RUV_2_edata <- RUV_2_edata;
+ }
+ # Correction Method 3.1 - RUV_sample # Ref:https://www.nature.com/articles/nbt.2931
+ if (all(!is.na(as.character(unique(class.lbl2)))) & !is.null(class.lbl2)){
+ print("Correcting with RUVs...");
+ RUV_s_edata<-RUVs_cor(commonMat2,class.lbl2);
+ mSetObj$dataSet$RUV_s_edata <- RUV_s_edata;
+ }
+ # Correction Method 3.2 - RUVSeq_residual # Ref:https://www.nature.com/articles/nbt.2931
+ if (all(!is.na(as.character(unique(class.lbl2)))) & !is.null(class.lbl2)){
+ print("Correcting with RUVr...");require(edgeR)
+ RUV_r_edata<-suppressPackageStartupMessages(RUVr_cor(commonMat2,class.lbl2));
+ mSetObj$dataSet$RUV_r_edata <- RUV_r_edata;
+ }
+ # Correction Method 3.3 - RUV_g # Ref:https://www.nature.com/articles/nbt.2931
+ print("Correcting with RUVg...");
+ RUV_g_edata<-RUVg_cor(commonMat2);
+ mSetObj$dataSet$RUV_g_edata <- RUV_g_edata;
+ }
+
+ #### Internal standards based dependent methods--------
+ ISs <- grep("IS",colnames(commonMat2));
+ if (!identical(ISs,integer(0))){
+
+ # Correction Method 1 - NOMIS
+ print("Correcting with NOMIS...")
+ NOMIS_edata <- NOMIS(commonMat2)
+ mSetObj$dataSet$NOMIS_edata <- NOMIS_edata;
+
+ # Correction Method 2 - CCMN
+ if (all(!is.na(as.character(unique(class.lbl2)))) & !is.null(class.lbl2)){
+ print("Correcting with CCMN...")
+ CCMN_edata <- CCMN2(commonMat2,class.lbl2)
+ mSetObj$dataSet$CCMN_edata <- CCMN_edata;
+ }
+ }
+
+ ###################
+
+ nms<-names(mSetObj$dataSet)
+ nms<-nms[grepl("*edata",nms)]
+ nms<- c("table",nms)
+
+ interbatch_dis<-sapply(nms,FUN=.evaluate.dis,mSetObj=mSetObj,center=center)
+ mSetObj$dataSet$interbatch_dis <- interbatch_dis
+
+ best.choice<-names(which(min(interbatch_dis)==interbatch_dis))
+
+ best.table <- mSetObj$dataSet[[best.choice]];
+ mSetObj$dataSet$adjusted.mat <- best.table;
+
+ Method <- sub(pattern = "_edata",x = best.choice, replacement = "")
+
+ print(paste("Best results generated by ", Method, " !"))
+ #=======================================================================/
+ } else if (Method=="Combat"){
+
+ if(any(is.na(batch.lbl2)) | is.null(batch.lbl2)){
+ AddErrMsg(paste0("batch inforamtion is required for ",Method," !"))
+ return(F)
+ }
+
+ Combat_edata<-combat(commonMat2,batch.lbl2,modcombat2);
+ mSetObj$dataSet$adjusted.mat<-mSetObj$dataSet$Combat_edata <- Combat_edata;
+
+ } else if (Method=="WaveICA"){
+
+ if(any(is.na(batch.lbl2)) | is.null(batch.lbl2)){
+ AddErrMsg(paste0("batch inforamtion is required for ",Method," !"))
+ return(F)
+ }
+ if(any(is.na(class.lbl2)) | is.null(class.lbl2)){
+ AddErrMsg(paste0("class inforamtion is required for ",Method," !"))
+ return(F)
+ }
+ WaveICA_edata<-WaveICA(commonMat2,batch.lbl2,class.lbl2);
+ mSetObj$dataSet$adjusted.mat<-mSetObj$dataSet$WaveICA_edata <- WaveICA_edata;
+
+ } else if (Method=="EigenMS"){
+ if(any(is.na(class.lbl2)) | is.null(class.lbl2)){
+ AddErrMsg(paste0("class inforamtion is required for ",Method," !"))
+ return(F)
+ }
+ EigenMS_edata<-EigenMS(commonMat2,class.lbl2);
+ mSetObj$dataSet$adjusted.mat<-mSetObj$dataSet$EigenMS_edata <- EigenMS_edata;
+
+ } else if (Method=="QC_RLSC"){
+
+ if(any(is.na(batch.lbl2)) | is.null(batch.lbl2)){
+ AddErrMsg(paste0("batch inforamtion is required for ",Method," !"))
+ return(F)
+ }
+
+ if(any(is.na(class.lbl2)) | is.null(class.lbl2)){
+ AddErrMsg(paste0("class inforamtion is required for ",Method," !"))
+ return(F)
+ }
+
+ if(any(is.na(order.lbl2)) | is.null(order.lbl2)){
+ AddErrMsg(paste0("order inforamtion is required for ",Method," !"))
+ return(F)
+ }
+
+ if(any(is.na(QCs)) | is.null(QCs) | identical(QCs, integer(0))){
+ AddErrMsg(paste0("QC inforamtion is required for ",Method," !"))
+
+ return(F)
+ }
+
+ QC_RLSC_edata<-suppressWarnings(suppressMessages(QC_RLSC(commonMat2,batch.lbl2,class.lbl2,order.lbl2,QCs)));
+ mSetObj$dataSet$adjusted.mat <- mSetObj$dataSet$QC_RLSC_edata <- QC_RLSC_edata;
+
+ } else if (Method=="ANCOVA"){
+
+ if(any(is.na(batch.lbl2)) | is.null(batch.lbl2)){
+ AddErrMsg(paste0("batch inforamtion is required for ",Method," !"))
+ return(F)
+ }
+
+ if(any(is.na(QCs)) | is.null(QCs) | identical(QCs, integer(0))){
+ AddErrMsg(paste0("QC inforamtion is required for ",Method," !"))
+ return(F)
+ }
+
+ ANCOVA_edata<-ANCOVA(commonMat2,batch.lbl2,QCs);
+ mSetObj$dataSet$adjusted.mat <- mSetObj$dataSet$ANCOVA_edata <- ANCOVA_edata;
+
+ } else if (Method=="RUV_random"){
+
+ QCms<-grep("IS",colnames(commonMat2));
+
+ if(any(is.na(QCms)) | is.null(QCms) | identical(QCms, integer(0))){
+ AddErrMsg(paste0("Quality Control Metabolites inforamtion is required for ",Method," !"))
+ return(F)
+ }
+
+
+ RUV_random_edata<-RUV_random(commonMat2);
+ mSetObj$dataSet$adjusted.mat <- mSetObj$dataSet$RUV_random_edata <- RUV_random_edata;
+
+ } else if (Method=="RUV_2"){
+
+ QCms<-grep("IS",colnames(commonMat2));
+
+ if(any(is.na(QCms)) | is.null(QCms) | identical(QCms, integer(0))){
+ AddErrMsg(paste0("Quality Control Metabolites inforamtion is required for ",Method," !"))
+ return(F)
+ }
+
+
+ if(any(is.na(class.lbl2)) | is.null(class.lbl2)){
+ AddErrMsg(paste0("class inforamtion is required for ",Method," !"))
+ return(F)
+ }
+
+ RUV_2_edata<-RUV_2(commonMat2,class.lbl2);
+ mSetObj$dataSet$adjusted.mat <- mSetObj$dataSet$RUV_2_edata <- RUV_2_edata;
+
+ } else if (Method=="RUV_s"){
+
+ QCms<-grep("IS",colnames(commonMat2));
+
+ if(any(is.na(QCms)) | is.null(QCms) | identical(QCms, integer(0))){
+ AddErrMsg(paste0("Quality Control Metabolites inforamtion is required for ",Method," !"))
+ return(F)
+ }
+
+
+ if(any(is.na(class.lbl2)) | is.null(class.lbl2)){
+ AddErrMsg(paste0("class inforamtion is required for ",Method," !"))
+ return(F)
+ }
+
+ RUV_s_edata<-RUVs_cor(commonMat2,class.lbl2);
+ mSetObj$dataSet$adjusted.mat <- mSetObj$dataSet$RUV_s_edata <- RUV_s_edata;
+
+ } else if (Method=="RUV_r"){
+
+ QCms<-grep("IS",colnames(commonMat2));
+
+ if(any(is.na(QCms)) | is.null(QCms) | identical(QCms, integer(0))){
+ AddErrMsg(paste0("Quality Control Metabolites inforamtion is required for ",Method," !"))
+ return(F)
+ }
+
+
+ if(any(is.na(class.lbl2)) | is.null(class.lbl2)){
+ AddErrMsg(paste0("class inforamtion is required for ",Method," !"))
+ return(F)
+ }
+
+ RUV_r_edata<-suppressPackageStartupMessages(RUVr_cor(commonMat2,class.lbl2));
+ mSetObj$dataSet$adjusted.mat <- mSetObj$dataSet$RUV_r_edata <- RUV_r_edata;
+
+ } else if (Method=="RUV_g"){
+
+ QCms<-grep("IS",colnames(commonMat2));
+
+ if(any(is.na(QCms)) | is.null(QCms) | identical(QCms, integer(0))){
+ AddErrMsg(paste0("Quality Control Metabolites inforamtion is required for ",Method," !"))
+ return(F)
+ }
+
+
+ RUV_g_edata<-RUVg_cor(commonMat2);
+ mSetObj$dataSet$adjusted.mat <- mSetObj$dataSet$RUV_g_edata <- RUV_g_edata;
+
+ } else if (Method=="NOMIS"){
+
+ ISs <- grep("IS",colnames(commonMat2));
+
+ if(any(is.na(ISs)) | is.null(ISs) | identical(ISs, integer(0))){
+ AddErrMsg(paste0("Internal Standards inforamtion is required for ",Method," !"))
+ return(F)
+ }
+
+
+ NOMIS_edata <- NOMIS(commonMat2)
+ mSetObj$dataSet$adjusted.mat <- mSetObj$dataSet$NOMIS_edata <- NOMIS_edata;
+
+ } else if (Method=="CCMN"){
+
+ if(any(is.na(class.lbl2)) | is.null(class.lbl2)){
+ AddErrMsg(paste0("class inforamtion is required for ",Method," !"))
+ return(F)
+ }
+
+ ISs <- grep("IS",colnames(commonMat2));
+
+ if(any(is.na(ISs)) | is.null(ISs) | identical(ISs, integer(0))){
+ AddErrMsg(paste0("Internal Standards inforamtion is required for ",Method," !"))
+ return(F)
+ }
+
+ CCMN_edata <- CCMN2(commonMat2,class.lbl2)
+ mSetObj$dataSet$adjusted.mat <- mSetObj$dataSet$CCMN_edata <- CCMN_edata;
+
+ }
+
+ ,silent=F)
+
+ if (is.null(mSetObj$dataSet$adjusted.mat) | all(is.na(mSetObj$dataSet$adjusted.mat))){
+ AddErrMsg(paste0("Your data or format is not valid! Please double check!"));
+ return(F);
+ }
+
+ if (Method != "auto"){
+
+ nms<-names(mSetObj$dataSet)
+ nms<-nms[grepl("*edata",nms)]
+ nms<- c("table",nms)
+
+ interbatch_dis<-sapply(nms,FUN=.evaluate.dis,mSetObj=mSetObj,center=center)
+ mSetObj$dataSet$interbatch_dis <- interbatch_dis
+
+ }
+
+ mSetObj <- PlotPCA.overview(mSetObj, imgName, method=Method);
+ Plot.sampletrend(mSetObj,paste(imgName,"Trend"),method=Method);
+ plot.dist(mSetObj,paste(imgName,"dist"))
+
+ best.table <- mSetObj$dataSet$adjusted.mat
+
+ # save the meta-dataset
+ res <- data.frame(colnames(t(best.table)), class.lbl2, batch.lbl2, best.table);
+ colnames(res) <- c('NAME', 'CLASS', 'Dataset', colnames(best.table));
+ write.table(res, sep=",", file="MetaboAnalyst_batch_data.csv", row.names=F, quote=FALSE);
+
+ if(.on.public.web){
+ .set.mSet(mSetObj)
+ return("T");
+ }
+
+ end.time <- Sys.time()
+ return(.set.mSet(mSetObj));
+}
+
+#'Signal Drift Correction
+#'@description This function is designed to perform the signal drift correction.
+#'Batch effect and signal drift correction will be performed with QC-RLSC method in this function.
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input the name of the plot to create
+#'@import data.table
+#'@importFrom plyr join ddply . summarise id
+#'@importFrom dplyr rename mutate select enquo tbl_vars group_vars grouped_df group_vars groups
+#'@import edgeR
+#'@importFrom pcaMethods pca
+#'@importFrom crmn standardsFit
+#'@import impute
+#'@import BiocParallel
+#'@author Zhiqiang Pang, Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PerformSignalDriftCorrection <- function(mSetObj=NA, imgName=NULL){
+
+ if (is.null(imgName)){
+ imgName<-"image_sg"
+ }
+
+ ## Extract the information from the mSetObj Object
+ commonMat2 <- mSetObj[["dataSet"]][["table"]];
+ batch.lbl2 <- mSetObj[["dataSet"]][["batch.cls"]];
+ class.lbl2 <- mSetObj[["dataSet"]][["class.cls"]];
+ order.lbl2 <- mSetObj[["dataSet"]][["order.cls"]];
+ QCs<-grep("QC",as.character(class.lbl2));
+
+ if (identical(QCs,integer(0))){
+ stop("QC samples are required for signal driift correction. Please double check your data !")
+ }
+
+ if (all(!is.na(as.character(unique(batch.lbl2)))) & !is.null(batch.lbl2) &
+ all(!is.na(as.character(unique(class.lbl2)))) & !is.null(class.lbl2) &
+ all(!is.na(as.character(unique(order.lbl2)))) & !is.null(order.lbl2)){
+ print("Correcting with QC-RLSC...");
+ QC_RLSC_edata<-suppressWarnings(suppressMessages(QC_RLSC(commonMat2,batch.lbl2,class.lbl2,order.lbl2,QCs)));
+ mSetObj$dataSet$adjusted.mat <- mSetObj$dataSet$QC_RLSC_edata <- QC_RLSC_edata;
+ } else {
+ stop("Please double check the batch, class and order information is not missing ")
+ }
+
+ Plot.sampletrend(mSetObj,paste(imgName,"Trend"),method="QC_RLSC");
+
+ best.table <- mSetObj$dataSet$adjusted.mat
+
+ # save the meta-dataset
+ res <- data.frame(colnames(t(best.table)), class.lbl2, batch.lbl2, best.table);
+ colnames(res) <- c('NAME', 'CLASS', 'Dataset', colnames(best.table));
+ write.table(res, sep=",", file="MetaboAnalyst_signal_drift.csv", row.names=F, quote=FALSE);
+
+}
+
+#'Scatter plot colored by different batches
+#'@description Scatter plot colored by different batches
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 600.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotPCA.overview <- function(mSetObj, imgName, format="png", dpi=72, width=NA,method){
+
+ #mSetObj <- .get.mSet(mSetObj);
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- 11;
+ }else{
+ w <- width;
+ }
+ h <- 6;
+
+ mSetObj$imgSet$pca.batch.overview <- imgName;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ par(mfrow=c(1,2));
+
+ nlbls <- mSetObj$dataSet$batch.cls;
+ pca <- prcomp(mSetObj$dataSet$table, center=T, scale=T);
+ sum.pca<-summary(pca);
+ var.pca<-sum.pca$importance[2,]; # variance explained by each PC
+
+ ## plot score plot
+ pc1 = pca$x[, 1];
+ pc2 = pca$x[, 2];
+
+ xlabel = paste("PC1", "(", round(100*var.pca[1],1), "%)");
+ ylabel = paste("PC2", "(", round(100*var.pca[2],1), "%)");
+
+ semi.cols <- CreateSemiTransColors(mSetObj$dataSet$batch.cls);
+ if (all(semi.cols == "")){
+ semi.cols <- "#FF000080"
+ };
+
+ plot(pc1, pc2, xlab=xlabel, ylab=ylabel, pch=21, bg=semi.cols, col="gray", cex=1.6, main="Before Adjustment");
+ legend("topright", legend=unique(nlbls), pch=15, col=unique(semi.cols));
+
+ qcInx <- substr(names(pc1), 0, 2) == "QC";
+ if(sum(qcInx) > 0){
+ points(pc1[qcInx], pc2[qcInx], pch=3, cex=2, lwd=2);
+ }
+
+ df_tmp<-apply(mSetObj$dataSet$adjusted.mat,2,FUN = function(x){
+ if(length(which(x==0))==length(x)){
+ x[1]<-0.000001;
+ return(x)
+ } else {x}
+ })
+
+ #a1<-mSetObj$dataSet$adjusted.mat
+ mSetObj$dataSet$adjusted.mat <- df_tmp
+ pca <- prcomp(mSetObj$dataSet$adjusted.mat, center=T, scale=T);
+ sum.pca<-summary(pca);
+ var.pca<-sum.pca$importance[2,]; # variance explained by each PC
+
+ ## plot score plot
+ pc1 = pca$x[, 1];
+ pc2 = pca$x[, 2];
+
+ xlabel = paste("PC1", "(", round(100*var.pca[1],1), "%)");
+ ylabel = paste("PC2", "(", round(100*var.pca[2],1), "%)");
+
+ main_name<-paste0("After Adjustment_",method)
+
+ semi.cols <- CreateSemiTransColors(mSetObj$dataSet$batch.cls);
+ if (all(semi.cols == "")){
+ semi.cols <- "#FF000080"
+ };
+
+ plot(pc1, pc2, xlab=xlabel, ylab=ylabel, pch=21, bg=semi.cols, col="gray", cex=1.6, main=main_name);
+ legend("topright", legend=unique(nlbls), pch=15, col=unique(semi.cols));
+
+ qcInx <- substr(names(pc1), 0, 2) == "QC";
+ if(sum(qcInx) > 0){
+ points(pc1[qcInx], pc2[qcInx], pch=3, cex=2, lwd=2);
+ }
+
+ dev.off();
+ return(mSetObj);
+ #return(.set.mSet(mSetObj));
+
+}
+
+#'Sample Trend Scatter
+#'@description Scatter sample trend comparison between all sample of different batches
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 600.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@author Zhiqiang Pang \email{zhiqiang.pang@mail.mcgill.ca}, Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+Plot.sampletrend <- function(mSetObj, imgName, format="png", dpi=72, width=NA,method){
+
+ #mSetObj <- .get.mSet(mSetObj)
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+
+ if(is.na(width)){
+ w <- 11;
+ }else{
+ w <- width;
+ }
+ h <- 6;
+
+ mSetObj$imgSet$trend.batch.overview <- imgName;
+
+ # centerin the adjusted data
+ adjusted.data<-t(mSetObj$dataSet$adjusted.mat)
+ original.data<-t(mSetObj$dataSet$table)
+
+ complete_all_center = t(scale(t(original.data), center = TRUE, scale = FALSE))
+ toplot1 = svd(complete_all_center)
+
+ complete_all_center = t(scale(t(adjusted.data), center = TRUE, scale = FALSE))
+ toplot3 = svd(complete_all_center)
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+
+ # Define the image
+
+ par(mfcol=c(3,2))
+ par(mar = c(2,2,2,2))
+
+ plot.eigentrends(toplot1, "Raw Data")
+ plot.eigentrends(toplot3, paste("Normalized Data",method))
+
+ dev.off()
+}
+
+#'Batch Distance Plotting
+#'@description Scatter sample trend comparison between all sample of different batches
+plot.dist <- function(mSetObj=NA, imgName="dist",format="png", width=NA, dpi=72){
+ library(ggplot2)
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- length(mSetObj[["dataSet"]])*0.4+1.6;
+ }else{
+ w <- width;
+ }
+ h <- w*6/11;
+
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+
+ Methods<-gsub("_edata",names(mSetObj[["dataSet"]][["interbatch_dis"]]),replacement = "")
+ Methods[1] <- "Original_Table"
+ Distance<-unname(mSetObj[["dataSet"]][["interbatch_dis"]])
+ dist.sort <- order(Distance)
+
+ data<-data.frame(Methods,Distance,dist.sort)
+
+ p<-ggplot2::ggplot(data,aes(fill=factor(Distance),y=Distance,x=Methods)) +
+ geom_bar(position="dodge", stat="identity",width = 0.7) +
+ scale_fill_grey(start = 0.1,end = 0.85) +
+ theme_bw() +
+ theme(legend.position = "none",
+ axis.text.x = element_text( angle=45, hjust = 1),
+ axis.text.y = element_text( angle=-30)) +
+ scale_x_discrete(limits=Methods[dist.sort])+
+ geom_text(x=1, y=min(data$Distance)*1.05, label="*",size=10, color="black")
+ print(p)
+ dev.off();
+}
+
+##############################################
+##############################################
+########## Utilities for web-server ##########
+##############################################
+##############################################
+
+GetAllBatchNames <- function(mSetObj=NA){
+
+ #mSetObj <- .get.mSet(mSetObj);
+
+ if(is.null(mSetObj$dataSet$batch)){
+ return(0);
+ }
+ names(mSetObj$dataSet$batch);
+}
+
+ResetBatchData <- function(mSetObj=NA){
+ #mSetObj <- .get.mSet(mSetObj);
+ mSetObj$dataSet$batch <- mSetObj$dataSet$batch.cls <- NULL;
+ return(.set.mSet(mSetObj));
+}
+
+#'Create semitransparant colors
+#'@description Create semitransparant colors for a given class label
+#'@param cls Input class labels
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'
+CreateSemiTransColors <- function(cls){
+
+ # note, the first color (red) is for QC
+ col.nms <- rainbow(length(levels(cls)));
+
+ # convert to semi-transparent
+ semi.nms <- ToSemiTransParent(col.nms);
+
+ # now expand to the one-to-one match to cls element
+ col.vec <- vector(mode="character", length=length(cls));
+ for (i in 1:length(levels(cls))){
+ lv <- levels(cls)[i];
+ col.vec[cls==lv] <- semi.nms[i];
+ }
+ return(col.vec);
+}
+
+# convert rgb color i.e. "#00FF00FF" to semi transparent
+ToSemiTransParent <- function (col.nms, alpha=0.5){
+ rgb.mat <- t(col2rgb(col.nms));
+ rgb(rgb.mat/255, alpha=alpha);
+}
+
+#################################################
+##### Functions for Batch Effect Correction #####
+
+# 1. WaveICA Function
+WaveICA<-function(data,batch,group){
+ ### Wavelet Decomposition
+ if(.on.public.web){
+ dyn.load(.getDynLoadPath());
+ }
+
+ batch<-as.character(batch)
+ group<-as.character(group)
+ wf="haar";
+ K=20;t=0.05;t2=0.05;alpha=0;
+ #library(waveslim)
+ level<-floor(log10(nrow(data),2))
+ if (is.null(colnames(data))){
+ stop("data must have colnames")
+ };
+ coef<-list();
+ for (k in 1:(level+1)){
+ coef[[k]] <-matrix(NA,nrow(data),ncol(data))
+ }
+ for (j in 1:ncol(data)){
+ #cat(paste("######Decomposition",j,"########\n"))
+ data_temp<-data[,j]
+ x_modwt<-modwt(data_temp,wf=wf,n.levels =level)
+ for (k in 1:(level+1)){
+ coef[[k]][,j]<-x_modwt[[k]]
+ }
+ }
+ ##### ICA
+ index<-level+1
+ data_wave_ICA<-list()
+ for (i in (1:index)){
+ #cat(paste("######### ICA",i,"#############\n"))
+ data_coef<-coef[[i]]
+ data_coef_ICA<-normFact(fact="stICA",X=t(data_coef),ref=batch,refType ="categorical",k=K,t=t,ref2=group,refType2="categorical",t2=t2,alpha)
+ data_wave_ICA[[i]]<-t(data_coef_ICA$Xn)
+ }
+ ### Wavelet Reconstruction
+ index<-ncol(data)
+ index1<-length(data_wave_ICA)
+ data_coef<-matrix(NA,nrow(data_wave_ICA[[1]]),index1)
+ data_wave<-matrix(NA,nrow(data_wave_ICA[[1]]),ncol(data_wave_ICA[[1]]))
+ for (i in 1:index){
+ #cat(paste("######Reconstruction",i,"########\n"))
+ for (j in 1:index1){
+ data_coef[,j]<-data_wave_ICA[[j]][,i]
+ }
+ data_temp<-data[,i]
+ data_coef<-as.data.frame(data_coef)
+ colnames(data_coef)<-c(paste("d",1:(index1-1),sep=""),paste("s",(index1-1),sep=""))
+ y<-as.list(data_coef)
+ attributes(y)$class<-"modwt"
+ attributes(y)$wavelet<-wf
+ attributes(y)$boundary<-"periodic"
+ data_wave[,i]<-imodwt(y)+mean(data_temp)
+ }
+ rownames(data_wave)<-rownames(data)
+ colnames(data_wave)<-colnames(data)
+ return(data_wave)
+}
+
+# 2. Combat Function
+combat<-function(data,batch,mod){
+ # note, transpose to fit the gene expression format
+ correc_edata <- suppressMessages(sva::ComBat(dat=t(data), batch=batch, mod=mod, par.prior=TRUE, prior.plots=FALSE))
+ return(t(correc_edata))
+}
+
+# 3. RUVSeq_sample Function
+RUVs_cor<-function(data,class){
+
+ data<-t(data)
+
+ QCm<-grep('IS',rownames(data))
+ if (identical(QCm, integer(0))){
+ AddErrMsg("QCm is required to be defined in data matrix colnames !")
+ }
+ class.list<-list()
+ for (i in levels(class)){
+ class.list[[i]]<-grep(i,class)
+ }
+ idx<-unlist(lapply(class.list,length))
+ max.idx<-max(idx)
+
+ differences<-matrix(nrow = length(idx),ncol = max.idx)
+ for (i in seq(length(idx))){
+ differences[i,]<-c(which(class==levels(class)[i]),rep(-1,(max.idx-idx[i])))
+ }
+
+ data[data<=0]<-0.0001
+ data.log<-log10(data)
+
+ data.cor<-RUVs(log10(data),
+ cIdx = QCm,
+ k = 1,
+ scIdx = differences,
+ isLog = T)[["normalizedCounts"]]
+
+ data.corrected<-exp(data.cor)
+
+ return(t(data.corrected))
+
+}
+
+# 4. RUVSeq_residual Function
+RUVr_cor<-function(data,class){
+
+ data<-t(data);
+
+ QCm<-grep('IS',rownames(data))
+ if (identical(QCm, integer(0))){
+ AddErrMsg("QCm is required to be defined in data matrix colnames !")
+ }
+
+ if (length(colnames(data))!=length(unique(colnames(data)))){
+ colnames(data)[(duplicated(colnames(data)))]<-paste0(colnames(data)[duplicated(colnames(data))],"_2")
+ }
+
+ design <- model.matrix(~class)
+
+ data[data<=0]<-0.0001
+
+ y <- DGEList(counts=data, group=class)
+ y <- calcNormFactors(y, method="upperquartile")
+ y <- estimateGLMCommonDisp(y, design)
+ y <- estimateGLMTagwiseDisp(y, design)
+
+ fit <- glmFit(y, design)
+ res <- residuals(fit, type="deviance")
+ #res <- fit[["deviance"]]
+ data.log<-log10(data)
+
+ seqRUVr <- RUVr(data.log,
+ QCm,
+ k=1,
+ res,
+ isLog = T)[["normalizedCounts"]]
+
+ data.corrected<-exp(seqRUVr)
+
+ return(t(data.corrected))
+
+}
+
+# 5. RUVSeq_g Function
+RUVg_cor<-function(data){
+
+ data<-t(data);
+
+ QCm<-grep('IS',rownames(data))
+ if (identical(QCm, integer(0))){
+ AddErrMsg("QCm is required to be defined in data matrix colnames !")
+ }
+
+ seqRUVg <- RUVg(data,
+ QCm,
+ k=1,
+ isLog = T)[["normalizedCounts"]]
+
+ return(t(seqRUVg))
+
+}
+
+# 6. RUV-random Function
+RUV_random<-function(data){
+ Y <- log10(data)
+ if (any(grepl("IS",colnames(Y)))){
+ IS<-Y[,grepl("IS",colnames(Y))]
+ }
+
+ if (is.null(IS)){
+ AddErrMsg("QCm is required to be defined in data matrix colnames !")
+ }
+
+ r<-numeric(dim(Y)[2])
+ for(j in 1:length(r)){
+ r[j]<-mean(cor(IS,Y[,j]))
+ }
+ ctl<-logical(length(r))
+ ctl[which(r>round(quantile(r,0.7),2))]<-TRUE
+
+ ruv<-NormalizeRUVRand(Y=Y,ctl=ctl,k=1)
+
+ return(exp(ruv$newY))
+}
+
+# 7. RUV-2 Function (caution: nu.coeff)
+RUV_2<-function(data,class){
+ return(naiveRandRUV(data, class, nu.coeff=2, k=1))
+}
+
+# 8. ANCOVA Function
+ANCOVA<-function(data,batch,QCs){
+ #require("BatchCorrMetabolomics")
+ batch<-as.factor(as.character(batch));
+ minBatchOccurrence.Ave <- 2
+ minBatchOccurrence.Line <- 3
+ conditions <- "" #creating a vector to represent the different methods of dealing with non-detects
+ experiments <- "Q" #creating a vector representing the correction strategies (QCs or samples)
+ methods <- rep("lm", length(experiments))
+ imputeValues <- rep(NA, length(experiments)) #create a vector the same length as experiments with repeating NAs
+ #PosFF.Refs <- list("Q" = which(PosMeta$SCode == "ref"))
+ strategies <- rep("Q", each = length(conditions)) #make a repeating vector of Qs and Ss
+
+
+ PosFF.Final <- lapply(seq(along = experiments), function(x)
+ apply(data, 2, ANCOVA_doBC,
+ ref.idx = QCs,
+ batch.idx = batch,
+ minBsamp = minBatchOccurrence.Line,
+ seq.idx = NULL,
+ method = methods[x],
+ imputeVal = imputeValues[x]))
+
+ names(PosFF.Final) <- experiments
+
+ corrected <- do.call(rbind.data.frame, PosFF.Final)
+ # remove Q from row names
+ for (i in 1:nrow(corrected)){
+ rownames(corrected)[i] <- gsub("^[^.]*\\.","", rownames(corrected)[i])
+ }
+
+ return(as.matrix(corrected))
+}
+
+# 9. QC-RLSC Function
+QC_RLSC<-function(data,batch,class,order,QCs){
+
+ # format the data table
+ ID=colnames(data)
+ sample=rownames(data)
+
+ if (length(sample)!=length(unique(sample))){
+ asample<-paste0(sample,"_",as.character(batch)) # to make the sample name unique.
+ } else {
+ asample<-sample
+ }
+
+ sample_split<-as.character(sapply(asample,FUN=function(x){rep(x,length(ID))}))
+ values<-as.numeric(sapply(c(1:nrow(data)), FUN = function(x){data[x,]}))
+ batch2<-as.character(sapply(batch,FUN=function(x){rep(x,length(ID))}))
+
+ class[QCs]<-NA
+ class<-as.character(sapply(class,FUN=function(x){rep(x,length(ID))}))
+ order<-as.numeric(sapply(order,FUN=function(x){rep(x,length(ID))}))
+
+ peaksData<-data.frame(ID=rep(ID,length(sample)),sample=sample_split,value=values,
+ batch=batch2,class=class,order=order)
+
+ ## Start the process
+
+ qcData <- peaksData[is.na(peaksData$class),]
+ samList<-data.frame(sample=rownames(data),batch=batch,
+ class=class,order=unique(order))
+
+ maxOrder<-max(samList$order); loessDegree <- 2; loessSpan <- 0.5
+ qcData$ID_batch <- paste(qcData$ID,qcData$batch,sep="_")
+
+ if(loessSpan==0){
+
+ intPredict <- lapply(unique(qcData$ID_batch),.runFit1,
+ qcData=qcData,maxOrder=maxOrder)
+
+ intPredict <- rbindlist(intPredict)
+ intPredict <- as.data.frame(intPredict)
+
+ }else{
+ #suppressMessages(require(BiocParallel))
+ intPredict <- BiocParallel::bplapply(unique(qcData$ID_batch),
+ .runFit2,
+ qcData=qcData,
+ maxOrder=maxOrder,
+ loessSpan =loessSpan,
+ BPPARAM = BiocParallel::bpparam())
+
+ #intPredict <- lapply(unique(qcData$ID_batch),.runFit2,
+ # qcData=qcData,maxOrder=maxOrder)
+
+ intPredict <- data.table::rbindlist(intPredict)
+ intPredict <- as.data.frame(intPredict)
+
+ }
+
+ newOrder <- 1:maxOrder
+
+ intPredict <- dplyr::rename(intPredict,order=newOrder)
+ ## head: sample ID value batch class order valuePredict
+
+ peaksData$valuePredict <- NULL
+ peaksData$valueNorm <- NULL
+ peaksData <- plyr::join(peaksData,intPredict,
+ by=intersect(names(peaksData),names(intPredict)))
+ #require(plyr)
+ mpa <- plyr::ddply(peaksData,plyr::.(ID),plyr::summarise,mpa=median(value,na.rm = TRUE))
+ peaksData <- plyr::join(peaksData,mpa,
+ by=intersect(names(peaksData),names(mpa)))
+ peaksData <- dplyr::mutate(peaksData,valuePredict=valuePredict/mpa)
+ peaksData$mpa <- NULL
+
+ peaksData$value[peaksData$value<=0] <- NA
+ peaksData$valueNorm <- peaksData$value/peaksData$valuePredict
+ peaksData$valuePredict[peaksData$valuePredict<=0] <- NA
+
+ ## calculate CV using this value
+ peaksData$valueNorm[peaksData$valueNorm<=0] <- NA
+
+ ## Value imputation
+ peaksData<-suppressMessages(.imputation(peaksData))
+ ## For each batch
+ ## CV plot
+ cvStat <- plyr::ddply(peaksData[is.na(peaksData$class),],plyr::.(ID,batch),
+ plyr::summarise,
+ rawCV=sd(value,na.rm = TRUE)/mean(value,na.rm = TRUE),
+ normCV=sd(valueNorm,na.rm = TRUE)/mean(valueNorm,na.rm = TRUE))
+
+
+ cvStatForEachBatch <- reshape2::melt(cvStat,id.vars = c("ID","batch"),
+ variable.name = "CV")
+ cvStatForEachBatch$batch <- as.factor(cvStatForEachBatch$batch)
+
+ #message("Summary information of the CV for QC samples:")
+ cvTable <- plyr::ddply(cvStatForEachBatch,plyr::.(batch,CV),plyr::summarise,
+ lessThan30=sum(value<=0.3,na.rm = TRUE),
+ total=length(value),ratio=lessThan30/total)
+
+ cvStat <- plyr::ddply(peaksData[is.na(peaksData$class),],plyr::.(ID),
+ plyr::summarise,
+ rawCV=sd(value,na.rm = TRUE)/mean(value,na.rm = TRUE),
+ normCV=sd(valueNorm,na.rm = TRUE)/mean(valueNorm,na.rm = TRUE))
+
+
+ cvStatForAll <- reshape2::melt(cvStat,id.vars = c("ID"),
+ variable.name = "CV")
+ ## output information
+ #message("Summary information of the CV for QC samples:")
+ cvTable <- plyr::ddply(cvStatForAll,plyr::.(CV),plyr::summarise,
+ lessThan30=sum(value<=0.3,na.rm = TRUE),
+ total=length(value),ratio=lessThan30/total)
+ #print(cvTable)
+
+
+
+ ########################################################
+ #message("Peaks with CV > ",0.3,"!")
+ #message(sum(cvStat$normCV > 0.3,na.rm = TRUE))
+ tmpPeaksData <- merge(peaksData,cvStat,by="ID")
+
+ if(nrow(tmpPeaksData)!=nrow(peaksData)){
+ #error_file <- paste(para@outdir,"/",para@prefix,"-doQCRLSC-error.rda",
+ # sep="")
+ #message("Please see the file: ",error_file," for detail!")
+ #save(peaksData,cvStat,file=error_file)
+ stop("Please see detailed data in ",error_file)
+ }
+ peaksData <- tmpPeaksData
+ peaksData <- dplyr::rename(peaksData,cv=normCV)
+
+ ### Format the final table
+ #x <- peaksData %>% dplyr::select(ID,sample,!!"value") %>%
+ # spread(sample,!!"value")
+ valueID="value"
+ x_tmp<-dplyr::select(peaksData,ID,sample,!!valueID)
+ x<-spread(x_tmp,sample,!!valueID)
+ #x<-dcast(peaksData,ID~sample,value.var = valueID)
+ row.names(x) <- x$ID
+ x$ID <- NULL
+ x[x<=0] <- NA
+ corrected.data<-x
+
+ #order.list <- match(as.character(peaksData$sample),asample)
+ #peaksData3<-cbind(peaksData,order.list)
+ #peaksData2<-peaksData3[order(order.list),];
+ #cnames<-unique(peaksData2$sample)
+ #a1<-lapply(1:length(sample),FUN=function(x){peaksData2[c((length(ID)*(x-1)+1):(length(ID)*x)),c(1,8)]})
+ #a1<-.cbindlist(a1);rnames<-a1$ID
+ #corrected.data<-a1[,colnames(a1)!="ID"][,-1]
+ #rownames(corrected.data)<-rnames;
+ #colnames(corrected.data)<-cnames
+
+ #return(t(corrected.data))
+
+ return(t(corrected.data))
+
+}
+
+# 10. EigenMS Function
+EigenMS<-function(data,class){
+ ## Format the data
+ a1<-as.character(class)
+ a1[is.na(a1)]<-"Q"
+ class<-as.factor(a1)
+ m_logInts<-t(data)
+
+ # Running the normalization/correction
+ m_prot.info<-data.frame(peak=rownames(m_logInts),ID=seq(nrow(m_logInts)))
+ m_ints_eig1 = eig_norm1(m=m_logInts,treatment=class,prot.info=m_prot.info)
+ m_ints_norm1 = eig_norm2(rv=m_ints_eig1)
+
+ data.table<-m_ints_norm1[["normalized"]]
+
+ rownames(data.table)<-data.table[,1]
+ data.table<-data.table[,-c(1:2)]
+ data.table<-t(data.table)
+ data.table[data.table<0]<-0
+
+ return(data.table)
+}
+
+# 11. NOMIS Function
+NOMIS<-function(data){
+
+ object<-t(data)
+
+ standards<-grepl("IS",rownames(object))
+
+ ana <- lana <-t(object[!standards,])
+ sta <- lsta <-t(object[standards,])
+
+ if((any(!is.finite(lsta)) | any(!is.finite(lsta)) |
+ any(!is.finite(lana)) | any(!is.finite(lana))) & ncol(lsta) > 1) {
+ lana[!is.finite(lana)] <- NA
+ lsta[!is.finite(lsta)] <- NA
+ lana <- completeObs(pca(lana, method="ppca"))
+ if(all(dim(lsta)) > 1)
+ lsta <- completeObs(pca(lsta, method="ppca"))
+ }
+
+ means <- colMeans(lana)
+ sds <- apply(lana, 2, sd, na.rm=TRUE)
+
+ model <- list(fit=lm(I(lana)~I(lsta)), means=means)
+ lnormedData <- lana - predict(model[["fit"]], data.frame(I(lsta)))
+ lnormedData <- sweep(lnormedData, 2, model[["means"]], "+")
+
+ return(lnormedData)
+
+}
+
+# 12. CCMN Function
+CCMN2<-function(data,class){
+
+ object<-t(data);
+ factors<-class;
+ lg<-F
+ standards<-grepl("IS",rownames(object))
+ factors=model.matrix(~-1+. , data=data.frame(factors))
+ ncomp=2
+
+ ana <- lana <-t(object[!standards,])
+ sta <- lsta <-t(object[standards,])
+
+
+ if((any(!is.finite(lsta)) | any(!is.finite(lsta)) |
+ any(!is.finite(lana)) | any(!is.finite(lana))) & ncol(lsta) > 1) {
+ lana[!is.finite(lana)] <- NA
+ lsta[!is.finite(lsta)] <- NA
+ lana <- completeObs(pca(lana, method="ppca"))
+ if(all(dim(lsta)) > 1)
+ lsta <- completeObs(pca(lsta, method="ppca"))
+ }
+
+ means <- colMeans(lana)
+ sds <- apply(lana, 2, sd, na.rm=TRUE)
+
+ sfit <- standardsFit(object, factors, lg=lg, ncomp=ncomp,standards=standards)
+ tz <- standardsPred(sfit, object, factors, lg=lg, standards=standards)
+ sclana <- scale(lana);fitfunc=lm
+ pfit <- fitfunc(sclana~-1+I(tz))
+ model <- list(fit=pfit,sds=sds, means=means)
+
+ if(lg){
+ lana <- log10(ana)
+ } else{
+ lana <- ana
+ }
+
+ ## center/scale
+ lana <- scale(lana, center=model[["means"]], scale=model[["sds"]])
+ ## correct
+ lnormedData <- lana - predict(model[["fit"]], data.frame(I(tz)))
+ ## recenter/rescale
+ lnormedData <- sweep(lnormedData, 2, model[["sds"]], "*")
+ lnormedData <- sweep(lnormedData, 2, model[["means"]], "+")
+
+ if(lg){
+ return(exp(lnormedData))
+ } else{
+ return(lnormedData)
+ }
+
+}
+
+# 2. Evalute Correction Model
+# 2.0 Model Selection
+.model.evaluation<-function(mSetObj,data.type){
+ #require(vegan);
+ edata.dca <- try(decorana(mSetObj[["dataSet"]][[data.type]]),silent = T);
+
+ # to decide CA or PCA suitable to use (Gradient Length, first axis)
+ # if greater than 3, CCA will be used, otherwise PCA instead.
+ # Ref: Lepš, J. & Šmilauer, P. 2003. Multivariate Analysis of Ecological Data using CANOCO. Cambridge Press.
+ if (class(edata.dca)=="try-error"){
+ return ("PCA")
+ } else {
+ gradient.length<-max(edata.dca[["rproj"]][,1]);
+ if (gradient.length > 3){
+ return("CCA")
+ } else {
+ return("PCA")
+ };
+ }
+}
+
+# 2.3 Distance Calculation
+.evaluate.dis<-function(mSetObj,data.type,center){
+
+ table <- mSetObj$dataSet[[data.type]];
+
+ df_tmp<-apply(table,2,FUN = function(x){
+ if(length(which(x==0))==length(x)){
+ x[1]<-0.000001;
+ return(x)
+ } else {x}
+ })
+
+ table<-df_tmp
+
+ model <- .model.evaluation(mSetObj,data.type);
+
+ if (center=="QC"){
+ QC_methods<-c("Combat_edata","WaveICA_edata","EigenMS_edata","QC_RLSC_edata","ANCOVA_edata");
+ } else {
+ QC_methods<-c("");
+ }
+
+ if (data.type %in% QC_methods){
+
+ #### Dustances between QCS
+ if (model=="PCA"){
+ pc.original<-prcomp(table,scale.=T);
+ nnms<-rownames(pc.original$x);
+ pc.original_select<-pc.original$x[grepl("QC",nnms),1:3];
+
+ } else {
+ pc.original<-cca(table,scale.=T);
+ nnms<-rownames(pc.original$x);
+ pc.original_select<-pc.original[["CA"]][["Xbar"]][grepl("QC",nnms),1:3];
+
+ }
+
+ dist.original <- dist(pc.original_select,method ="euclidean")
+ dist.original <- as.matrix(dist.original)
+
+ ns<-dim(pc.original_select)[1]
+ interbatch.dis <- sum(dist.original)/(ns*ns-ns)
+
+ } else{
+
+ ##### Distances between subject samples
+ if (model=="PCA"){
+
+ pc.original<-prcomp(table,scale.=T);
+ #nnms<-rownames(pc.original$x);
+ pc.original_select<-pc.original$x[,1:3];
+
+ } else {
+
+ pc.original<-cca(table,scale.=T);
+ #nnms<-rownames(pc.original$x);
+ pc.original_select<-pc.original[["CA"]][["Xbar"]][,1:3];
+
+ }
+
+ dist.original<-dist(pc.original_select,method ="euclidean");
+ dist.original<-as.matrix(dist.original);
+
+ ns<-dim(pc.original_select)[1];
+ interbatch.dis <- sum(dist.original)/(ns*ns-ns);
+ }
+ return(interbatch.dis);
+}
+
+
+#### Internal Functions- WaveICA and wavelism
+normFact <- function(fact,X,ref,refType,k=20,t=0.5,ref2=NULL,refType2=NULL,t2=0.5,alpha,...) {
+ if (fact=='stICA'){
+ obj = unbiased_stICA(X,k,alpha=alpha)
+ B=obj$B
+ A=obj$A
+ } else if (fact == 'SVD'){
+ obj = svd(X,nu=k,nv=k)
+ A = obj$u%*%diag(obj$d[1:k],k)
+ B = obj$v
+ } else {
+ stop("Factorization method should be SVD or stICA")
+ }
+
+ factR2 = R2(ref,B,refType,pval=T)
+
+ idx = which(factR2$allpv<t)
+
+ if (t <0 | t>1){stop("t not in [0 1]")}
+
+ if (!is.null(ref2)){
+ if (sum(t2 <0 | t2>1)){stop("t2 not in [0 1]")}
+ factR2_2 = R2(ref2,B,refType2,pval=T)
+ idx_2 = c()
+ if (length(t2)!=length(refType2)){
+ if(length(t2)==1){
+ t2=rep(t2,length(refType2))
+ }
+ else {
+ stop("length(t2) sould be equal to 1 or length(refType2)")
+ }
+ }
+ for (i in 1:length(refType2)){
+
+ idx_2 = c(idx_2,which(factR2_2$allpv[,i]<t2[i]))
+ }
+
+ idx2keep =intersect(idx,idx_2)
+ #print(paste("Keeping",length(idx2keep), "cmpts with P value less than t2"))
+ idx = setdiff(idx, idx2keep)
+ }
+
+ bestcmptA = A[,idx]
+ bestcmptB = B[,idx]
+
+ #print(paste("Removing",length(idx),"components with P value less than",t))
+
+ Xn = X - bestcmptA%*% t(bestcmptB)
+
+ R2=factR2$allR2
+ if (!is.null(ref2)){
+ R2 = cbind(R2,factR2_2$allR2)
+ }
+
+ return(list(Xn=Xn,R2=R2,bestSV =bestcmptB,A=A,B=B))
+}
+
+unbiased_stICA <- function(X,k=10,alpha) {
+
+ #library(JADE)
+ #library(corpcor)
+
+ jadeCummulantMatrices <- function(X) {
+
+ n <- nrow(X)
+ t <- ncol(X)
+
+ M <- array(0,c(n,n,n*(n+1)/2))
+ scale <- matrix(1,n,1)/t # for convenience
+
+ R <- cov(t(X)) # covariance
+
+ k <- 1
+ for (p in 1:n){
+ #case q=p
+ C <- ((scale %*% (X[p,]*X[p,]))*X) %*% t(X)
+ E <- matrix(0,n,n)
+ E[p,p] <- 1
+ M[,,k] <- C - R %*% E %*% R - sum(diag(E %*% R)) * R - R %*% t(E) %*% R
+ k <- k+1
+ #case q<p
+ if (p > 1) {
+ for (q in 1:(p-1)){
+ C <- ((scale %*% (X[p,]*X[q,]))*X) %*% t(X) * sqrt(2)
+ E <- matrix(0,n,n)
+ E[p,q] <- 1/sqrt(2)
+ E[q,p] <- E[p,q]
+ M[,,k] <- C - R %*% E %*% R - sum(diag(E %*% R)) * R - R %*% t(E) %*% R
+ k <- k+1
+ }
+ }
+ }
+ return(M)
+ }
+
+ p <- nrow(X)
+ n <- ncol(X)
+
+ dimmin <- min(n,p)
+
+ if (dimmin < k) {
+ k <- dimmin
+ }
+ if (alpha <0 | alpha >1){
+ stop("alpha not in [0 1]")
+ }
+
+ # Remove the spatiotemporal mean
+
+ Xc <- X - matrix(rep(colMeans(X,dims=1),p),nrow = p,byrow=T);
+ Xc <- Xc - matrix(rep(rowMeans(Xc,dims=1),n),nrow = p);
+
+ # SVD of Xc and dimension reduction: keeping only the k first
+ # components
+ udv <- svd(Xc,k,k)
+ D <- diag(udv$d[1:k]); if (k==1) {D <- udv$d[1]}
+ U <- udv$u;
+ V <- udv$v;
+
+ # Estimation of the cumulant matrices
+ nummat <- k*(k+1)/2;
+ M <- array(0,c(k,k,2*nummat));
+ Bt <- D^(1-alpha) %*% t(V)
+ if (alpha == 1) { Bt <- t(V)}
+ At <- D^(alpha) %*% t(U)
+ if (alpha == 0) { At <- t(U)}
+ M[,,1:nummat] <- jadeCummulantMatrices(Bt);
+ M[,,(nummat+1):(2*nummat)] <- jadeCummulantMatrices(At)
+
+ # normalization within the groups in order to allow for comparisons using
+ # alpha
+ M[,,1:nummat] <- alpha*M[,,1:nummat]/mean(sqrt(apply(M[,,1:nummat]*M[,,1:nummat],3,sum)));
+ M[,,(nummat+1):(2*nummat)] <- (1-alpha)*M[,,(nummat+1):(2*nummat)]/mean(sqrt(apply(M[,,(nummat+1):(2*nummat)]*M[,,(nummat+1):(2*nummat)],3,sum)));
+
+ # Joint diagonalization
+ Worth <- rjd(M,eps = 1e-06, maxiter = 1000);
+ Wo <-t (Worth$V);
+ # Computation of A and B
+
+ A0 <- U %*% D^(alpha) %*% solve(Wo);
+ B0 <- V%*% D^(1-alpha) %*% t(Wo);
+ if (alpha == 1) { B0 <- V %*% t(Wo)}
+ if (alpha == 0) { A0 <- U %*% solve(Wo)}
+
+ # Add transformed means
+ meanCol <- matrix(colMeans(X,dims=1),ncol =1); # spatial means
+ meanRows <- matrix(rowMeans(X,dims=1),ncol = 1); # temporal means
+
+ meanB <- pseudoinverse(A0) %*% (meanRows);
+ meanA <- pseudoinverse(B0) %*% (meanCol);
+
+ Bfin <- B0 + matrix(rep(meanB,n),nrow = n,byrow=T)
+ Afin <- A0 + matrix(rep(meanA,p),nrow = p,byrow=T)
+ return(list(A=Afin,B=Bfin,W=Wo))
+}
+
+modwt<-function (x, wf = "la8", n.levels = 4, boundary = "periodic") {
+ switch(boundary, reflection = x <- c(x, rev(x)), periodic = invisible(),
+ stop("Invalid boundary rule in modwt"))
+ N <- length(x)
+ storage.mode(N) <- "integer"
+ J <- n.levels
+ if (2^J > N)
+ stop("wavelet transform exceeds sample size in modwt")
+ dict <- wave.filter(wf)
+ L <- dict$length
+ storage.mode(L) <- "integer"
+ ht <- dict$hpf/sqrt(2)
+ storage.mode(ht) <- "double"
+ gt <- dict$lpf/sqrt(2)
+ storage.mode(gt) <- "double"
+ y <- vector("list", J + 1)
+ names(y) <- c(paste("d", 1:J, sep = ""), paste("s", J, sep = ""))
+ W <- V <- numeric(N)
+ storage.mode(W) <- "double"
+ storage.mode(V) <- "double"
+ for (j in 1:J) {
+ out <- C_modwt_r(as.double(x), N, as.integer(j), L,
+ ht, gt, W = W, V = V)
+ y[[j]] <- out$W
+ x <- out$V
+ }
+ y[[J + 1]] <- x
+ class(y) <- "modwt"
+ attr(y, "wavelet") <- wf
+ attr(y, "boundary") <- boundary
+ return(y)
+}
+
+R2 <- function(poi,V,poiType,pval = T) {
+ #
+ # R2(poi,V,poiType)
+ #
+ # Args:
+ # - V is a p*k matrix, where the rows corresponds to the samples
+ # - poi is a matrix p*l, representing the phenotypes of interest
+ # - poiType (1*l) is the types of poi: 'continuous' (then a linear
+ # regression is used) or 'categorical' (then the mean by class is used)
+ #
+ # Outputs:
+ # - R2(l), higher R^2 value between a column of V and poi(l)
+ # - idxCorr(l), index of the column of V giving the higher R^2 value (if many,
+ # takes the first one)
+ # - allR2(k,l), R2 value for column k of V with poi l
+ #
+ # IF pval =TRUE, return also: #
+ # - pv(l) smaller p-value association between a column of V and poi(l)
+ # - idxcorr2(l) index of the column of V giving the smaller p-value (if many,
+ # # takes the first one)
+ # - allpv(k,l), p-value for column k of V with poi l
+ #
+ # if missing information in poi, remove the corresponding samples in the R2 computation
+
+
+ if (is.vector(V) ){ V = matrix(V,ncol=1)}
+ if (is.vector(poi)){poi = matrix(poi,nrow =length(poi))}
+
+ p = nrow(V) # number of samples
+ k = ncol(V) # number of components
+ l = length(poiType) # number of cf/poi to test
+ if (is.null(l)){stop("POI type(s) neeeded")}
+ p2 = nrow(poi)
+ l2 = ncol(poi)
+
+ if( l2 != l){ # checking poi and poiType dimensions compatiblity
+ if (p2 == l){ # if poi is transposed (l*p)
+ poi = t(poi)
+ warning("Transposing poi to match poiType dimension")
+ p2 = nrow(poi)
+ } else {
+ #print(poi)
+ #print(poiType)
+ stop("poi dimensions doesn't match poiType dimension")
+ }
+ }
+
+ if (p != p2){ # checking poi and V dimensions compatiblity
+ if (p2 == k){
+ warnings("Transposing V to match poi dimension")
+ V =t(V)
+ k = p
+ p = p2
+ } else {
+ stop("poi and V dimensions incompatible")
+ }
+ }
+
+ R2 = rep(-1,l)
+ names(R2) = colnames(poi)
+ idxcorr = R2
+ R2_tmp <- matrix(rep(-1,k*l),k,l,dimnames=list(colnames(V),colnames(poi))) # r2_tmp(k,l) hold the R2 value for column k of V with poi l
+
+ if (pval){
+ pv = R2
+ idxcorr2 = R2
+ pv_tmp <- R2_tmp # r2_tmp(k,l) hold the R2 value for column k of V with poi l
+ }
+
+ for (cmpt in 1:k){ # for each column of V
+ cmpt2an <- V[,cmpt]
+ for (ipoi in 1:l){
+ idx_finite = is.finite(as.factor(poi[,ipoi]))
+ poi2an = poi[idx_finite,ipoi]
+ cmpt2an_finite=cmpt2an[idx_finite]
+ if (poiType[ipoi] == "continuous") { # estimation by linear regression
+ coefs <- coef(lm(cmpt2an_finite~as.numeric(poi2an)))
+ cmpt2an_est <- coefs[2]*as.numeric(poi2an)+coefs[1]
+ nc <- 2;
+ } else if (poiType[ipoi]=="categorical"){ # estimation by classe mean
+ classes <- unique(poi2an)
+ nc <- length(classes)
+ cmpt2an_est <- rep(NA,length(cmpt2an_finite))
+ for (icl in 1:length(classes) ){
+ idxClasse <- which(poi2an==classes[icl])
+ cmpt2an_est[idxClasse] <- mean(cmpt2an_finite[idxClasse])
+ }
+ } else {
+ stop("Incorrect poiType. Select 'continuous' or 'categorical'. ")
+ }
+ sse <- sum((cmpt2an_finite-cmpt2an_est)^2)
+ sst <- sum((cmpt2an_finite-mean(cmpt2an_finite))^2)
+ R2_tmp[cmpt,ipoi] <- 1 - sse/sst
+ if (pval){
+ F <- ((sst-sse)/(nc-1))/(sse/(p-nc))
+ pv_tmp[cmpt,ipoi] = 1-pf(F,nc-1,p-nc);
+ if (!is.finite(pv_tmp[cmpt,ipoi])) {
+ warning(paste("Non finite p-value for component ",cmpt," (pv=",pv_tmp[cmpt,ipoi],", F=",F,"), assigning NA", sep=""))
+ pv_tmp[cmpt,ipoi] <- NA
+ }
+ }
+ }
+ }
+
+ for (ipoi in 1:l){
+ if (pval){
+ pv[ipoi] <- min(pv_tmp[,ipoi])
+ idxcorr2[ipoi] <- which(pv_tmp[,ipoi] == pv[ipoi])[1] # if more than one component gives the best R2, takes the first one
+ }
+ R2[ipoi] <- max(R2_tmp[,ipoi])
+ idxcorr[ipoi] <- which(R2_tmp[,ipoi] == R2[ipoi])[1] # if more than one component gives the best R2, takes the first one
+ }
+
+ if (pval){
+ return(list(R2=R2,idxcorr=idxcorr,allR2 = R2_tmp, pv=pv,idxcorr2=idxcorr2,allpv = pv_tmp))
+ } else {
+ return(list(R2=R2,idxcorr=idxcorr,allR2 = R2_tmp))
+ }
+}
+
+wave.filter <- function(name){
+ select.haar <- function() {
+ L <- 2
+ g <- c(0.7071067811865475, 0.7071067811865475)
+ h <- qmf(g)
+ return(list(length = L, hpf = h, lpf = g))
+ }
+ select.d4 <- function() {
+ L <- 4
+ g <- c(0.4829629131445341, 0.8365163037378077, 0.2241438680420134,
+ -0.1294095225512603)
+ h <- qmf(g)
+
+ return(list(length = L, hpf = h, lpf = g))
+ }
+ select.mb4 <- function() {
+ L <- 4
+ g <- c(4.801755e-01, 8.372545e-01, 2.269312e-01, -1.301477e-01)
+ h <- qmf(g)
+ return(list(length = L, hpf = h, lpf = g))
+ }
+ select.bs3.1 <- function() {
+ L <- 4
+ g <- c(0.1767767, 0.5303301, 0.5303301, 0.1767767)
+ h <- qmf(g)
+ gd <- c(0.3535534, 1.06066, -1.06066, -0.3535534)
+ hd <- qmf(g)
+ return(list(length = L, hpf = h, lpf = g, dhpf = hd, dlpf = gd))
+ }
+ select.w4 <- function() {
+ L <- 4
+ g <- c(-1, 3, 3, -1) / 8
+ h <- c(-1, 3, -3, 1) / 8
+ return(list(length = L, hpf = h, lpf = g))
+ }
+ select.fk4 <- function() {
+ L <- 4
+ g <- c(.6539275555697651, .7532724928394872, .5317922877905981e-1,
+ -.4616571481521770e-1)
+ h <- qmf(g)
+ return(list(length = L, hpf = h, lpf = g))
+ }
+ select.d6 <- function() {
+ L <- 6
+ g <- c(0.3326705529500827, 0.8068915093110928, 0.4598775021184915,
+ -0.1350110200102546, -0.0854412738820267, 0.0352262918857096)
+ h <- qmf(g)
+ return(list(length = L, hpf = h, lpf = g))
+ }
+ select.fk6 <- function() {
+ L <- 6
+ g <- c(.4279150324223103, .8129196431369074, .3563695110701871,
+ -.1464386812725773, -.7717775740697006e-1, .4062581442323794e-1)
+ h <- qmf(g)
+ return(list(length = L, hpf = h, lpf = g))
+ }
+ select.d8 <- function() {
+ L <- 8
+ g <- c(0.2303778133074431, 0.7148465705484058, 0.6308807679358788,
+ -0.0279837694166834, -0.1870348117179132, 0.0308413818353661,
+ 0.0328830116666778, -0.0105974017850021)
+ h <- qmf(g)
+ return(list(length = L, hpf = h, lpf = g))
+ }
+ select.fk8 <- function() {
+ L <- 8
+ g <- c(.3492381118637999, .7826836203840648, .4752651350794712,
+ -.9968332845057319e-1, -.1599780974340301, .4310666810651625e-1,
+ .4258163167758178e-1, -.1900017885373592e-1)
+ h <- qmf(g)
+ return(list(length = L, hpf = h, lpf = g))
+ }
+ select.la8 <- function() {
+ L <- 8
+ g <- c(-0.07576571478935668, -0.02963552764596039, 0.49761866763256290,
+ 0.80373875180538600, 0.29785779560560505, -0.09921954357695636,
+ -0.01260396726226383, 0.03222310060407815)
+ h <- qmf(g)
+ return(list(length = L, hpf = h, lpf = g))
+ }
+ select.mb8 <- function() {
+ L <- 8
+ g <- rev(c(-1.673619e-01, 1.847751e-02, 5.725771e-01, 7.351331e-01,
+ 2.947855e-01, -1.108673e-01, 7.106015e-03, 6.436345e-02))
+ h <- qmf(g)
+ return(list(length = L, hpf = h, lpf = g))
+ }
+ select.bl14 <- function() {
+ L <- 14
+ g <- c( 0.0120154192834842, 0.0172133762994439, -0.0649080035533744,
+ -0.0641312898189170, 0.3602184608985549, 0.7819215932965554,
+ 0.4836109156937821, -0.0568044768822707, -0.1010109208664125,
+ 0.0447423494687405, 0.0204642075778225, -0.0181266051311065,
+ -0.0032832978473081, 0.0022918339541009)
+ h <- qmf(g)
+ return(list(length = L, hpf = h, lpf = g))
+ }
+ select.fk14 <- function() {
+ L <- 14
+ g <- c(.2603717692913964, .6868914772395985, .6115546539595115,
+ .5142165414211914e-1, -.2456139281621916, -.4857533908585527e-1,
+ .1242825609215128, .2222673962246313e-1, -.6399737303914167e-1,
+ -.5074372549972850e-2, .2977971159037902e-1, -.3297479152708717e-2,
+ -.9270613374448239e-2, .3514100970435962e-2)
+ h <- qmf(g)
+ return(list(length = L, hpf = h, lpf = g))
+ }
+ select.d16 <- function() {
+ L <- 16
+ g <- c(0.0544158422431049, 0.3128715909143031, 0.6756307362972904,
+ 0.5853546836541907, -0.0158291052563816, -0.2840155429615702,
+ 0.0004724845739124, 0.1287474266204837, -0.0173693010018083,
+ -0.0440882539307952, 0.0139810279173995, 0.0087460940474061,
+ -0.0048703529934518, -0.0003917403733770, 0.0006754494064506,
+ -0.0001174767841248)
+ h <- qmf(g)
+ return(list(length = L, hpf = h, lpf = g))
+ }
+ select.la16 <- function() {
+ L <- 16
+ g <- c(-0.0033824159513594, -0.0005421323316355, 0.0316950878103452,
+ 0.0076074873252848, -0.1432942383510542, -0.0612733590679088,
+ 0.4813596512592012, 0.7771857516997478, 0.3644418948359564,
+ -0.0519458381078751, -0.0272190299168137, 0.0491371796734768,
+ 0.0038087520140601, -0.0149522583367926, -0.0003029205145516,
+ 0.0018899503329007)
+ h <- qmf(g)
+ return(list(length = L, hpf = h, lpf = g))
+ }
+ select.mb16 <- function() {
+ L <- 16
+ g <- rev(c(-1.302770e-02, 2.173677e-02, 1.136116e-01, -5.776570e-02,
+ -2.278359e-01, 1.188725e-01, 6.349228e-01, 6.701646e-01,
+ 2.345342e-01, -5.656657e-02, -1.987986e-02, 5.474628e-02,
+ -2.483876e-02, -4.984698e-02, 9.620427e-03, 5.765899e-03))
+ h <- qmf(g)
+ return(list(length = L, hpf = h, lpf = g))
+ }
+ select.la20 <- function() {
+ L <- 20
+ g <- c(0.0007701598091030, 0.0000956326707837, -0.0086412992759401,
+ -0.0014653825833465, 0.0459272392237649, 0.0116098939129724,
+ -0.1594942788575307, -0.0708805358108615, 0.4716906668426588,
+ 0.7695100370143388, 0.3838267612253823, -0.0355367403054689,
+ -0.0319900568281631, 0.0499949720791560, 0.0057649120455518,
+ -0.0203549398039460, -0.0008043589345370, 0.0045931735836703,
+ 0.0000570360843390, -0.0004593294205481)
+ h <- qmf(g)
+ return(list(length = L, hpf = h, lpf = g))
+ }
+ select.bl20 <- function() {
+ L <- 20
+ g <- c(0.0008625782242896, 0.0007154205305517, -0.0070567640909701,
+ 0.0005956827305406, 0.0496861265075979, 0.0262403647054251,
+ -0.1215521061578162, -0.0150192395413644, 0.5137098728334054,
+ 0.7669548365010849, 0.3402160135110789, -0.0878787107378667,
+ -0.0670899071680668, 0.0338423550064691, -0.0008687519578684,
+ -0.0230054612862905, -0.0011404297773324, 0.0050716491945793,
+ 0.0003401492622332, -0.0004101159165852)
+ h <- qmf(g)
+ return(list(length = L, hpf = h, lpf = g))
+ }
+ select.fk22 <- function() {
+ L <- 22
+ g <- c(.1938961077599566, .5894521909294277, .6700849629420265,
+ .2156298491347700, -.2280288557715772, -.1644657152688429,
+ .1115491437220700, .1101552649340661, -.6608451679377920e-1,
+ -.7184168192312605e-1, .4354236762555708e-1, .4477521218440976e-1,
+ -.2974288074927414e-1, -.2597087308902119e-1, .2028448606667798e-1,
+ .1296424941108978e-1, -.1288599056244363e-1, -.4838432636440189e-2,
+ .7173803165271690e-2, .3612855622194901e-3, -.2676991638581043e-2,
+ .8805773686384639e-3)
+ h <- qmf(g)
+ return(list(length = L, hpf = h, lpf = g))
+ }
+ select.mb24 <- function() {
+ L <- 24
+ g <- rev(c(-2.132706e-05, 4.745736e-04, 7.456041e-04, -4.879053e-03,
+ -1.482995e-03, 4.199576e-02, -2.658282e-03, -6.559513e-03,
+ 1.019512e-01, 1.689456e-01, 1.243531e-01, 1.949147e-01,
+ 4.581101e-01, 6.176385e-01, 2.556731e-01, -3.091111e-01,
+ -3.622424e-01, -4.575448e-03, 1.479342e-01, 1.027154e-02,
+ -1.644859e-02, -2.062335e-03, 1.193006e-03, 5.361301e-05))
+ h <- qmf(g)
+ return(list(length = L, hpf = h, lpf = g))
+ }
+
+ switch(name,
+ "haar" = select.haar(),
+ "d4" = select.d4(),
+ "mb4" = select.mb4(),
+ "w4" = select.w4(),
+ "bs3.1" = select.bs3.1(),
+ "fk4" = select.fk4(),
+ "d6" = select.d6(),
+ "fk6" = select.fk6(),
+ "d8" = select.d8(),
+ "fk8" = select.fk8(),
+ "la8" = select.la8(),
+ "mb8" = select.mb8(),
+ "bl14" = select.bl14(),
+ "fk14" = select.fk14(),
+ "d16" = select.d16(),
+ "la16" = select.la16(),
+ "mb16" = select.mb16(),
+ "la20" = select.la20(),
+ "bl20" = select.bl20(),
+ "fk22" = select.fk22(),
+ "mb24" = select.mb24(),
+ stop("Invalid selection for wave.filter"))
+}
+
+qmf <- function(g, low2high = TRUE) {
+ L <- length(g)
+ if(low2high)
+ h <- (-1)^(0:(L - 1)) * rev(g)
+ else
+ h <- (-1)^(1:L) * rev(g)
+ return(h)
+}
+
+imodwt <- function(y){
+ ctmp <- class(y)
+ if(is.null(ctmp) || all(ctmp != "modwt"))
+ stop("argument `y' is not of class \"modwt\"")
+
+ J <- length(y) - 1
+
+ dict <- wave.filter(attributes(y)$wavelet)
+ L <- dict$length
+ storage.mode(L) <- "integer"
+ ht <- dict$hpf / sqrt(2)
+ storage.mode(ht) <- "double"
+ gt <- dict$lpf / sqrt(2)
+ storage.mode(gt) <- "double"
+
+ jj <- paste("s", J, sep="")
+ X <- y[[jj]]
+ N <- length(X)
+ storage.mode(N) <- "integer"
+ XX <- numeric(N)
+ storage.mode(XX) <- "double"
+ for(j in J:1) {
+ jj <- paste("d", j, sep="")
+ X <- C_imodwt_r(as.double(y[[jj]]), as.double(X), N, as.integer(j),
+ L, ht, gt, XX)
+ }
+ if(attr(y, "boundary") == "reflection") return(X[1:(N/2)])
+ else return(X)
+}
+
+### Internal Functions - JADE
+rjd <-function(X, eps = 1e-06, maxiter = 100, na.action = na.fail){
+ X <- na.action(X)
+ dim.X <- dim(X)
+
+ if (length(dim.X)==2) type <- "Matrix"
+ if (length(dim.X)==3) type <- "Array"
+ if ((length(dim.X) %in% c(2,3))==FALSE) stop("'X' must have two or three dimensions")
+
+ if (type == "Array")
+ {
+ if (dim.X[1] != dim.X[2]) stop("'X' must be an array with dim of the form c(p,p,k)")
+ p <- dim.X[1]
+ Xt <- aperm(X, c(1,3,2))
+ X <- matrix(Xt, ncol=p)
+ }
+
+ if (!all(sapply(X, is.numeric))) stop("'X' must be numeric")
+ X <- as.matrix(X)
+ X.data <- X
+
+ p <- dim(X)[2]
+ if (p==1) stop("'X' must be at least bivariate")
+ kp <- dim(X)[1]
+
+
+ k <- kp/p
+ if (floor(k) != ceiling(k)) stop("'X' must me a matrix of k stacked pxp matrices")
+
+ V <- diag(p)
+ encore <- TRUE
+ iter <- 0
+ while (encore==TRUE)
+ {
+ iter <- iter +1
+ encore <- FALSE
+ for (i in 1:(p-1))
+ {
+ for (j in (i+1):(p))
+ {
+ Ii <- seq(i,kp,p)
+ Ij <- seq(j,kp,p)
+
+ g1 <- X[Ii,i]-X[Ij,j]
+ g2 <- X[Ij,i]+X[Ii,j]
+
+ g <- cbind(g1,g2)
+
+ gg <- crossprod(g)
+ ton <- gg[1,1]-gg[2,2]
+ toff <- gg[1,2]+gg[2,1]
+ theta <- 0.5*atan2(toff, ton+sqrt(ton*ton+toff*toff))
+
+ cos.theta <- cos(theta)
+ sin.theta <- sin(theta)
+
+ if (abs(sin.theta)>eps)
+ {
+ encore <- TRUE
+
+ Mi <- X[Ii,]
+ Mj <- X[Ij,]
+
+ X[Ii,] <- cos.theta * Mi + sin.theta * Mj
+ X[Ij,] <- cos.theta * Mj - sin.theta * Mi
+
+ col.i <- X[,i]
+ col.j <- X[,j]
+
+ X[,i] <- cos.theta * col.i + sin.theta * col.j
+ X[,j] <- cos.theta * col.j - sin.theta * col.i
+
+ temp <- V[i,]
+ V[i,] <- cos.theta * V[i,] + sin.theta * V[j,]
+ V[j,] <- cos.theta * V[j,] - sin.theta * temp
+ }
+ }
+
+ }
+ if (iter >= maxiter) stop("maxiter reached without convergence")
+ }
+
+ recomp <- function(X,V)
+ {as.data.frame(V %*% tcrossprod(as.matrix(X), V))}
+ Z <- split(as.data.frame(X.data), rep(1:k, each=p))
+ Z2 <- sapply(Z, recomp, V=as.matrix(V), simplify=FALSE)
+ Z3 <- matrix(unlist(lapply(Z2, t)), ncol=p, byrow=TRUE)
+ if (type == "Array")
+ {
+ D <- aperm(array(t(Z3), dim = c(p,p,k)), c(2,1,3), resize = FALSE)
+ }
+ else
+ {
+ D <- Z3
+ }
+ return(list(V=t(V),D=D))
+}
+
+### Internal Functions - corpcor
+pseudoinverse = function (m, tol) {
+ msvd = fast.svd(m, tol)
+
+ if (length(msvd$d) == 0)
+ {
+ return(
+ array(0, dim(m)[2:1])
+ )
+ }
+ else
+ {
+ return(
+ msvd$v %*% (1/msvd$d * t(msvd$u))
+ )
+ }
+}
+
+fast.svd = function(m, tol) {
+ n = dim(m)[1]
+ p = dim(m)[2]
+
+ EDGE.RATIO = 2 # use standard SVD if matrix almost square
+ if (n > EDGE.RATIO*p)
+ {
+ return(psmall.svd(m,tol))
+ }
+ else if (EDGE.RATIO*n < p)
+ {
+ return(nsmall.svd(m,tol))
+ }
+ else # if p and n are approximately the same
+ {
+ return(positive.svd(m, tol))
+ }
+}
+
+psmall.svd = function(m, tol) {
+ B = crossprod(m) # pxp matrix
+ s = svd(B,nu=0) # of which svd is easy..
+
+ # determine rank of B (= rank of m)
+ if( missing(tol) )
+ tol = dim(B)[1]*max(s$d)*.Machine$double.eps
+ Positive = s$d > tol
+
+ # positive singular values of m
+ d = sqrt(s$d[Positive])
+
+ # corresponding orthogonal basis vectors
+ v = s$v[, Positive, drop=FALSE]
+ u = m %*% v %*% diag(1/d, nrow=length(d))
+
+ return(list(d=d,u=u,v=v))
+}
+
+nsmall.svd = function(m, tol) {
+ B = m %*% t(m) # nxn matrix
+ s = svd(B,nv=0) # of which svd is easy..
+
+ # determine rank of B (= rank of m)
+ if( missing(tol) )
+ tol = dim(B)[1]*max(s$d)*.Machine$double.eps
+ Positive = s$d > tol
+
+ # positive singular values of m
+ d = sqrt(s$d[Positive])
+
+ # corresponding orthogonal basis vectors
+ u = s$u[, Positive, drop=FALSE]
+ v = crossprod(m, u) %*% diag(1/d, nrow=length(d))
+
+ return(list(d=d,u=u,v=v))
+}
+
+positive.svd = function(m, tol)
+{
+ s = svd(m)
+
+ if( missing(tol) )
+ tol = max(dim(m))*max(s$d)*.Machine$double.eps
+ Positive = s$d > tol
+
+ return(list(
+ d=s$d[Positive],
+ u=s$u[, Positive, drop=FALSE],
+ v=s$v[, Positive, drop=FALSE]
+ ))
+}
+
+
+##### Internal Functions for ANCOVA
+ANCOVA_doBC <- function(Xvec, ref.idx, batch.idx, seq.idx,
+ result = c("correctedX", "corrections"),
+ method = c("lm", "rlm", "tobit"),
+ correctionFormula = formula("X ~ S * B"),
+ minBsamp = ifelse(is.null(seq.idx), 2, 4),
+ imputeVal = NULL, ...) {
+
+ result <- match.arg(result)
+ method <- match.arg(method)
+
+ if (is.null(imputeVal) & method == "tobit")
+ stop("Tobit regression requires a value for 'imputeVal'")
+
+ ## next line commented out to get rid of unused levels...
+ ## if (!is.factor(batch.idx))
+ batch.idx <- factor(batch.idx)
+ nbatches <- nlevels(batch.idx)
+ if (is.factor(seq.idx)) seq.idx <- as.numeric(levels(seq.idx))[seq.idx]
+
+ if (is.null(seq.idx) & method != "lm") {
+ warning("Using method = 'lm' since seq.idx equals NULL")
+ }
+
+ ## convert TRUE/FALSE vector to vector of numerical indices
+ if (is.logical(ref.idx)) ref.idx <- which(ref.idx)
+ Xref <- Xvec[ref.idx]
+ Bref <- batch.idx[ref.idx]
+ Sref <- seq.idx[ref.idx]
+
+ glMean <- mean(Xref, na.rm = TRUE)
+
+ ## check that at least minBsamp samples per batch are present
+ ## if less than minBsamp samples present, remove batch for correction by
+ ## setting values to NA.
+ nNonNA <- tapply(Xref, Bref, function(x) sum(!is.na(x)))
+ tooFew <- names(nNonNA)[nNonNA < minBsamp]
+ ## no batch found with enough samples...
+ if (length(tooFew) > length(levels(Bref))-2)
+ return(rep(NA, length(Xvec)))
+
+ if (is.null(seq.idx)) {
+ if (!is.null(imputeVal))
+ Xref[is.na(Xref)] <- imputeVal
+
+ Bmod <- lm(Xref ~ Bref - 1)
+ Bcorrections <- (glMean - coef(Bmod))[ batch.idx ]
+
+ switch(result,
+ correctedX = Xvec + Bcorrections,
+ Bcorrections)
+ } else {
+ ## finally plug in imputeVal for non-detects
+ if (!is.null(imputeVal))
+ Xref[is.na(Xref)] <- imputeVal
+ fitdf <- data.frame(S = Sref, B = Bref, X = Xref)
+ ## subset argument for rlm does not work correctly: the number of
+ ## levels is not diminished and as a result we get a singular
+ ## matrix... the only solution is to take out the unused levels
+ ## from the fitdf object.
+ if (length(tooFew) > 0) {
+ fitdf <- fitdf[!(fitdf$B %in% tooFew),]
+ fitdf$B <- factor(fitdf$B)
+ }
+
+ Bmods2 <- switch(method,
+ lm = lm(correctionFormula, data = fitdf),
+ rlm = MASS::rlm(correctionFormula, data = fitdf,
+ maxit = 50),
+ ### tobit = AER:::tobit(correctionFormula, data = fitdf,
+ ### left = imputeVal),
+ tobit = .crch(correctionFormula, data = fitdf,
+ left = imputeVal))
+
+ ## Now make predictions for each sample, not just the ref samples
+ ## The actual correction is the following:
+ ## ycorr = y - pred + gm
+ predictdf <- data.frame(S = seq.idx, B = batch.idx)
+ predictdf$B[predictdf$B %in% tooFew] <- NA
+ predictions <- rep(NA, length(Xvec))
+ predictions[!(predictdf$B %in% tooFew)] <-
+ predict(Bmods2, newdata = predictdf)
+
+ switch(result,
+ correctedX = Xvec + glMean - predictions,
+ glMean - predictions)
+ }
+}
+
+ANCOVA_evaluatePCA <- function(data, batch, noref.idx,
+ npc = 2, plot = FALSE,
+ batch.colors, scaleX = TRUE,
+ legend.loc = "topright",
+ legend.col = 2, ..., perBatch = TRUE) {
+ nbatches <- nlevels(batch)
+
+ noref.idx <- noref.idx
+ Xsample <- X[noref.idx,]
+ #YSample <- Y[noref.idx,]
+
+ Xsample <- Xsample[, apply(Xsample, 2, function(x) !all(is.na(x)))]
+
+ ## replace NA values with column means
+ for (i in 1:ncol(Xsample))
+ Xsample[is.na(Xsample[,i]),i] <- mean(Xsample[,i], na.rm = TRUE)
+
+ Xsample <- Xsample[, apply(Xsample, 2, sd, na.rm = TRUE) > 0]
+
+ X.PCA <- PCA(scale(Xsample))
+
+
+ Xscores <- scores.PCA(X.PCA)[, 1:npc, drop = FALSE]
+ ## a double loop is necessary to compare all batches... we
+ ## only do the top triangle.
+ batch.means <-
+ lapply(levels(YSample$Batch),
+ function(btch)
+ colMeans(Xscores[which(YSample$Batch == btch),,drop=FALSE]))
+ batch.covs <-
+ lapply(levels(YSample$Batch),
+ function(btch)
+ cov(Xscores[which(YSample$Batch == btch),,drop=FALSE]))
+ noCov.idx <- which(sapply(batch.covs, function(x) all(x < 1e-8)))
+ if ((nnoCov <- length(noCov.idx)) > 0) {
+ warning(paste("Too little information for batch correction in the following batches:\n",
+ levels(YSample$Batch)[noCov.idx],
+ "- ignoring these batches in the PCA criterion"))
+ nbatches <- nbatches - nnoCov
+ batch.covs <- batch.covs[-noCov.idx]
+ batch.means <- batch.means[-noCov.idx]
+ }
+
+ batch.dist <- matrix(0, nbatches, nbatches)
+ for (i in 2:nbatches)
+ for (j in 1:(i-1))
+ batch.dist[j, i] <- bhattacharyya.dist(batch.means[[j]],
+ batch.means[[i]],
+ batch.covs[[j]],
+ batch.covs[[i]])
+
+ if (perBatch) {
+ batch.dist + t(batch.dist)
+ } else {
+ ## Here we take the mean and not the median since one deviating
+ ## batch is already a problem.
+ mean(batch.dist[col(batch.dist) > row(batch.dist)])
+ }
+}
+
+### Internal Functions - MetNorm Package
+
+NormalizeRUVRand <- function(Y, ctl, k=NULL,lambda=NULL,plotk=TRUE){
+ output<-RUVRand(Y=Y, ctl=ctl,lambda=lambda, k=k)
+ return(structure(output, class="normdata"))
+}
+
+RUVRand <- function(Y, ctl,lambda=NULL, k=NULL,...){
+
+ Yc<-Y[, ctl]
+ svdYc <- svd(Yc)
+ fullW <- svdYc$u %*% diag(svdYc$d)
+ if(is.null(k))
+ stop('k must be entered')
+ if (!is.null(k) & is.null(lambda)){
+ optklambda<-opt(ktry=k, W=fullW,Yc=Yc)
+ lambda<-optklambda$optmat[,3]
+ } else optklambda<-NULL
+
+ W<-fullW[,1:k,drop=FALSE]
+ alpha<-solve(t(W)%*%W + lambda*diag(k), t(W) %*% Y)
+ uvcomp<-W %*% alpha
+ newY <- Y - uvcomp
+ return(list(unadjY=Y,newY=newY,UVcomp=uvcomp,W=W,alpha= alpha,opt=optklambda,
+ k=k,lambda=lambda,ctl=ctl))
+}
+
+loglik<- function (par, Y,W){
+ m <- ncol(Y)
+ n<-nrow(Y)
+ if (!is.null(W)){
+ sigma2.a<-par[1]
+ sigma2.e<-par[2]
+ if ((sigma2.a<0)|(sigma2.e<0))
+ return(1e6)
+ Sigma<-sigma2.a*(W%*%t(W))+sigma2.e*diag(m)
+ } else{
+ Sigma <- diag(m)
+ Sigma[upper.tri(Sigma, diag=TRUE)] <- par
+ Sigma <- Sigma + t(Sigma) - diag(diag(Sigma))
+ }
+ ed = eigen(Sigma, symmetric = TRUE)
+ ev = ed$values
+ if (!all(ev >= -1e-06 * abs(ev[1])))
+ return(1e6)
+ mu<-rep(0,m)
+ centeredx<-sweep(Y,2,mu,"-")
+ ssnew<- t(centeredx)%*%(centeredx)
+ if (is.null(tryCatch(solve(Sigma), error=function(e) NULL)))
+ return(1e6)
+ else
+ inv.Sigma<-solve(Sigma)
+ Sigmainvss<-inv.Sigma%*%ssnew
+ return(n*determinant(Sigma,logarithm=T)$mod+sum(diag(Sigmainvss)))
+}
+
+opt<-function(ktry,W,Yc){
+ opt<-list()
+ optmat<-matrix(NA,nrow=1,ncol=8)
+ colnames(optmat)<-c("sigma2.a","sigma2.e","nu",
+ "lower_sigma2.a","upper_sigma2.a",
+ "lower_sigma2.e","upper_sigma2.e",
+ "convergence")
+
+ opt<-optim(c(0.1,0.1),
+ loglik,
+ Y=t(Yc),
+ W=W[,1:ktry,drop=FALSE],
+ hessian=T)
+ fisher_info<-solve(opt$hessian/2)
+ se<-sqrt(diag(fisher_info))
+ upper_par1<-opt$par[1]+1.96*se[1]
+ lower_par1<-opt$par[1]-1.96*se[1]
+ upper_par2<-opt$par[2]+1.96*se[2]
+ lower_par2<-opt$par[2]-1.96*se[2]
+
+ optmat[1,]<-c(opt$par[1],
+ opt$par[2],
+ opt$par[2]/opt$par[1],
+ lower_par1, upper_par1,
+ lower_par2, upper_par2,
+ opt$convergence)
+
+ rownames(optmat)<-ktry
+ return(list(optmat=optmat, opt=opt))
+}
+
+RuvRandIter <- function(RUVRand,maxIter,wUpdate=maxIter+1, lambdaUpdate=TRUE,p=p,...){
+ Y<-RUVRand$unadjY
+ ctl<-RUVRand$ctl
+ ndim<-RUVRand$ndim
+ m <- nrow(Y)
+ n <- ncol(Y)
+
+ converged <- 0
+ iter <- 0
+ currObj <- Inf
+ cEps<-1e-6
+
+
+ W <- RUVRand$W
+ a <- RUVRand$alpha
+ lambda<-RUVRand$lambda
+ k<-RUVRand$k
+ Wa <- W %*% a
+
+ X <- matrix(0,m,p)
+ b <- matrix(0,p,n)
+ Xb <- X %*% b
+
+ while(!converged){
+ iter <- iter + 1
+
+ #print('Estimating the factor of interest')
+ XbOld <- Xb
+
+ kmres <- kmeans((Y[, -ctl] - Wa[, -ctl]),centers=p,nstart=20,...)
+ idx <- kmres$cluster
+ for(kk in 1:p){
+ X[, kk] <- cbind(as.numeric(idx==kk))
+ }
+ b[, -ctl] <- kmres$centers
+ Xb <- X %*% b
+
+ WaOld <- Wa
+ WOld <- W
+
+ if(iter / wUpdate == iter %/% wUpdate){
+
+ #print('Re-estimating W')
+
+ svdYmXb <- svd((Y - Xb))
+ fullW <- svdYmXb$u %*% diag(svdYmXb$d)
+ if (lambdaUpdate){
+ #print('Re-estimating k and lambda')
+ barplot(prcomp((Y - Xb),scale. =T)$sdev^2/
+ sum(prcomp((Y - Xb),scale. =T)$sdev^2),
+ xlim=c(0,min(dim(Y))+1),
+ names.arg =c(1:min(dim(Y))),
+ ylim=c(0,1),
+ xlab="k",
+ ylab="proportion of the variance",
+ cex.lab=1.2,cex.axis=1.2)
+
+ k<-readk()
+ W <- fullW[,c(1:k)]
+ optklambda<-opt(ktry=k,
+ W=W,
+ Yc=(Y - Xb))
+ lambda<-optklambda$optmat[,3]
+ #print(paste("lambda =" ,lambda))
+ }
+ }
+
+ #print('Estimating the unwanted variation component')
+
+
+
+ a <- solve(t(W)%*%W + lambda*diag(ncol(W)), t(W) %*% (Y - Xb))
+ Wa <- W %*% a
+
+ #print('Update done')
+
+
+ l2Err <- (norm((Y - Xb - Wa), 'F')^2)/(m*n)
+ oldObj <- currObj
+ currObj <- norm((Y - Xb - Wa), 'F')^2 +lambda*norm(a,'F')^2
+
+ dXb <- norm(Xb-XbOld,'F')/norm(Xb,'F')
+ dWa <- norm(Wa-WaOld,'F')/norm(Wa,'F')
+ if(ncol(W) != ncol(WOld)){
+ dW <- Inf}
+ else{
+ dW <- norm(W-WOld,'F')/norm(W,'F')
+ }
+ dObj <- (oldObj-currObj)/oldObj
+
+ if(iter >= maxIter || (!is.nan(max(dXb,dWa)) && max(dXb,dWa) < cEps)){
+ converged = 1
+ }
+ }
+
+ cY <- Y - Wa
+
+ return(list(unadjY=RUVRand$unadjY, newY=cY, UVcomp=Wa,
+ W=W,alpha=a,X=X,b=b,k=k,lambda=lambda,opt=RUVRand$opt,
+ ctl=RUVRand$ctl))
+}
+
+### Internal Functions - metaX package
+
+plotNorValue<-function(){
+
+ fig_cv<- "cv.pdf"
+ pdf(fig_cv,width = 6,height = 6)
+
+ p<-ggplot(data=cvStatForEachBatch,aes(x=value,fill=CV,colour=CV))+
+ facet_grid(batch~.)+
+ geom_density(alpha = 0.5)+
+ xlab(label = "CV")
+ #print(p)
+
+ p<-ggplot(data=cvStatForEachBatch,aes(x=value,fill=CV,colour=CV))+
+ facet_grid(batch~.)+
+ geom_density(alpha = 0.5)+
+ xlim(0,2)+
+ xlab(label = "CV")
+ #print(p)
+
+ dev.off()
+}
+
+myLoessFit = function(x,y,newX,span.vals=seq(0.1,1,by=0.05),log=TRUE,a=1){
+ if(log==TRUE){
+ y <- .glogfit(y,a=a)
+ }
+ #sp.obj <- smooth.spline(x,y,spar = tuneSpline(x,y,span.vals = span.vals))
+ sp.obj <- smooth.spline(x,y,cv = TRUE)
+
+ valuePredict=predict(sp.obj,newX)
+ if(log==TRUE){
+ valuePredict$y <- .glogfit(valuePredict$y,a = a,inverse = TRUE)
+ }
+ return(valuePredict$y)
+}
+
+tuneSpline = function(x,y,span.vals=seq(0.1,1,by=0.05)){
+ mae <- numeric(length(span.vals))
+
+ crossEva <- function(span,x,y) {
+
+ fun.fit <- function(x,y,span) {smooth.spline(x = x,y =y ,spar = span)}
+ fun.predict <- function(fit,x0) {predict(fit,x0)$y}
+ y.cv <- .crossval(x,y,fun.fit,fun.predict,span=span,
+ ngroup = length(x))$cv.fit
+ fltr <- !is.na(y.cv)
+ return(mean(abs(y[fltr]-y.cv[fltr])))
+ }
+ mae <- sapply(span.vals,crossEva,x=x,y=y)
+ span <- span.vals[which.min(mae)]
+ return(span)
+}
+
+.runFit1=function(id,qcData,maxOrder){
+ out <- tryCatch({
+
+ dat <- data.frame(newOrder=1:maxOrder)
+
+ piece <- qcData[qcData$ID_batch==id,]
+
+ dat$valuePredict=myLoessFit(piece$order,piece$value,dat$newOrder)
+
+ dat$ID <- piece$ID[1]
+ dat$batch <- piece$batch[1]
+ dat
+
+ },
+ error=function(e){
+ #message("Please see the file: runFit_error.rda for related data!")
+ #save(e,id,qcData,maxOrder,file="runFit_error.rda")
+ #stop("error in runFit!")
+ return(NULL)
+ },
+ warning=function(cond){
+ #message("Please see the file: runFit_warning.rda for related data!")
+ #save(cond,id,qcData,maxOrder,file="runFit_warning.rda")
+ return(NULL)
+ })
+ return(out)
+}
+
+.runFit2=function(id,qcData,maxOrder,loessSpan){
+ #out <- tryCatch({
+ dat <- data.frame(newOrder=1:maxOrder)
+
+ piece <- qcData[ qcData$ID_batch==id,]
+ dat$valuePredict=predict(smooth.spline(piece$order,
+ piece$value,
+ spar = loessSpan),
+ dat$newOrder)$y
+ dat$ID <- piece$ID[1]
+ dat$batch <- piece$batch[1]
+ dat
+ # },
+ #error=function(e){
+ #message("Please see the file: runFit_error.rda for related data!")
+ #save(e,id,qcData,maxOrder,file="runFit_error.rda")
+ # stop("error in runFit!")
+ # return(NULL)
+ #},
+ # warning=function(cond){
+ #message("Please see the file: runFit_warning.rda for related data!")
+ #save(cond,id,qcData,maxOrder,file="runFit_warning.rda")
+ # return(NULL)
+ #})
+ # return(out)
+}
+
+.glogfit=function (x, a = 1, inverse = FALSE) {
+ if (inverse) {
+ out <- 0.25 * exp(-x) * (4 * exp(2 * x) - (a * a))
+ }else{
+ out <- log10((x + sqrt(x^2 + a^2))/2)
+ }
+ return(out)
+}
+
+.imputation<-function(peaksData){
+ #require(tidyverse);
+ valueID="value"
+ #x <- peaksData %>% dplyr::select(ID,sample,!!valueID) %>%
+ # spread(sample,!!valueID)
+
+ x_tmp<-dplyr::select(peaksData,ID,sample,!!valueID)
+ x<-spread(x_tmp,sample,!!valueID)
+
+ #x<-dcast(peaksData,ID~sample,value.var = valueID)
+ row.names(x) <- x$ID
+ x$ID <- NULL
+ x[x<=0] <- NA
+
+ #message("Missing value in total: ",sum(is.na(x)))
+ if(any(is.na(peaksData$class))){
+ qcValue <- peaksData[,valueID][is.na(peaksData$class)]
+ #message("Missing value in QC sample: ",
+ # sum(qcValue<=0 | is.na(qcValue)))
+ sValue <- peaksData[,valueID][!is.na(peaksData$class)]
+ #message("Missing value in non-QC sample: ",
+ # sum(sValue<=0 | is.na(sValue)))
+ }
+ x <- .imputation_internal(x,method="knn",cpu=1)
+ #message("Missing value in total after missing value inputation: ",
+ # sum(is.na(x)))
+
+ ## maybe x has value which <=0
+ #message("<=0 value in total after missing value inputation: ",
+ # sum(x<=0))
+ x$ID <- row.names(x)
+ y <- reshape2::melt(x,id.vars = "ID",variable.name = "sample",value.name = "newValue")
+ m <- plyr::join(peaksData,y,by=c("ID","sample"))
+ m[,valueID] <- m$newValue
+ m$newValue <- NULL
+ #para@peaksData <- m
+ return(m)
+}
+
+.imputation_internal<-function(x,method="knn",negValue = TRUE,cpu=1){
+ if(cpu==0){
+ cpu <- detectCores()
+ }
+
+ inputedData <- NULL
+ colName <- names(x)
+ rowName <- row.names(x)
+ x <- as.matrix(t(x))
+ ## An expression matrix with samples in the rows, features in the columns
+ #save(x,file="x.rda")
+ #message(date(),"\tThe ratio of missing value: ",
+ # sprintf("%.4f%%",100*sum(is.na(x))/length(x)))
+ if(method == "bpca"){
+ ## Numerical matrix with (or an object coercible to such) with samples
+ ## in rows and variables as columns. Also takes ExpressionSet in which
+ ## case the transposed expression matrix is used. Can also be a data
+ ## frame in which case all numberic variables are used to fit the PCA.
+ ## Please note that this method is very time-consuming.
+ mvd <- pca(x, nPcs = 3, method = "bpca")
+ inputedData <- completeObs(mvd)
+ }else if(method == "svdImpute"){
+ ## This method is very fast.
+ mvd <- pca(x, nPcs = 3, method = "svdImpute")
+ inputedData <- completeObs(mvd)
+ }else if(method == "knn"){
+ ## An expression matrix with genes in the rows, samples in the columns
+ ## This method is very fast.
+ #require(impute)
+ mvd <- impute::impute.knn(t(x))
+ inputedData <- t(mvd$data)
+ }else if(method == "softImpute"){
+ # https://cran.r-project.org/web/packages/softImpute/vignettes/softImpute.html
+ # An m by n matrix with NAs.
+ # TODO: tune the parameters, rank.max and lambda
+ softfit <- softImpute(t(x))
+ x_new <- complete(x,softfit)
+ inputedData <- x_new
+
+ }else if(method == "rf"){
+ ## A data matrix with missing values.
+ ## The columns correspond to the variables and the rows to the
+ ## observations.
+ ## Please note that this method is very time-consuming.
+
+ if(cpu>1){
+ cat("do missForest cpu=(",cpu,") ...\n")
+ cl <- makeCluster(cpu)
+ registerDoParallel(cl)
+ # xmis: a data matrix with missing values.
+ # The columns correspond to the variables and the rows
+ # to the observations.
+ mvd <- missForest(xmis = x,parallelize = "variables")
+ #print(mvd$OOBerror)
+ inputedData <- mvd$ximp
+ stopCluster(cl)
+
+ }else{
+ cat("do missForest ...\n")
+ mvd <- missForest(xmis = x)
+ #print(mvd$OOBerror)
+ inputedData <- mvd$ximp
+ }
+
+ }else if(method == "min"){
+ ## min value / 2
+ inputedData <- apply(x,1,function(y){
+ y[is.na(y) | y<=0] <- min(y[y>0],na.rm = TRUE)/2.0
+ y})
+ inputedData <- t(inputedData)
+ }else if(method == "none"){
+ cat("No missing value imputation!\n")
+ inputedData <- x
+ }else{
+ stop("Please provide valid method for missing value inputation!")
+ }
+
+ if(method != "none"){
+
+ if(negValue & method != "min"){
+ #message("<=0: ",sum(inputedData<=0))
+ x <- inputedData
+ inputedData <- apply(x,1,function(y){
+ y[is.na(y) | y<=0] <- min(y[y>0],na.rm = TRUE)
+ y})
+ inputedData <- t(inputedData)
+
+ }
+ }
+
+ inputedData <- as.data.frame(t(inputedData))
+ row.names(inputedData) <- rowName
+ names(inputedData) <- colName
+ return(inputedData)
+}
+
+.cbindlist <- function(list) {
+ n <- length(list)
+ res <- matrix()
+ for (i in seq(n)) {
+ res <- cbind(res, list[[i]])
+ }
+ return(res)
+}
+
+.crossval<- function(x,y,theta.fit,theta.predict,...,ngroup=n){
+ call <- match.call()
+ x <- as.matrix(x)
+ n <- length(y)
+ ngroup <- trunc(ngroup)
+ if( ngroup < 2){
+ stop ("ngroup should be greater than or equal to 2")
+ }
+ if(ngroup > n){
+ stop ("ngroup should be less than or equal to the number of observations")
+ }
+
+ if(ngroup==n) {groups <- 1:n; leave.out <- 1}
+ if(ngroup<n){
+ leave.out <- trunc(n/ngroup);
+ o <- sample(1:n)
+ groups <- vector("list",ngroup)
+ for(j in 1:(ngroup-1)){
+ jj <- (1+(j-1)*leave.out)
+ groups[[j]] <- (o[jj:(jj+leave.out-1)])
+ }
+ groups[[ngroup]] <- o[(1+(ngroup-1)*leave.out):n]
+ }
+ u <- vector("list",ngroup)
+ cv.fit <- rep(NA,n)
+ for(j in 1:ngroup){
+ u <- theta.fit(x[-groups[[j]], ],y[-groups[[j]]],...)
+ cv.fit[groups[[j]]] <- theta.predict(u,x[groups[[j]],])
+
+ }
+
+ if(leave.out==1) groups <- NULL
+ return(list(cv.fit=cv.fit,
+ ngroup=ngroup,
+ leave.out=leave.out,
+ groups=groups,
+ call=call))
+}
+
+# Define Internal Functions - EigenMS
+makeLMFormula = function(eff, var_name='') {
+ # eff - effects used in contrasts
+ # var_name - for singe factor use var-name that is passed in as variable names, otherwise it has no colnmae
+ # only used for a single factor
+ if(is.factor(eff))
+ {
+ ndims = 1
+ cols1 = var_name # ftemp in EigenMS
+ }
+ else
+ {
+ ndims = dim(eff)[2]
+ cols1 = colnames(eff)
+ }
+ lhs = cols1[1]
+ lm.fm = NULL
+ # check if can have a list if only have 1 factor...
+
+ params = paste('contrasts=list(', cols1[1], '=contr.sum', sep=)
+
+ if (ndims > 1) { # removed ndims[2] here, now ndims holds only 1 dimention...
+ for (ii in 2:length(cols1))
+ {
+ lhs = paste(lhs, "+", cols1[ii]) # bl="contr.sum",
+ params = paste(params, ',', cols1[ii], '=contr.sum', sep='')
+ }
+ }
+ params = paste(params,")")
+ lm.formula = as.formula(paste('~', lhs))
+ lm.fm$lm.formula = lm.formula
+ lm.fm$lm.params = params
+ return(lm.fm)
+}
+
+eig_norm1 = function(m, treatment, prot.info, write_to_file=''){
+ # Identify significant eigentrends, allow the user to adjust the number (with causion! if desired)
+ # before normalizing with eig_norm2
+ #
+ # Input:
+ # m: An m x n (peptides x samples) matrix of expression data, log-transformed!
+ # peptide and protein identifiers come from the get.ProtInfo()
+ # treatment: either a single factor indicating the treatment group of each sample i.e. [1 1 1 1 2 2 2 2...]
+ # or a frame of factors: treatment= data.frame(cbind(data.frame(Group), data.frame(Time))
+ # prot.info: 2+ colum data frame, pepID, prID columns IN THAT ORDER.
+ # IMPORTANT: pepIDs must be unique identifiers and will be used as Row Names
+ # If normalizing non-proteomics data, create a column such as: paste('ID_',seq(1:num_rows), sep='')
+ # Same can be dome for ProtIDs, these are not used for normalization but are kept for future analyses
+ # write_to_file='' - if a string is passed in, 'complete' peptides (peptides with NO missing observations)
+ # will be written to that file name
+ #
+ # Output: list of:
+ # m, treatment, prot.info, grp - initial parameters returned for futre reference
+ # my.svd - matrices produced by SVD
+ # pres - matrix of peptides that can be normalized, i.e. have enough observations for ANOVA,
+ # n.treatment - number of factors passed in
+ # n.u.treatment - number of unique treatment facotr combinations, eg:
+ # Factor A: a a a a c c c c
+ # Factor B: 1 1 2 2 1 1 2 2
+ # then: n.treatment = 2; n.u.treatment = 4
+ # h.c - bias trends
+ # present - names/IDs of peptides on pres
+ # complete - complete peptides, no missing values, these were used to compute SVD
+ # toplot1 - trends automatically produced, if one wanted to plot at later time.
+ # Tk - scores for each bias trend
+ # ncompl - number of complete peptides with no missing observations
+ #print("Data dimentions: ")
+ #print(dim(m))
+ # check if treatment is a 'factor' vs data.frame', i.e. single vs multiple factors
+ if(class(treatment) == "factor") { # TRUE if one factor
+ n.treatment = 1 # length(treatment)
+ n.u.treatment = length(unique(treatment))[1]
+ } else { # data.frame
+ n.treatment = dim(treatment)[2]
+ n.u.treatment = dim(unique(treatment))[1] # all possible tretment combinations
+ }
+ # convert m to a matrix from data.frame
+ m = as.matrix(m) # no loss of information
+
+ # filter out min.missing, here just counting missing values
+ # if 1+ treatment completely missing, cannot do ANOVA, thus cannot preserve grp diff.
+ # IMPORTANT: we create a composite grp = number of unique combinations of all groups, only for
+ # 'nested' groups for single layer group is left as it is
+ grpFactors = treatment # temporary var, leftover from old times...
+
+ nGrpFactors = n.treatment # length(colnames(treatment)) # not good: dim(grpFactors)
+ if(nGrpFactors > 1) { # got nested factors
+ ugrps = unique(grpFactors)
+ udims = dim(ugrps)
+ grp = NULL
+ for(ii in 1:udims[1]) {
+ pos = grpFactors[,1] == ugrps[ii,1] # set to initial value
+ for(jj in 2:udims[2]) {
+ pos = pos & grpFactors[,jj] == ugrps[ii,jj]
+ }
+ grp[pos] = rep(ii, sum(pos))
+ }
+ grp = as.factor(grp)
+ } else {
+ grp = treatment
+ }
+ nobs = array(NA, c(nrow(m), length(unique(grp)))) # noobs = number of observations
+
+ #print('Treatmenet groups:')
+ #print(grp)
+
+ for(ii in 1:nrow(m)) {
+ #print(ii)
+ for(jj in 1:length(unique(grp))) {
+ #print(jj)
+ nobs[ii,jj] = sum(!is.na(m[ii, grp==unique(grp)[jj]])) # total number of groups num(g1) * num(g2) * ...
+ }
+ }
+ # now 'remove' peptides with missing groups
+ present.min = apply(nobs, 1, min) # number present in each group
+ ii = present.min == 0 # 1+ obs present in ALL of the groups
+ nmiss = sum(present.min == 0) # not used, one value of how many peptides have 1+ grp missing completely
+ pmiss = rbind(m[ii,]) # these have 1+ grp missing !!!!
+ # rownames must be UNIQUE, if have possible duplicates: use 'ii' ?
+ rownames(pmiss) = prot.info[ii,1] # set rownames,
+
+ # create matrix for peptides with enough observations for ANOVA
+ # 'present' are names of the peptides (pepID) and 'pres' are abundances
+ # NOTE: ! negates the proteins, so we get ones that have 1+ obs in each group
+ present = prot.info[which(!prot.info[,1] %in% rownames(pmiss)), ] # rownames OK
+ # pres = m[which(!rownames(m) %in% rownames(pmiss)), ]
+ pres = m[which(!prot.info[,1] %in% rownames(pmiss)), ] # is this OK?
+ rownames(pres) = prot.info[which(!prot.info[,1] %in% rownames(pmiss)),1]
+
+ #print('Selecting complete peptides')
+ # Should issue an error message if we have NO complete peptides.
+ # select only 'complete' peptides, no missing values
+ nobs = array(NA, nrow(pres)) # reassign noobs to dims of 'present'
+ numiter = nrow(pres)
+ for (ii in 1:numiter) {
+ # if(ii %% 100 == 0) { print(ii) }
+ nobs[ii] = sum(!is.na(pres[ii,]))
+ }
+
+ iii = nobs == ncol(pres)
+ complete = rbind(pres[iii,])
+
+ # write out a file of complete peptides if file name is passed in
+ #if(write_to_file != '') {
+ # write.table(complete, file = write_to_file, append = FALSE,
+ # quote = FALSE, sep = "\t",
+ # eol = "\n", na = "NaN", dec = ".", row.names = TRUE,
+ # col.names = TRUE, qmethod = c("escape", "double"))
+ #}
+
+ # compute bias with 'complete' matrix and residuals from 'present'
+ # calculate eigenpeptides for 'complete' data only
+ # if have only 1 group, we do not need to preserve group differernces, everything is the same group, ex: QC samples
+ # contrasts will fail if have only 1 group, thus have else
+ if(n.u.treatment > 1) {
+ #print('Got 2+ treatment grps')
+ # check to see if we have multiple factors
+ grpdim = dim(treatment)
+
+ lm.fm = makeLMFormula(treatment, 'TREAT') # using general function that can accomodate for 1+ number of factors
+ TREAT = treatment
+ TREAT = data.frame(treatment) # temp var to work if we got only 1 treatment vector.
+ if(class(treatment) == "factor") {
+ colnames(TREAT) = "TREAT"
+ } else {
+ colnames(TREAT) = colnames(treatment)
+ }
+ attach(TREAT)
+
+ mod.c = model.matrix(lm.fm$lm.formula, data=TREAT, eval(parse(text=lm.fm$lm.params)))
+ Y.c = as.matrix(complete)
+ options(warn = -1)
+
+ # use lm() to get residuals
+ formula1 = paste('t(Y.c)~', as.character(lm.fm$lm.formula)[2], sep = '')
+ TREAT = treatment
+ fit_lmAll = lm(eval(parse(text=formula1)))
+ R.c = residuals(fit_lmAll) # Oct 2 messing with residuals...
+ } else { # 1 group only, set residuals to original matrix
+ #print('Got 1 treatment grp')
+ mod.c = as.numeric(t(treatment))
+ R.c = t(as.matrix(complete)) # needs to be transposed to match the matrix returned from lm
+ TREAT = treatment
+ }
+
+ #print('Computing SVD, estimating Eigentrends...') # let user know what is going on
+ # residuals are centered around 0, here center samples not peptides/metabolites
+ # centering is basic normalization
+
+ R.c_center = scale(R.c, center = TRUE, scale = FALSE) # t(scale(t(R.c), center = TRUE, scale = FALSE))
+ my.svd = svd(R.c_center) # can use wrapper below to chek if SVD has a problem...
+ temp = my.svd$u
+ my.svd$u = my.svd$v
+ my.svd$v = temp
+
+ #identify number of eigenvalues that account for a significant amount of residual variation
+ numcompletepep = dim(complete)[1] # save to return to the user as part of the return list
+ # this is important info for publications
+ # tell users how many peptides/metabolites the trends are based on
+ # can also be determined by doing dim(return_value_fromEIg_norm1$pres)
+
+ #print(paste('Number of treatments: ', n.u.treatment))
+ h.c = sva.id(complete, treatment, n.u.treatment, lm.fm=lm.fm,seed=1234)$n.sv
+ #print(paste("Number of significant eigenpeptides/trends", h.c) )
+
+ # show RAW trends
+ # center each peptide around zero (subtract its mean across samples)
+ complete_center = scale(t(complete), center = TRUE, scale = FALSE)
+ #print('Preparing to plot...')
+
+ n.u.treatment
+ toplot1 = svd(complete_center) # scales above
+ temp = toplot1$u
+ toplot1$u = toplot1$v
+ toplot1$v = temp
+
+ #par(mfcol=c(3,2))
+ #par(mar = c(2,2,2,2))
+
+ #plot.eigentrends(toplot1, "Raw Data")
+ #plot.eigentrends(my.svd, "Residual Data")
+
+ d = my.svd$d; ss = d^2;
+ Tk = signif(ss/sum(ss)* 100, 2)
+
+ retval = list(m=m, treatment=treatment, my.svd=my.svd,
+ pres=pres, n.treatment=n.treatment, n.u.treatment=n.u.treatment,
+ h.c=h.c, present=present, prot.info=prot.info,
+ complete=complete, toplot1=toplot1, Tk=Tk, ncompl=numcompletepep,
+ grp=grp)
+ return(retval)
+}
+
+eig_norm2 = function(rv) {
+ # UNPUT:
+ # rv - return value from the eig_norm1
+ # if user wants to change the number of bias trends that will be eliminated h.c in rv should
+ # be updates to the desired number
+ #
+ # OUTPUT:
+ # normalized - matrix of normalized abundances with 2 columns of protein and peptdie names
+ # norm_m - matrix of normalized abundances, no extra columns
+ # eigentrends - found in raw data, bias trendsup to h.c
+ # rescrange - rescaling range for the addition of the while noise to avoid overfitting
+ # norm.svd - trends in normalized data, if one wanted to plot at later time.
+ # exPeps - excluded peptides - excluded due to exception in fitting a linear model
+
+ m = rv$pres # yuliya: use pres matrix, as we cannot deal with m anyways, need to narrow it down to 'complete' peptides
+ treatment = rv$treatment
+ my.svd = rv$my.svd
+ pres = rv$pres
+ n.treatment = rv$n.treatment
+ n.u.treatment = rv$n.u.treatment
+ numFact = dim(rv$treatment)[2]
+ #print(paste('Unique number of treatment combinations:', n.u.treatment) )
+ h.c = rv$h.c
+ present = rv$present
+ toplot1 = rv$toplot1
+ # vector of indicators of peptides that threw exeptions
+ exPeps = vector(mode = "numeric", length = nrow(pres))
+
+ #print("Normalizing...")
+ treatment = data.frame(treatment) # does this need to be done?
+ if(n.u.treatment > 1) {
+ lm.fm = makeLMFormula(treatment, 'ftemp')
+ mtmp = model.matrix(lm.fm$lm.formula, data=treatment, eval(parse(text=lm.fm$lm.params))) #contrasts=list(bl="contr.sum", it="contr.sum",Pi="contr.sum", tp="contr.sum"))
+ } else { # have 1 treatment group
+ mtmp = treatment # as.numeric(t(treatment))
+ }
+ # above needed to know how many values will get back for some matrices
+ # create some variables:
+ betahat = matrix(NA,nrow=dim(mtmp)[2],ncol=nrow(pres))
+ newR = array(NA, c(nrow(pres), ncol(pres))) #, n.treatment))
+ norm_m = array(NA, c(nrow(pres), ncol(pres))) # , n.treatment))
+ numsamp = dim(pres)[2]
+ numpep = dim(pres)[1]
+ betahat_n = matrix(NA,nrow=dim(mtmp)[2],ncol=nrow(pres))
+ rm(mtmp)
+
+ V0 = my.svd$v[,1:h.c,drop=F] # residual eigenpeptides
+
+ if(n.u.treatment == 1) { # got 1 treatment group
+ for (ii in 1:nrow(pres)) {
+ #if(ii%%250 == 0) { print(paste('Processing peptide ',ii)) }
+ pep = pres[ii, ]
+ pos = !is.na(pep)
+ peptemp = as.matrix(pep[pos]) # take only the observed values
+ resm = rep(NA, numsamp)
+ resm[pos] = as.numeric(pep[pos])
+ bias = array(NA, numsamp)
+ bias[pos] = resm[pos] %*% V0[pos,] %*% t(V0[pos,])
+ norm_m[ii, ] = as.numeric(pep - bias)
+ }
+
+ } else { # got 2+ treatment groups
+ for (ii in 1:nrow(pres)) {
+ if(ii %% 100 == 0) { #print(paste('Processing peptide ',ii))
+ }
+ pep = pres[ii, ]
+ pos = !is.na(pep)
+ peptemp = as.matrix(pep[pos]) # take only the observed values, may not be needed in R? but this works
+ ftemp = treatment[pos,]
+ ftemp = data.frame(ftemp)
+ #### use try, not entirely sure if need for modt, need it for solve lm?!
+ options(warn = -1)
+ lm.fm = makeLMFormula(ftemp, 'ftemp') # using general function that can accomodate for 1+ number of factors
+ modt = try(model.matrix(lm.fm$lm.formula, data=ftemp, eval(parse(text=lm.fm$lm.params))), silent=TRUE)
+ options(warn = 0)
+
+ if(!inherits(modt, "try-error")) { # do nothing if could not make model matrix
+ options(warn = -1)
+ # if we are able to solve this, we are able to estimate bias
+ bhat = try(solve(t(modt) %*% modt) %*% t(modt) %*% peptemp)
+ options(warn = 0)
+ if(!inherits(bhat, "try-error")) {
+ betahat[,ii] = bhat
+ ceffects = modt %*% bhat # these are the group effects, from estimated coefficients betahat
+
+ resm = rep(NA, numsamp) # really a vector only, not m
+ resm[pos] = as.numeric(pep[pos] - ceffects)
+ bias = array(NA, numsamp)
+ bias[pos] = resm[pos] %*% V0[pos,] %*% t(V0[pos,])
+ norm_m[ii, ] = as.numeric(pep - bias)
+
+ # yuliya: but newR should be computed on Normalized data
+ resm_n = rep(NA, numsamp)
+ bhat_n = solve(t(modt) %*% modt) %*% t(modt) %*% norm_m[ii, pos]
+ betahat_n[,ii] = bhat_n
+ ceffects_n = modt %*% bhat_n
+ resm_n[pos] = norm_m[ii,pos] - ceffects
+ newR[ii, ] = resm_n
+ } else {
+ #print(paste('got exception 2 at peptide:', ii, 'should not get here...'))
+ exPeps[ii] = 2 # should not get 2 here ever...
+ }
+ } else {
+ #print(paste('got exception at peptide:', ii))
+ exPeps[ii] = 1 # keep track of peptides that threw exeptions, check why...
+ }
+ }
+ } # end else - got 2+ treatment groups
+
+ #####################################################################################
+ # rescaling has been eliminated form the code after discussion that bias
+ # adds variation and we remove it, so no need to rescale after as we removed what was introduced
+ y_rescaled = norm_m # for 1 group normalization only, we do not rescale
+ # add column names to y-rescaled, now X1, X2,...
+ colnames(y_rescaled) = colnames(pres) # these have same number of cols
+ rownames(y_rescaled) = rownames(pres)
+ y_resc = data.frame(present, y_rescaled)
+ rownames(y_resc) = rownames(pres) # rownames(rv$normalized)
+ final = y_resc # row names are assumed to be UNIQUE, peptide IDs are unique
+
+ # rows with all observations present
+ complete_all = y_rescaled[rowSums(is.na(y_rescaled))==0,,drop=F]
+
+ # x11() # make R open new figure window
+ #par(mfcol=c(3,2))
+ #par(mar = c(2,2,2,2))
+ # center each peptide around zero (subtract its mean across samples)
+ # note: we are not changing matrix itself, only centerig what we pass to svd
+ complete_all_center = t(scale(t(complete_all), center = TRUE, scale = FALSE))
+ toplot3 = svd(complete_all_center)
+ #plot.eigentrends(toplot1, "Raw Data")
+ #plot.eigentrends(toplot3, "Normalized Data")
+
+ #print("Done with normalization!!!")
+ colnames(V0) = paste("Trend", 1:ncol(V0), sep="_")
+
+ maxrange = NULL # no rescaling # data.matrix(maxrange)
+ return(list(normalized=final, norm_m=y_rescaled, eigentrends=V0, rescrange=maxrange,
+ norm.svd=toplot3, exPeps=exPeps))
+} # end function eig_norm2
+
+sva.id = function(dat, treatment, n.u.treatment, lm.fm, B=500, sv.sig=0.05, seed=NULL) {
+ # Executes Surrogate Variable Analysis
+ # Input:
+ # dat: A m peptides/genes by n samples matrix of expression data
+ # mod: A model matrix for the terms included in the analysis
+ # n.u.treatment - 0 or 1, if we are normalizing data with NO groups or some groups, QC vs samples
+ # B: The number of null iterations to perform
+ # sv.sig: The significance cutoff for the surrogate variables
+ # seed: A seed value for reproducible results
+ # Output
+ # n.sv: Number of significant surrogate variables.
+ # id: An indicator of the significant surrogate variables
+ # B: number of permutation to do
+ # sv.sig: significance level for surrogate variables
+ #print("Number of complete peptides (and samples) used in SVD")
+ # print(dim(dat))
+
+
+ if(!is.null(seed)) { set.seed(seed) }
+ warn = NULL
+ n = ncol(dat)
+ m = nrow(dat)
+
+ # ncomp = length(as.numeric(n.u.treatment))
+ ncomp = n.u.treatment # JULY 2013: as.numeric(n.u.treatment)
+ #print(paste("Number of treatment groups (in svd.id): ", ncomp))
+ # should be true for either case and can be used later
+
+ if(ncomp > 1) { #
+ formula1 = paste('t(dat)~', as.character(lm.fm$lm.formula)[2], sep = '')
+ fit_lmAll = lm(eval(parse(text=formula1)))
+ res = t(residuals(fit_lmAll))
+ } else {
+ res = dat
+ }
+ # centering was not done before...
+ # center each peptide around zero (subtract its mean across samples)
+ # note: we are not changing matrix itself, only centerig what we pass to svd
+ res_center = t(scale(t(res), center = TRUE, scale = FALSE))
+
+ uu = svd(t(res_center)) # NEED a WRAPPER for t(). the diag is min(n, m)
+ temp = uu$u
+ uu$u = uu$v
+ uu$v = temp
+
+
+ # yuliya: Sept 2014: can I get around without using H??
+ # ndf = min(n, m) - ceiling(sum(diag(H)))
+ # dstat = uu$d[1:ndf]^2/sum(uu$d[1:ndf]^2)
+ # dstat0 = matrix(0,nrow=B,ncol=ndf)
+ # s0 = diag(uu$d) # no need for diag here, should investigate why this is a vector already...
+ s0 = uu$d
+ s0 = s0^2
+ dstat = s0/sum(s0) # this did not have 'diag' in it in Tom's code...
+ ndf = length(dstat) # sticking to Tom's variable name
+ # print(paste('length(dstat) = ndf = ', ndf))
+ dstat0 = matrix(0,nrow=B,ncol=ndf) # num samples (?)
+
+ #print("Starting Bootstrap.....")
+ # this is the Bootstrap procedure that determines the number of significant eigertrends...
+ for(ii in 1:B){
+ #if(ii %% 50 == 0) { print(paste('Iteration ', ii)) }
+ res0 = t(apply(res, 1, sample, replace=FALSE)) # regression
+ # yuliya: not sure if this is needed at all
+ # not needed for 1 group normalizaiton
+ ##### res0 = res0 - t(H %*% t(res0))
+ # yuliya: Sept 3, 2014: REMOVED above line. Do not think this needs to be done..
+ # center each peptide around zero (subtract its mean across samples)
+ # note: we are not changing matrix itself, only centerig what we pass to svd
+ res0_center = t(scale(t(res0), center = TRUE, scale = FALSE))
+ uu0 = svd(res0_center)
+ temp = uu0$u # why did tom do this??
+ uu0$u = uu0$v
+ uu0$v = temp
+
+ ss0 = uu0$d # no need for diag....
+ ss0 = ss0^2
+ dstat0[ii,] = ss0 / sum(ss0) # Tk0 in Matlab
+ }
+
+ # yuliya: check p-values here, Tom had mean value...
+ psv = rep(1,n)
+ for(ii in 1:ndf){
+ # psv[ii] = mean(dstat0[,ii] >= dstat[ii])
+ # should this be compared to a MEAN? Should this be dstat0[ii,] ?
+ posGreater = dstat0[,ii] > dstat[ii]
+ psv[ii] = sum(posGreater) / B
+ }
+
+ # p-values for peptides have to be in monotonically increasing order,
+ # set equal to previous one if not the case
+ for(ii in 2:ndf){
+ if(psv[(ii-1)] > psv[ii]) {
+ # psv[ii] = max(psv[(ii-1)],psv[ii])
+ psv[ii] = psv[(ii-1)]
+ }
+ }
+ nsv = sum(psv <= sv.sig)
+ # tom - this should be at least 1
+ # nsv = min(sum(psv <= sv.sig), 1, na.rm=T)
+ return(list(n.sv = nsv,p.sv=psv))
+}
+
+plot.eigentrends = function(svdr, title1){
+ v = svdr$v
+ d = svdr$d
+ ss = d^2
+ Tk = signif(ss/sum(ss)* 100, 2)
+
+ titles = paste("Trend ", 1:3, " (", Tk[1:3], "%)", sep = "")
+ do.text = function(j) mtext(titles[j], cex=0.7, padj=-0.7, adj=1)
+ range.y = range(as.numeric(v[,1:3]), na.rm=T)
+
+ toplot1_1 = as.numeric(v[,1])
+ toplot1_2 = as.numeric(v[,2])
+ toplot1_3 = as.numeric(v[,3])
+
+ plot(c(1:length(toplot1_1)), toplot1_1, type='b', ann=F, ylim=range.y)
+ do.text(1)
+ abline(h=0, lty=3)
+ title(title1, cex.main = 1.2, font.main= 1, col.main= "purple", ylab=NULL)
+ plot(c(1:length(toplot1_2)), toplot1_2, type='b', ann=F, ylim=range.y)
+ do.text(2)
+ abline(h=0, lty=3)
+ plot(c(1:length(toplot1_3)), toplot1_3, type='b', ann=F, ylim=range.y)
+ do.text(3)
+ abline(h=0, lty=3)
+ return(Tk)
+}
+
+# Define Internal Functions - CCMN
+standardsFit <- function(object, factors, ncomp=NULL, lg=TRUE, fitfunc=lm, standards) {
+ X <- factors
+
+ if(lg)
+ lsta <- log10(t(object[standards,]))
+ else
+ lsta <- t(object[standards,])
+
+ clsta <- scale(lsta)
+ means <- attr(clsta, "scaled:center")
+ sds <- attr(clsta, "scaled:scale")
+ pfit <- fitfunc(clsta~-1+I(X))
+ zbzhate <- cbind(resid(pfit))
+ np <- max(1, min(nrow(zbzhate) - 1, ncol(zbzhate) - 1, ncomp))
+ #hp <- library(help="pcaMethods")$info[[1]]
+ #ver <- gsub("Version:", "", hp[grep("Version:", hp)])
+ #if(compareVersion(ver, "1.26.0") == 1)
+ # pc <- pca(zbzhate, nPcs=np, verbose=FALSE)
+ #else
+ withCallingHandlers(pc <- pcaMethods::pca(zbzhate, nPcs=np, method="nipals", verbose=FALSE),
+ warning=pcaMuffle
+ )
+
+ r2 <- NULL -> q2
+ best <- min(np, ncomp)
+ #if(is.null(ncomp) ) {
+ # withCallingHandlers(q2 <- Q2(pc, zbzhate, nruncv=1), warning=pcaMuffle)
+ # r2 <- pc@R2
+ # best <- which.max(q2)
+ #}
+
+ list(fit=list(fit=pfit,pc=pc), ncomp=best, means=means, sds=sds, q2=q2, r2=r2)
+}
+
+standardsPred <- function(model, newdata, factors, lg=TRUE, standards) {
+ X <- factors
+ object <- newdata
+ if(lg) {
+ lsta <- log10(t(object[standards,]))
+ } else {
+ lsta <- t(object[standards,])
+ }
+
+ slsta <- scale(lsta, center=model$means, scale=model$sds)
+
+ ## correct for G
+ cslstaE <- slsta - predict(model$fit$fit, data.frame(I(X)))
+
+ ## correct for E, get Tz
+ predict(model$fit$pc, cslstaE, pcs=model$ncomp)$scores
+}
+
+pcaMuffle <- function(w) {
+ if(any(grepl("Precision for components", w),
+ grepl("Validation incomplete", w)))
+ invokeRestart( "muffleWarning" )}
+
+# Define Internal Functions - RUV-2
+naiveRandRUV <- function(Y, cIdx, nu.coeff=1e-3, k=min(nrow(Y), length(cIdx)), tol=1e-6){
+
+ ## W is the square root of the empirical covariance on the control
+ ## genes.
+
+ svdYc <- svd(Y[, cIdx, drop=FALSE])
+ k.max <- sum(svdYc$d^2/svdYc$d[1]^2 > tol)
+ if(k > k.max){
+ warning(sprintf('k larger than the rank of Y[, cIdx]. Using k=%d instead', k.max))
+ k <- k.max
+ }
+ W <- svdYc$u[, 1:k, drop=FALSE] %*% diag(svdYc$d[1:k], nrow=k)
+
+ ## Regularization heuristic: nu is a fraction of the largest eigenvalue of WW'
+
+ nu <- nu.coeff*svdYc$d[1]^2 #/ (length(cIdx)+1)
+
+ ## Naive correction: ridge regression of Y against W
+
+ nY <- Y - W %*% solve(t(W)%*%W + nu*diag(k), t(W) %*% Y)
+
+ return(nY)
+}
+
+# Define Internal Functions - 'crch' Package
+crch <- function(formula, data, subset, na.action, weights, offset,
+ link.scale = c("log", "identity", "quadratic"),
+ dist = c("gaussian", "logistic", "student"), df = NULL,
+ left = -Inf, right = Inf, truncated = FALSE, type = c("ml", "crps"),
+ control = crch.control(...), model = TRUE, x = FALSE, y = FALSE, ...){
+ ## call
+ cl <- match.call()
+ if(missing(data)) data <- environment(formula)
+ mf <- match.call(expand.dots = FALSE)
+ m <- match(c("formula", "data", "subset", "na.action", "weights", "offset"), names(mf), 0L)
+ mf <- mf[c(1L, m)]
+ mf$drop.unused.levels <- TRUE
+
+ ## formula
+ oformula <- as.formula(formula)
+ formula <- as.Formula(formula)
+ if(length(formula)[2L] < 2L) {
+ formula <- as.Formula(formula(formula), ~ 1)
+ simple_formula <- TRUE
+ } else {
+ if(length(formula)[2L] > 2L) {
+ formula <- Formula(formula(formula, rhs = 1:2))
+ warning("formula must not have more than two RHS parts")
+ }
+ simple_formula <- FALSE
+ }
+ mf$formula <- formula
+ ## evaluate model.frame
+ mf[[1L]] <- as.name("model.frame")
+ mf <- eval(mf, parent.frame())
+ ## extract terms, model matrix, response
+ mt <- terms(formula, data = data, dot = control$dot)
+ mtX <- terms(formula, data = data, rhs = 1L, dot = control$dot)
+ mtZ <- delete.response(terms(formula, data = data, rhs = 2L, dot = control$dot))
+ Y <- model.response(mf, "numeric")
+ X <- model.matrix(mtX, mf)
+ Z <- model.matrix(mtZ, mf)
+
+ ## obtain correct subset of predvars/dataClasses to terms
+ .add_predvars_and_dataClasses <- function(terms, model.frame) {
+ ## original terms
+ rval <- terms
+ ## terms from model.frame
+ nval <- if(inherits(model.frame, "terms")) model.frame else terms(model.frame, dot = control$dot)
+
+ ## associated variable labels
+ ovar <- sapply(as.list(attr(rval, "variables")), deparse)[-1]
+ nvar <- sapply(as.list(attr(nval, "variables")), deparse)[-1]
+ if(!all(ovar %in% nvar)) stop(
+ paste("The following terms variables are not part of the model.frame:",
+ paste(ovar[!(ovar %in% nvar)], collapse = ", ")))
+ ix <- match(ovar, nvar)
+
+ ## subset predvars
+ if(!is.null(attr(rval, "predvars")))
+ warning("terms already had 'predvars' attribute, now replaced")
+ attr(rval, "predvars") <- attr(nval, "predvars")[1L + c(0L, ix)]
+
+ ## subset dataClasses
+ if(!is.null(attr(rval, "dataClasses")))
+ warning("terms already had 'dataClasses' attribute, now replaced")
+ attr(rval, "dataClasses") <- attr(nval, "dataClasses")[ix]
+
+ return(rval)
+ }
+ mt <- .add_predvars_and_dataClasses(mt, mf)
+ mtX <- .add_predvars_and_dataClasses(mtX, mf)
+ mtZ <- .add_predvars_and_dataClasses(mtZ, mf)
+
+ ## link
+ if(is.character(link.scale)) link.scale <- match.arg(link.scale)
+
+
+ ## distribution
+ if(is.character(dist)) dist <- match.arg(dist)
+
+ ## type
+ if(is.character(type)) type <- match.arg(type)
+
+ ## sanity checks
+ if(length(Y) < 1) stop("empty model")
+ if(identical(dist, "student")) {
+ if(!is.null(df) && df <= 0) stop("'df' must be positive")
+ if(!is.null(df) && !is.finite(df)) dist <- "gaussian"
+ }
+
+ ## convenience variables
+ n <- length(Y)
+
+
+ ## weights
+ weights <- model.weights(mf)
+ if(is.null(weights)) weights <- 1
+ if(length(weights) == 1) weights <- rep.int(weights, n)
+ weights <- as.vector(weights)
+ names(weights) <- rownames(mf)
+
+ ## offsets
+ expand_offset <- function(offset) {
+ if(is.null(offset)) offset <- 0
+ if(length(offset) == 1) offset <- rep.int(offset, n)
+ as.vector(offset)
+ }
+ ## in location part of formula
+ offsetX <- expand_offset(model.offset(model.part(formula, data = mf, rhs = 1L, terms = TRUE)))
+ ## in scale part of formula
+ offsetZ <- expand_offset(model.offset(model.part(formula, data = mf, rhs = 2L, terms = TRUE)))
+ ## in offset argument (used for location)
+ if(!is.null(cl$offset)) offsetX <- offsetX + expand_offset(mf[, "(offset)"])
+ ## collect
+ offset <- list(location = offsetX, scale = offsetZ)
+
+
+ ## call the actual workhorse: crch.fit() or crch.boost.fit()
+ fit <- control$fit
+ control$fit <- NULL
+ rval <- do.call(fit, list(x = X, y = Y, z = Z, left = left, right = right,
+ link.scale = link.scale, dist = dist, df = df, weights = weights,
+ offset = offset, control = control, truncated = truncated, type = type))
+
+
+ ## further model information
+ rval$call <- if(length(control$call)) control$call else cl
+ rval$formula <- oformula
+ rval$terms <- list(location = mtX, scale = mtZ, full = mt)
+ rval$levels <- list(location = .getXlevels(mtX, mf),
+ scale = .getXlevels(mtZ, mf), full = .getXlevels(mt, mf))
+ rval$contrasts <- list(location = attr(X, "contrasts"), scale = attr(Z, "contrasts"))
+ if(model) rval$model <- mf
+ if(y) rval$y <- Y
+ if(x) rval$x <- list(location = X, scale = Z)
+
+ return(rval)
+}
+
+crch.control <- function(method = "BFGS", maxit = NULL,
+ hessian = NULL, trace = FALSE, start = NULL, dot = "separate",
+ lower = -Inf, upper = Inf, ...){
+ if(method == "boosting") {
+ if(is.null(maxit)) maxit <- 100
+ rval <- crch.boost(dot = dot, start = start, maxit = maxit, ...)
+ } else {
+ if(is.null(maxit)) maxit <- 5000
+ rval <- list(method = method, maxit = maxit, hessian = hessian, trace = trace,
+ start = start, dot = dot,lower=lower,upper=upper, fit = "crch.fit")
+ rval <- c(rval, list(...))
+ if(!is.null(rval$fnscale)) warning("fnscale must not be modified")
+ rval$fnscale <- 1
+ if(is.null(rval$reltol)) rval$reltol <- .Machine$double.eps^(1/1.2)
+ }
+ rval
+}
+
+crch.fit <- function(x, z, y, left, right, truncated = FALSE,
+ dist = "gaussian", df = NULL, link.scale = "log", type = "ml",
+ weights = NULL, offset = NULL, control = .crch.control()) {
+ ## response and regressor matrix
+ n <- NROW(x)
+ k <- NCOL(x)
+ if(is.null(weights)) weights <- rep.int(1, n)
+ nobs <- sum(weights > 0)
+ dfest <- identical(dist, "student") & is.null(df)
+ if(is.null(offset)) offset <- rep.int(0, n)
+ if(!is.list(offset)) offset <- list(location = offset, scale = rep.int(0, n))
+ if(is.null(z)) {
+ q <- 1L
+ z <- matrix(1, ncol = q, nrow = n)
+ colnames(z) <- "(Intercept)"
+ rownames(z) <- rownames(x)
+ } else {
+ q <- NCOL(z)
+ if(q < 1L) stop("scale regression needs to have at least one parameter")
+ }
+
+ ## control parameters
+ ocontrol <- control
+ method <- control$method
+ hessian <- control$hessian
+ start <- control$start
+ lower <- control$lower
+ upper <- control$upper
+ control$method <- control$hessian <- control$start <- control$lower <- control$upper <- NULL
+
+ if(is.character(dist)){
+ if(type == "ml") {
+ ## distribution functions for maximum likelihood
+ if(truncated) {
+ ddist2 <- switch(dist,
+ "student" = dtt, "gaussian" = dtnorm, "logistic" = dtlogis)
+ sdist2 <- switch(dist,
+ "student" = stt, "gaussian" = stnorm, "logistic" = stlogis)
+ hdist2 <- switch(dist,
+ "student" = htt, "gaussian" = htnorm, "logistic" = htlogis)
+ } else {
+ ddist2 <- switch(dist,
+ "student" = dct, "gaussian" = dcnorm, "logistic" = dclogis)
+ sdist2 <- switch(dist,
+ "student" = sct, "gaussian" = scnorm, "logistic" = sclogis)
+ hdist2 <- switch(dist,
+ "student" = hct, "gaussian" = hcnorm, "logistic" = hclogis)
+ }
+ ddist <- if(dist == "student") ddist2 else function(..., df) ddist2(...)
+ sdist <- if(dist == "student") sdist2 else function(..., df) sdist2(...)
+ hdist <- if(dist == "student") hdist2 else function(..., df) hdist2(...)
+ } else {
+ stopifnot(requireNamespace("scoringRules"))
+ ## loss function for CRPS minimization
+ if(truncated) {
+ ddist2 <- switch(dist,
+ "student" = crps_tt,
+ "gaussian" = crps_tnorm,
+ "logistic" = crps_tlogis)
+ sdist2 <- switch(dist,
+ "student" = gradcrps_tt,
+ "gaussian" = gradcrps_tnorm,
+ "logistic" = gradcrps_tlogis)
+ hdist2 <- switch(dist,
+ "student" = hesscrps_tt,
+ "gaussian" = hesscrps_tnorm,
+ "logistic" = hesscrps_tlogis)
+ } else {
+ ddist2 <- switch(dist,
+ "student" = crps_ct,
+ "gaussian" = crps_cnorm,
+ "logistic" = crps_clogis)
+ sdist2 <- switch(dist,
+ "student" = gradcrps_ct,
+ "gaussian" = gradcrps_cnorm,
+ "logistic" = gradcrps_clogis)
+ hdist2 <- switch(dist,
+ "student" = hesscrps_ct,
+ "gaussian" = hesscrps_cnorm,
+ "logistic" = hesscrps_clogis)
+ }
+ ddist3 <- if(dist == "student") ddist2 else function(..., df) ddist2(...)
+ sdist3 <- if(dist == "student") sdist2 else function(..., df) sdist2(...)
+ hdist3 <- if(dist == "student") hdist2 else function(..., df) hdist2(...)
+ ddist <- function(x, location, scale, df, left = -Inf, right = Inf, log = TRUE) {
+ - ddist3(x, location = location, scale = scale, lower = left,
+ upper = right, df = df)
+ }
+ sdist <- function(x, location, scale, df, left = -Inf, right = Inf) {
+ rval <- - sdist3(x, df = df, location = location, scale = scale,
+ lower = left, upper = right)
+ colnames(rval) <- c("dmu", "dsigma")
+ rval
+ }
+ hdist <- function(x, location, scale, df, left = -Inf, right = Inf, which) {
+ rval <- - hdist3(x, df = df, location = location, scale = scale,
+ lower = left, upper = right)
+ colnames(rval) <- c("d2mu", "d2sigma", "dmu.dsigma", "dsigma.dmu")
+ rval
+ }
+
+ ## density function required for log-likelihood
+ if(truncated) {
+ ddist4 <- switch(dist,
+ "student" = dtt, "gaussian" = dtnorm, "logistic" = dtlogis)
+ } else {
+ ddist4 <- switch(dist,
+ "student" = dct, "gaussian" = dcnorm, "logistic" = dclogis)
+ }
+ lldist <- if(dist == "student") ddist4 else function(..., df) ddist4(...)
+ }
+ } else {
+ ## for user defined distribution (requires list with ddist, sdist (optional)
+ ## and hdist (optional), ddist, sdist, and hdist must be functions with
+ ## arguments x, location, sd, df, left, right, and log)
+ ddist <- dist$ddist
+ sdist <- if(is.null(dist$sdist)) NULL else dist$sdist
+ if(is.null(dist$hdist)) {
+ if(!is.null(hessian))
+ if(hessian == FALSE) warning("no analytic hessian available. Hessian is set to TRUE and numerical Hessian from optim is employed")
+ hessian <- TRUE
+ } else hdist <- dist$hdist
+ }
+
+ ## analytic or numeric Hessian
+ if(is.null(hessian)) {
+ hessian <- dfest
+ returnvcov <- TRUE # vcov is not computed when hessian == FALSE
+ } else {
+ returnvcov <- hessian
+ }
+
+ ## link
+ if(is.character(link.scale)) {
+ linkstr <- link.scale
+ if(linkstr != "quadratic") {
+ linkobj <- make.link(linkstr)
+ linkobj$dmu.deta <- switch(linkstr,
+ "identity" = function(eta) rep.int(0, length(eta)),
+ "log" = function(eta) pmax(exp(eta), .Machine$double.eps))
+ } else {
+ linkobj <- structure(list(
+ linkfun = function(mu) mu^2,
+ linkinv = function(eta) sqrt(eta),
+ mu.eta = function(eta) 1/2/sqrt(eta),
+ dmu.deta = function(eta) -1/4/sqrt(eta^3),
+ valideta = function(eta) TRUE,
+ name = "quadratic"
+ ), class = "link-glm")
+ }
+ } else {
+ linkobj <- link.scale
+ linkstr <- link.scale$name
+ if(is.null(linkobj$dmu.deta) & !hessian) {
+ warning("link.scale needs to provide dmu.deta component for analytical Hessian. Numerical Hessian is employed.")
+ hessian <- TRUE
+ }
+ }
+ linkfun <- linkobj$linkfun
+ linkinv <- linkobj$linkinv
+ mu.eta <- linkobj$mu.eta
+ dmu.deta <- linkobj$dmu.deta
+
+
+ ## starting values
+ if(is.null(start)) {
+ auxreg <- lm.wfit(x, y, w = weights, offset = offset[[1L]])
+ beta <- auxreg$coefficients
+ gamma <- c(linkfun(sqrt(sum(weights * auxreg$residuals^2)/
+ auxreg$df.residual)), rep(0, ncol(z) - 1))
+ start <- if(dfest) c(beta, gamma, log10(10)) else c(beta, gamma)
+ }
+ if(is.list(start)) start <- do.call("c", start)
+ if(length(start) > k + q + dfest) {
+ warning(paste("too many entries in start! only first", k + q + dfest, "entries are considered"))
+ start <- start[1: (k + q + dfest)]
+ }
+ ## various fitted quantities (parameters, linear predictors, etc.)
+ fitfun <- function(par) {
+ beta <- par[seq.int(length.out = k)]
+ gamma <- par[seq.int(length.out = q) + k]
+ delta <- if(dfest) tail(par, 1) else NULL
+ mu <- drop(x %*% beta) + offset[[1L]]
+ zgamma <- drop(z %*% gamma) + offset[[2L]]
+ sigma <- linkinv(zgamma)
+ df <- if(dfest) exp(delta) else df
+ list(
+ beta = beta,
+ gamma = gamma,
+ delta = delta,
+ mu = mu,
+ zgamma = zgamma,
+ sigma = sigma,
+ df = df
+ )
+ }
+ ## objective function
+ loglikfun <- function(par) {
+ fit <- fitfun(par)
+ ll <- with(fit,
+ ddist(y, mu, sigma, df = df, left = left, right = right, log = TRUE))
+ if(any(!is.finite(ll))) NaN else -sum(weights * ll)
+ }
+ ## functions to evaluate gradients and hessian
+ if(dfest | is.null(sdist)) {
+ gradfun <- NULL
+ } else {
+ gradfun <- function(par, type = "gradient") {
+ fit <- fitfun(par)
+ grad <- with(fit,
+ sdist(y, mu, sigma, df = df, left = left, right = right))
+ grad <- cbind(grad[,1]*x, grad[,2] * mu.eta(fit$zgamma) * z)
+ return(-colSums(weights * grad))
+ }
+ hessfun <- function(par) {
+ fit <- fitfun(par)
+ hess <- with(fit, hdist(y, mu, sigma, left = left, right = right,
+ df = df, which = c("mu", "sigma", "mu.sigma", "sigma.mu")))
+ grad <- with(fit, sdist(y, mu, sigma, left = left, right = right,
+ df = df))[,"dsigma"]
+ hess[, "d2sigma"] <- hess[, "d2sigma"]*mu.eta(fit$zgamma)^2 + grad*dmu.deta(fit$zgamma)
+ hess[, "dmu.dsigma"] <- hess[, "dsigma.dmu"] <- hess[, "dmu.dsigma"]*mu.eta(fit$zgamma)
+ hess <- weights*hess
+ hessmu <- crossprod(hess[,"d2mu"]*x, x)
+ hessmusigma <- crossprod(hess[,"dmu.dsigma"]*x, z)
+ hesssigmamu <- crossprod(hess[,"dsigma.dmu"]*z, x)
+ hesssigma <- crossprod(hess[,"d2sigma"]*z, z)
+ -cbind(rbind(hessmu, hesssigmamu), rbind(hessmusigma, hesssigma))
+ }
+ }
+ opt <- suppressWarnings(optim(par = start, fn = loglikfun, gr = gradfun,
+ method = method, hessian = hessian, control = control,lower=lower,upper=upper))
+ if(opt$convergence > 0) {
+ converged <- FALSE
+ warning("optimization failed to converge")
+ } else {
+ converged <- TRUE
+ }
+ par <- opt$par
+ fit <- fitfun(par)
+ beta <- fit$beta
+ gamma <- fit$gamma
+ delta <- fit$delta
+ mu <- fit$mu
+ sigma <- fit$sigma
+ vcov <- if(returnvcov) {
+ if (hessian) solve(as.matrix(opt$hessian))
+ else solve(hessfun(par))
+ } else matrix(NA, k+q+dfest, n+k+dfest)
+ df <- if(dfest) exp(delta) else df
+ if(type == "crps") {
+ ll <- sum(lldist(y, mu, sigma, left, right, log = TRUE, df = df))
+ crps <- opt$value/n
+ } else {
+ ll <- -opt$value
+ crps <- NULL
+ }
+
+ names(beta) <- colnames(x)
+ names(gamma) <- colnames(z)
+ if (returnvcov) {
+ colnames(vcov) <- rownames(vcov) <- c(
+ colnames(x),
+ paste("(scale)", colnames(z), sep = "_"),
+ if(dfest) "(Log(df))")
+ }
+
+ rval <- list(
+ coefficients = list(location = beta, scale = gamma, df = delta),
+ df = df,
+ residuals = y - mu,
+ fitted.values = list(location = mu, scale = sigma),
+ dist = dist,
+ cens = list(left = left, right = right),
+ optim = opt,
+ method = method,
+ type = type,
+ control = ocontrol,
+ start = start,
+ weights = if(identical(as.vector(weights), rep.int(1, n))) NULL else weights,
+ offset = list(location = if(identical(offset[[1L]], rep.int(0, n))) NULL else
+ offset[[1L]],
+ scale = if(identical(offset[[2L]], rep.int(0, n))) NULL else offset[[2L]]),
+ n = n,
+ nobs = nobs,
+ loglik = ll,
+ crps = crps,
+ vcov = vcov,
+ link = list(scale = linkobj),
+ truncated = truncated,
+ converged = converged,
+ iterations = as.vector(tail(na.omit(opt$counts), 1))
+ )
+
+ class(rval) <- "crch"
+ return(rval)
+}
+
+# Define Inernal Function - "spread" (tidyr package)
+spread <- function(data, key, value, fill = NA, convert = FALSE,
+ drop = TRUE, sep = NULL) {
+ key_var <- tidyselect::vars_pull(names(data), !! dplyr::enquo(key))
+ value_var <- tidyselect::vars_pull(names(data), !! dplyr::enquo(value))
+
+ col <- data[key_var]
+ col_id <- plyr::id(col, drop = drop)
+ col_labels <- split_labels(col, col_id, drop = drop)
+
+ rows <- data[setdiff(names(data), c(key_var, value_var))]
+ if (ncol(rows) == 0 && nrow(rows) > 0) {
+ # Special case when there's only one row
+ row_id <- structure(1L, n = 1L)
+ row_labels <- as.data.frame(matrix(nrow = 1, ncol = 0))
+ } else {
+ row_id <- plyr::id(rows, drop = drop)
+ row_labels <- split_labels(rows, row_id, drop = drop)
+ rownames(row_labels) <- NULL
+ }
+
+ overall <- plyr::id(list(col_id, row_id), drop = FALSE)
+ n <- attr(overall, "n")
+ # Check that each output value occurs in unique location
+ if (anyDuplicated(overall)) {
+ groups <- split(seq_along(overall), overall)
+ groups <- groups[map_int(groups, length) > 1]
+
+ shared <- sum(map_int(groups, length))
+
+ str <- map_chr(groups, function(x) paste0(x, collapse = ", "))
+ rows <- paste0(paste0("* ", str, "\n"), collapse = "")
+ abort(glue(
+ "Each row of output must be identified by a unique combination of keys.",
+ "\nKeys are shared for {shared} rows:",
+ "\n{rows}"
+ ))
+ }
+
+ # Add in missing values, if necessary
+ if (length(overall) < n) {
+ overall <- match(seq_len(n), overall, nomatch = NA)
+ } else {
+ overall <- order(overall)
+ }
+
+ value <- data[[value_var]]
+ ordered <- value[overall]
+ if (!is.na(fill)) {
+ ordered[is.na(ordered)] <- fill
+ }
+
+ if (convert && !is_character(ordered)) {
+ ordered <- as.character(ordered)
+ }
+ dim(ordered) <- c(attr(row_id, "n"), attr(col_id, "n"))
+ colnames(ordered) <- enc2utf8(col_names(col_labels, sep = sep))
+
+ ordered <- as_tibble_matrix(ordered)
+
+ if (convert) {
+ ordered[] <- map(ordered, type.convert, as.is = TRUE)
+ }
+
+ out <- append_df(row_labels, ordered)
+ reconstruct_tibble(data, out, c(key_var, value_var))
+}
+
+col_names <- function(x, sep = NULL) {
+ names <- as.character(x[[1]])
+
+ if (is.null(sep)) {
+ if (length(names) == 0) {
+ # ifelse will return logical()
+ character()
+ } else {
+ ifelse(is.na(names), "<NA>", names) # replace original are_na with is.na()
+ }
+ } else {
+ paste(names(x)[[1]], names, sep = sep)
+ }
+}
+
+as_tibble_matrix <- function(x) {
+ # getS3method() only available in R >= 3.3
+ get("as_tibble.matrix", asNamespace("tibble"), mode = "function")(x)
+}
+
+split_labels <- function(df, id, drop = TRUE) {
+ if (length(df) == 0) {
+ return(df)
+ }
+
+ if (drop) {
+ representative <- match(sort(unique(id)), id)
+ out <- df[representative, , drop = FALSE]
+ rownames(out) <- NULL
+ out
+ } else {
+ unique_values <- map(df, ulevels)
+ rev(expand.grid(rev(unique_values), stringsAsFactors = FALSE))
+ }
+}
+
+ulevels <- function(x) {
+ if (is.factor(x)) {
+ orig_levs <- levels(x)
+ x <- addNA(x, ifany = TRUE)
+ levs <- levels(x)
+ factor(levs, levels = orig_levs, ordered = is.ordered(x), exclude = NULL)
+ } else if (is.list(x)) {
+ unique(x)
+ } else {
+ sort(unique(x), na.last = TRUE)
+ }
+}
+
+append_df <- function(x, y, after = length(x), remove = FALSE) {
+ if (is.character(after)) {
+ after <- match(after, dplyr::tbl_vars(x))
+ } else if (!is.integer(after)) {
+ stop("`after` must be character or integer", call. = FALSE)
+ }
+
+ # Replace duplicated variables
+ x_vars <- setdiff(names(x), names(y))
+ if (remove) {
+ x_vars <- setdiff(x_vars, names(x)[[after]])
+ after <- after - 1L
+ }
+
+ y <- append(x[x_vars], y, after = after)
+ structure(y, class = class(x), row.names = .row_names_info(x, 0L))
+}
+
+reconstruct_tibble <- function(input, output, ungrouped_vars = character()) {
+ if (inherits(input, "grouped_df")) {
+ old_groups <- dplyr::group_vars(input)
+ new_groups <- intersect(setdiff(old_groups, ungrouped_vars), names(output))
+ dplyr::grouped_df(output, new_groups)
+ } else if (inherits(input, "tbl_df")) {
+ # Assume name repair carried out elsewhere
+ as_tibble(output, .name_repair = "minimal")
+ } else {
+ output
+ }
+}
+
+#### Internal Function - RUVSeq Package
+RUVs<-function(x, cIdx, k, scIdx, round=TRUE, epsilon=1, tolerance=1e-8, isLog=FALSE) {
+
+ if(!isLog && !all(.isWholeNumber(x))) {
+ warning(paste0("The expression matrix does not contain counts.\n",
+ "Please, pass a matrix of counts (not logged) or set isLog to TRUE to skip the log transformation"))
+ }
+
+ if(isLog) {
+ Y <- t(x)
+ } else {
+ Y <- t(log10(x+epsilon))
+ }
+
+ scIdx <- scIdx[rowSums(scIdx > 0) >= 2, , drop = FALSE]
+ Yctls <- matrix(0, prod(dim(scIdx)), ncol(Y))
+ m <- nrow(Y)
+ n <- ncol(Y)
+ c <- 0
+ for (ii in 1:nrow(scIdx)) {
+ for (jj in 1:(ncol(scIdx))) {
+ if (scIdx[ii, jj] == -1)
+ next
+ c <- c + 1
+ Yctls[c, ] <- Y[scIdx[ii, jj], , drop = FALSE] -
+ colMeans(Y[scIdx[ii, (scIdx[ii, ] > 0)], , drop = FALSE])
+ }
+ }
+ Yctls <- Yctls[rowSums(Yctls) != 0, ]
+ Y <- rbind(Y, Yctls)
+ sctl <- (m + 1):(m + nrow(Yctls))
+ svdRes <- svd(Y[sctl, ], nu = 0, nv = k)
+ k <- min(k, max(which(svdRes$d > tolerance)))
+ a <- diag(as.vector(svdRes$d[1:k]), ncol=k, nrow=k) %*% t(as.matrix(svdRes$v[, 1:k]))
+ colnames(a) <- colnames(Y)
+ W <- Y[, cIdx] %*% t(solve(a[, cIdx, drop = FALSE] %*% t(a[, cIdx, drop = FALSE]), a[, cIdx, drop = FALSE]))
+ Wa <- W %*% a
+ correctedY <- Y[1:m, ] - W[1:m, ] %*% a
+
+ if(!isLog && all(.isWholeNumber(x))) {
+ if(round) {
+ correctedY <- round(exp(correctedY) - epsilon)
+ correctedY[correctedY<0] <- 0
+ } else {
+ correctedY <- exp(correctedY) - epsilon
+ }
+ }
+
+ W <- as.matrix(W[1:m,])
+ colnames(W) <- paste("W", seq(1, ncol(W)), sep="_")
+ return(list(W = W, normalizedCounts = t(correctedY)))
+}
+
+RUVr<-function(x, cIdx, k, residuals, center=TRUE, round=TRUE, epsilon=1, tolerance=1e-8, isLog=FALSE) {
+
+ Y <- t(log10(x+epsilon))
+
+ if(center) {
+ E <- apply(residuals, 1, function(x) scale(x, center=TRUE, scale=FALSE))
+ } else {
+ E <- t(residuals)
+ }
+ m <- nrow(Y)
+ n <- ncol(Y)
+ svdWa <- svd(E[, cIdx])
+ k <- min(k, max(which(svdWa$d > tolerance)))
+ W <- svdWa$u[, (1:k), drop = FALSE]
+ alpha <- solve(t(W) %*% W) %*% t(W) %*% Y
+ correctedY <- Y - W %*% alpha
+ if(!isLog && all(.isWholeNumber(x))) {
+ if(round) {
+ correctedY <- round(exp(correctedY) - epsilon)
+ correctedY[correctedY<0] <- 0
+ } else {
+ correctedY <- exp(correctedY) - epsilon
+ }
+ }
+ colnames(W) <- paste("W", seq(1, ncol(W)), sep="_")
+ return(list(W = W, normalizedCounts = t(correctedY)))
+}
+
+RUVg<-function(x, cIdx, k, drop=0, center=TRUE, round=TRUE, epsilon=1, tolerance=1e-8, isLog=FALSE) {
+
+ if(!isLog && !all(.isWholeNumber(x))) {
+ warning(paste0("The expression matrix does not contain counts.\n",
+ "Please, pass a matrix of counts (not logged) or set isLog to TRUE to skip the log transformation"))
+ }
+
+ if(isLog) {
+ Y <- t(x)
+ } else {
+ Y <- t(log10(x+epsilon))
+ }
+
+ if (center) {
+ Ycenter <- apply(Y, 2, function(x) scale(x, center = TRUE, scale=FALSE))
+ } else {
+ Ycenter <- Y
+ }
+ if (drop >= k) {
+ stop("'drop' must be less than 'k'.")
+ }
+ m <- nrow(Y)
+ n <- ncol(Y)
+ svdWa <- svd(Ycenter[, cIdx])
+ first <- 1 + drop
+ k <- min(k, max(which(svdWa$d > tolerance)))
+ W <- svdWa$u[, (first:k), drop = FALSE]
+ alpha <- solve(t(W) %*% W) %*% t(W) %*% Y
+ correctedY <- Y - W %*% alpha
+ if(!isLog && all(.isWholeNumber(x))) {
+ if(round) {
+ correctedY <- round(exp(correctedY) - epsilon)
+ correctedY[correctedY<0] <- 0
+ } else {
+ correctedY <- exp(correctedY) - epsilon
+ }
+ }
+ colnames(W) <- paste("W", seq(1, ncol(W)), sep="_")
+ return(list(W = W, normalizedCounts = t(correctedY)))
+}
+
+.isWholeNumber <- function(x, tol = .Machine$double.eps^0.5) {
+ !is.na(x) & abs(x - round(x)) < tol
+}
+
+residuals.DGEGLM <- function(object, type=c("deviance", "pearson"), ...) {
+ y <- as.matrix(object$counts)
+ mu <- as.matrix(object$fitted.values)
+ theta <- 1/object$dispersion
+ if(is.null(object$weights)) {
+ wts <- rep(1, ncol(object$counts))
+ } else {
+ wts <- as.matrix(object$weights)
+ }
+ type <- match.arg(type)
+ ymut <- cbind(y, mu, theta)
+
+ res <- t(apply(ymut, 1, function(x) {
+ yy <- as.vector(x[1:ncol(y)])
+ mm <- as.vector(x[(ncol(y)+1):(ncol(y)+ncol(mu))])
+ t <- x[length(x)]
+ if(type=="deviance") {
+ if(t==Inf) {
+ d.res <- sqrt(pmax((poisson()$dev.resids)(yy, mm, wts), 0))
+ } else {
+ d.res <- sqrt(pmax((negative.binomial(theta=t)$dev.resids)(yy, pmax(mm, 1e-8), wts), 0))
+ }
+ return(ifelse(yy > mm, d.res, -d.res))
+ } else if(type=="pearson") {
+ if(t==Inf) {
+ return((yy - mm) * sqrt(wts) / pmax(sqrt(poisson()$variance(mm)), 1))
+ } else {
+ return((yy - mm) * sqrt(wts) / pmax(sqrt(negative.binomial(theta=t)$variance(mm)), 1))
+ }
+ }
+ }))
+ return(res)
+}
+
+### Internal Function - MASS package
+negative.binomial <- function(theta = stop("'theta' must be specified"), link = "log") {
+ linktemp <- substitute(link)
+ if (!is.character(linktemp)) linktemp <- deparse(linktemp)
+ if (linktemp %in% c("log", "identity", "sqrt"))
+ stats <- make.link(linktemp)
+ else if (is.character(link)) {
+ stats <- make.link(link)
+ linktemp <- link
+ } else {
+ ## what else shall we allow? At least objects of class link-glm.
+ if(inherits(link, "link-glm")) {
+ stats <- link
+ if(!is.null(stats$name)) linktemp <- stats$name
+ } else
+ stop(gettextf("\"%s\" link not available for negative binomial family; available links are \"identity\", \"log\" and \"sqrt\"", linktemp))
+ }
+ .Theta <- theta ## avoid codetools warnings
+ env <- new.env(parent=.GlobalEnv)
+ assign(".Theta", theta, envir=env)
+ variance <- function(mu)
+ mu + mu^2/.Theta
+ validmu <- function(mu)
+ all(mu > 0)
+ dev.resids <- function(y, mu, wt)
+ 2 * wt * (y * log(pmax(1, y)/mu) - (y + .Theta) *
+ log((y + .Theta)/ (mu + .Theta)))
+ aic <- function(y, n, mu, wt, dev) {
+ term <- (y + .Theta) * log(mu + .Theta) - y * log(mu) +
+ lgamma(y + 1) - .Theta * log(.Theta) + lgamma(.Theta) - lgamma(.Theta+y)
+ 2 * sum(term * wt)
+ }
+ initialize <- expression({
+ if (any(y < 0))
+ stop("negative values not allowed for the negative binomial family")
+ n <- rep(1, nobs)
+ mustart <- y + (y == 0)/6
+ })
+ simfun <- function(object, nsim) {
+ ftd <- fitted(object)
+ rnegbin(nsim * length(ftd), ftd, .Theta)
+ }
+ environment(variance) <- environment(validmu) <-
+ environment(dev.resids) <- environment(aic) <-
+ environment(simfun) <- env
+ famname <- paste("Negative Binomial(", format(round(theta, 4)), ")",
+ sep = "")
+ structure(list(family = famname, link = linktemp, linkfun = stats$linkfun,
+ linkinv = stats$linkinv, variance = variance,
+ dev.resids = dev.resids, aic = aic, mu.eta = stats$mu.eta,
+ initialize = initialize, validmu = validmu,
+ valideta = stats$valideta, simulate = simfun),
+ class = "family")
+}
+
+### Internal Function - Vegan Package
+decorana <- function (veg, iweigh = 0, iresc = 4, ira = 0, mk = 26, short = 0,
+ before = NULL, after = NULL) {
+ Const1 <- 1e-10
+ Const2 <- 5
+ Const3 <- 1e-11
+ veg <- as.matrix(veg)
+ aidot <- rowSums(veg)
+ if (any(aidot <= 0))
+ stop("all row sums must be >0 in the community matrix: remove empty sites")
+ if (any(veg < 0))
+ stop("'decorana' cannot handle negative data entries")
+ adotj <- colSums(veg)
+ if (any(adotj <= 0))
+ warning("some species were removed because they were missing in the data")
+ if (mk < 10)
+ mk <- 10
+ if (mk > 46)
+ mk <- 46
+ if (ira)
+ iresc <- 0
+ if (!is.null(before)) {
+ if (is.unsorted(before))
+ stop("'before' must be sorted")
+ if (length(before) != length(after))
+ stop("'before' and 'after' must have same lengths")
+ for (i in seq_len(nrow(veg))) {
+ tmp <- veg[i, ] > 0
+ veg[i, tmp] <- approx(before, after, veg[i, tmp],
+ rule = 2)$y
+ }
+ }
+ if (iweigh) {
+ veg <- downweight(veg, Const2)
+ aidot <- rowSums(veg)
+ adotj <- colSums(veg)
+ }
+ v <- attr(veg, "v")
+ v.fraction <- attr(veg, "fraction")
+ adotj[adotj < Const3] <- Const3
+ CA <- .Call(C_do_decorana, veg, ira, iresc, short, mk, as.double(aidot),
+ as.double(adotj))
+ if (ira)
+ dnames <- paste("RA", 1:4, sep = "")
+ else dnames <- paste("DCA", 1:4, sep = "")
+ dimnames(CA$rproj) <- list(rownames(veg), dnames)
+ dimnames(CA$cproj) <- list(colnames(veg), dnames)
+ names(CA$evals) <- dnames
+ origin <- apply(CA$rproj, 2, weighted.mean, aidot)
+ if (ira) {
+ evals.decorana <- NULL
+ }
+ else {
+ evals.decorana <- CA$evals
+ var.r <- diag(cov.wt(CA$rproj, aidot, method = "ML")$cov)
+ var.c <- diag(cov.wt(CA$cproj, adotj, method = "ML")$cov)
+ CA$evals <- var.r/var.c
+ if (any(ze <- evals.decorana <= 0))
+ CA$evals[ze] <- 0
+ }
+ additems <- list(evals.decorana = evals.decorana, origin = origin,
+ v = v, fraction = v.fraction, iweigh = iweigh,
+ before = before, after = after,
+ call = match.call())
+ CA <- c(CA, additems)
+ class(CA) <- "decorana" # c() strips class
+ CA
+}
+
+# New .readDataTable2 Function
+.readDataTable2<-function(filePath){
+
+ dat <- try(data.table::fread(filePath, header=T, check.names=FALSE, blank.lines.skip=TRUE, data.table=FALSE),silent=T);
+
+ if(class(dat) == "try-error" || any(dim(dat) == 0)){
+ print("Using slower file reader ...");
+ formatStr <- substr(filePath, nchar(filePath)-2, nchar(filePath))
+ if(formatStr == "txt"){
+ dat <- try(read.table(filePath, header=TRUE, comment.char = "", check.names=F, as.is=T),silent=T);
+ }else{ # note, read.csv is more than read.table with sep=","
+ dat <- try(read.csv(filePath, header=TRUE, comment.char = "", check.names=F, as.is=T),silent=T);
+ }
+ }
+ return(dat);
+}
+
+## Tem Functions
+.readDataTable <- function(fileName){
+
+ dat <- tryCatch(
+ data.table::fread(fileName, header=TRUE, check.names=FALSE, blank.lines.skip=TRUE, data.table=FALSE),
+ error=function(e){
+ print(e);
+ return(.my.slowreaders(fileName));
+ },
+ warning=function(w){
+ print(w);
+ return(.my.slowreaders(fileName));
+ });
+
+ if(any(dim(dat) == 0)){
+ dat <- .my.slowreaders(fileName);
+ }
+ return(dat);
+}
+.get.mSet <- function(mSetObj=NA){
+ if(.on.public.web){
+ return(mSet)
+ }else{
+ return(mSetObj);
+ }
+}
+.set.mSet <- function(mSetObj=NA){
+ if(.on.public.web){
+ mSet <<- mSetObj;
+ return (1);
+ }
+ return(mSetObj);
+}
+
+
+##############################################
+##############################################
+########## Utilities for web-server ##########
+##############################################
+##############################################
+
+GetAllBatchNames <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(is.null(mSetObj$dataSet$batch)){
+ return(0);
+ }
+ names(mSetObj$dataSet$batch);
+}
+
+ResetBatchData <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$dataSet$batch <- mSetObj$dataSet$batch.cls <- NULL;
+ return(.set.mSet(mSetObj));
+}
+
+#'Create semitransparant colors
+#'@description Create semitransparant colors for a given class label
+#'@param cls Input class labels
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'
+
+CreateSemiTransColors <- function(cls){
+
+ # note, the first color (red) is for QC
+ col.nms <- rainbow(length(levels(cls)));
+
+ # convert to semi-transparent
+ semi.nms <- ToSemiTransParent(col.nms);
+
+ # now expand to the one-to-one match to cls element
+ col.vec <- vector(mode="character", length=length(cls));
+ for (i in 1:length(levels(cls))){
+ lv <- levels(cls)[i];
+ col.vec[cls==lv] <- semi.nms[i];
+ }
+ return(col.vec);
+}
+
+# convert rgb color i.e. "#00FF00FF" to semi transparent
+ToSemiTransParent <- function (col.nms, alpha=0.5){
+ rgb.mat <- t(col2rgb(col.nms));
+ rgb(rgb.mat/255, alpha=alpha);
+}
+
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/biomarker_utils.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/biomarker_utils.R
new file mode 100755
index 0000000000000000000000000000000000000000..b61bbdb666c156d8cee9723d6f323409702f1423
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/biomarker_utils.R
@@ -0,0 +1,3092 @@
+### Miscellaneous tasks for subsetting and training
+### Subset data, train, rank
+### Jeff Xia \email{jeff.xia@mcgill.ca}
+### McGill University, Canada
+### License: GNU GPL (>= 2)
+
+#'Numbers for subset selection
+#'@description Return a series of number for subsets selection
+#'@param feat.len Input the feature length
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+GetFeatureNumbers <- function(feat.len){
+ if(feat.len > 100){
+ nFeatures <- c(5, 10, 15, 25, 50, 100);
+ }else if(feat.len > 50){
+ nFeatures <- c(3, 5, 10, 20, round(feat.len/2), feat.len);
+ }else if(feat.len > 20){
+ nFeatures <- c(2, 3, 5, 10, 20, feat.len);
+ }else if(feat.len > 10){
+ nFeatures <- c(2, 3, 5, 7, 10, feat.len);
+ }else if(feat.len > 1){
+ nFeatures <- sort(sample(2:feat.len));
+ }else{
+ print("Feature number is less than 2!")
+ return();
+ }
+ nFeatures;
+}
+
+#'Make random partitions
+#'@description Make random partitions, returns matrices indicating
+#'whether the observation is in train/test for each run
+#'note: try to get a balanced sampling for each group (classification)
+#'or each quantile (regression). This is very useful for unbalanced data
+#'@param y Input the data
+#'@param propTraining By default set to 2/3
+#'@param nRuns By default set to 30
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+GetTrainTestSplitMat <- function(y, propTraining = 2/3, nRuns = 30){
+
+ nTotalSample <- length(y);
+
+ smallestClass <- names(sort(table(y)))[1];
+ nSmallest <- sum(y == smallestClass);
+
+ nSmallestTrain <- round(propTraining * nSmallest);
+ nBiggestTrain <- nSmallestTrain;
+
+ nSmallestTest <- nSmallest - nSmallestTrain;
+ nBiggestTest <- nTotalSample - (nSmallestTest + nSmallestTrain + nBiggestTrain);
+
+ # sanity check for very large number of samples
+ # for each run max 600 - 400 train, 200 test
+ big.samples <- FALSE;
+ if(nSmallestTrain > 400){
+ big.samples <- TRUE;
+ nSmallestTrain <- nBiggestTrain <- 400;
+ nSmallestTest <- nBiggestTest <- 200;
+ }
+
+ # split up in smallest class indices and biggest class indices
+ smallestIndices <- which(y == smallestClass)
+ biggestIndices <- seq(along = y)[-smallestIndices]
+
+ nTrainingSample <- nSmallestTrain + nBiggestTrain;
+ nTestSample <- nSmallestTest + nBiggestTest;
+
+ trainingSampleAllRuns <- matrix(0, nrow = nRuns, ncol = nTrainingSample)
+ testSampleAllRuns <- matrix(0, nrow = nRuns, ncol = nTestSample);
+
+ for (irun in 1:nRuns) {
+ sampleSmallestTrain <- sample(smallestIndices, nSmallestTrain);
+ sampleBiggestTrain <- sample(biggestIndices, nBiggestTrain);
+ trainingSampleRun <- c(sampleSmallestTrain, sampleBiggestTrain);
+ indicesTrainingSample <- rep(FALSE, length = nTotalSample);
+ indicesTrainingSample[trainingSampleRun] <- TRUE;
+ trainingSampleAllRuns[irun, ] <- which(indicesTrainingSample);
+ if(big.samples){
+ testSampleAllRuns[irun, ] <- sample(which(!indicesTrainingSample), 200);
+ }else{
+ testSampleAllRuns[irun, ] <- which(!indicesTrainingSample);
+ }
+ }
+
+ # return the results
+ list(
+ training.mat = trainingSampleAllRuns,
+ testing.mat = testSampleAllRuns
+ );
+}
+
+#'To choose from two groups
+#'@description Choose two groups (when more than two groups uploaded)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param grps Input the groups
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+SetCurrentGroups <- function(mSetObj=NA, grps){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(length(levels(mSetObj$dataSet$cls.all))>2){
+ grp.nms <- strsplit(grps, " vs. ")[[1]];
+ # now extract the data for the two groups
+ hit.inx <- as.character(mSetObj$dataSet$cls.all) %in% grp.nms;
+ mSetObj$dataSet$cls <- factor(mSetObj$dataSet$cls.all[hit.inx]);
+ mSetObj$dataSet$norm <- mSetObj$dataSet$norm.all[hit.inx, ];
+ }else{
+ mSetObj$dataSet$cls <- mSetObj$dataSet$cls.all;
+ mSetObj$dataSet$norm <- mSetObj$dataSet$norm.all;
+ }
+ return(.set.mSet(mSetObj));
+}
+
+#'Rank features based on different importance measures
+#'@description Ranks features based on various importance measures,
+#'return imp.vec which contains the importance measures
+#'of unordered features
+#'@param x.in Input the X features
+#'@param y.in Input the Y features
+#'@param method Input the method
+#'@param lvNum Input the number of levels
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+RankFeatures <- function(x.in, y.in, method, lvNum){
+ if(method == "rf"){ # use randomforest mean decrease accuracy
+ rf <- randomForest::randomForest(x = x.in,y = y.in,importance=TRUE, keep.forest=F);
+ return(randomForest::importance(rf)[ ,"MeanDecreaseAccuracy"]);
+ }else if (method == "pls"){
+ ncls <- as.numeric(y.in)-1;
+ datmat <- as.matrix(x.in);
+ pls <- pls::plsr(ncls~datmat,method='oscorespls', ncomp=lvNum);
+ return(Get.VIP(pls, lvNum));
+ }else if(method == "svm"){
+ svmres <- e1071::svm(x.in, y.in, type = 'C', kernel="linear");
+ imp.vec <- (t(svmres$coefs) %*% svmres$SV)[1,]^2;
+ names(imp.vec) <- colnames(x.in);
+ return(imp.vec);
+ }else if(method == "auroc"){ # univariate based ou area under ROC
+ imp.vec <- caTools::colAUC(x.in, y.in, plotROC=F)[1,];
+ return(imp.vec);
+ }else if(method == "tt"){ # univariate based ou area under ROC
+ imp.vec <- Get.Fstat(x.in, as.factor(y.in)); # all f-stats
+ names(imp.vec) <- colnames(x.in);
+ return(imp.vec);
+ }else if(method == "fisher"){ # univariate based ou area under ROC
+ imp.vec <- Get.Fisher(x.in, as.factor(y.in));
+ names(imp.vec) <- colnames(x.in);
+ return(imp.vec);
+ }else{
+ print("Not supported!");
+ return(NULL);
+ }
+}
+
+#'Calculates feature importance
+#'@description Perform calculation of feature importance (AUC, p value, fold change)
+#'@usage CalculateFeatureRanking(mSetObj=NA, clust.num=5)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param clust.num Numeric, input the number of clusters for cluster-analysis
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+CalculateFeatureRanking <- function(mSetObj=NA, clust.num=5){
+
+ mSetObj <- .get.mSet(mSetObj);
+ LRConverged <<- "FALSE";
+
+ x <- mSetObj$dataSet$norm;
+ y <- mSetObj$dataSet$cls;
+
+ # auc
+ auc <- caTools::colAUC(x, y, plotROC=F)[1,];
+ if(.on.public.web & RequireFastUnivTests(mSetObj)){
+ res <- PerformFastUnivTests(x, y);
+ ttp <- res[,2];
+ }else{
+ ttp <- GetROCTtestP(x, y);
+ }
+
+ # fold change
+ # use non-transformed data, then log2
+ if(mSetObj$dataSet$use.ratio){
+ data <- mSetObj$dataSet$proc.ratio;
+ }else{
+ data <- mSetObj$dataSet$proc;
+ }
+ # update in case norm filtered?
+ hit.inxX <- rownames(data) %in% rownames(x);
+ hit.inxY <- colnames(data) %in% colnames(x);
+ data <- data[hit.inxX, hit.inxY, drop=FALSE];
+ min.val <- min(abs(data[data!=0]))/2;
+ data <- log2((data + sqrt(data^2 + min.val))/2);
+
+ m1 <- colMeans(data[which(mSetObj$dataSet$cls==levels(mSetObj$dataSet$cls)[1]), , drop=FALSE]);
+ m2 <- colMeans(data[which(mSetObj$dataSet$cls==levels(mSetObj$dataSet$cls)[2]), , drop=FALSE]);
+ fc <- m1-m2;
+
+ if(mSetObj$dataSet$roc_cols > 1){ # dont need to calc kmeans if only 1 metabolite!
+ # now do k-means to measure their expression similarities
+
+ kms <- ComputeKmeanClusters(t(x), clust.num);
+ feat.rank.mat <- data.frame(AUC=auc, Pval=ttp, FC=fc, clusters = kms);
+ rownames(feat.rank.mat) <- colnames(x);
+
+ ord.inx <- order(feat.rank.mat$AUC, decreasing=T);
+ feat.rank.mat <- data.matrix(feat.rank.mat[ord.inx, , drop=FALSE]);
+ }else{
+ feat.rank.mat <- data.matrix(data.frame(AUC=auc, Pval=ttp, FC=fc, clusters=1))
+ }
+
+ # how to format pretty, and still keep numeric
+ feat.rank.mat <<- signif(feat.rank.mat, digits = 5);
+
+ if(mSetObj$analSet$mode == "univ"){
+ fast.write.csv(feat.rank.mat, file="metaboanalyst_roc_univ.csv");
+ }
+ return(.set.mSet(mSetObj));
+}
+
+
+# return a vector contain the cluster index
+ComputeKmeanClusters <- function(data, clust.num){
+ set.seed(28051968);
+ # if feature number is too low, change clust.num
+ if(nrow(data) <= clust.num){
+ clust.num <- nrow(data)-1;
+ }
+ if(clust.num < 2){
+ clust.num <- 1;
+ }
+ kmeans.res <- kmeans(data, clust.num, nstart=100);
+ return(kmeans.res$cluster);
+}
+
+# recomputing based on new cluster number
+UpdateKmeans <- function(mSetObj=NA, clust.num=5){
+ mSetObj <- .get.mSet(mSetObj);
+ x <- mSetObj$dataSet$norm;
+ clsts <- ComputeKmeanClusters(t(x), clust.num);
+
+ # note, need to synchronize the order as feat.rank.mat is order by AUC, not the same as in the x
+ ord.inx <- match(rownames(feat.rank.mat), names(clsts));
+ feat.rank.mat[,"clusters"] <- clsts[ord.inx];
+ feat.rank.mat <<- feat.rank.mat;
+}
+
+#'Set biomarker analysis mode
+#'@description ROC utilities
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'@usage SetAnalysisMode(mSetObj, mode)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)s
+#'@param mode Input the selected mode for biomarker analysis, "univ" for univariate ROC curve analysis,
+#'"explore" for multivariate ROC curve analysis, and "test" for ROC curve based model creation and evaluation.
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+SetAnalysisMode <- function(mSetObj=NA, mode){
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$analSet$mode <- mode;
+ return(.set.mSet(mSetObj));
+}
+
+#'Perform Monte-Carlo Cross Validation (MCCV)
+#'@description Classification MCCV, aims to find the best feature
+#'subsets using default model parameters
+#'@usage PerformCV.explore(mSetObj, cls.method, rank.method="auroc", lvNum=2, propTraining=2/3)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param cls.method Select the classification method, "rf" for random forest classification, "pls" for PLS-DA,
+#'and "svm" for support vector machine
+#'@param rank.method Select the ranking method, "rf" for random forest mean decrease accuracy,
+#'"fisher" for Fisher's univariate ranking based on area under the curve
+#'"auroc" for univariate ranking based on area under the curve, "tt" for T-test univariate ranking based on area under the curve,
+#'"pls" for partial least squares, and "svm" for support vector machine
+#'@param lvNum Input the number of latent variables to include in the analyis, only for PLS-DA classification
+#'@param propTraining Input the proportion of samples to use for training
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+PerformCV.explore <- function(mSetObj=NA, cls.method, rank.method="auroc", lvNum=2, propTraining=2/3){
+ mSetObj <- .get.mSet(mSetObj);
+
+ mSetObj$analMethod <- cls.method;
+ data <- mSetObj$dataSet$norm;
+ cls <- mSetObj$dataSet$cls;
+
+ # number of subsampling to produce smooth curve
+ if(nrow(data) > 500){
+ nRuns <- 10;
+ }else if(nrow(data) > 200){
+ nRuns <- 20;
+ }else if(nrow(data) > 100){
+ nRuns <- 30;
+ }else{
+ nRuns <- 50;
+ }
+
+ nFeatures <- GetFeatureNumbers(ncol(data));
+
+ feat.outp <- actualCls <- vector(length = nRuns, mode = "list");
+
+ perf.outp <- vector(length = length(nFeatures), mode = "list");
+ perf.outp <- lapply(perf.outp, function(x){x <- vector(length = nRuns, mode = "list"); return(x)});
+ auc.mat <- accu.mat <- matrix(nrow=nRuns, ncol=length(nFeatures));
+
+ splitMat <- GetTrainTestSplitMat(cls, propTraining, nRuns);
+ trainRuns <- splitMat$training.mat;
+ testRuns <- splitMat$testing.mat;
+
+ for (irun in 1:nRuns){
+ trainingSampleRun <- trainRuns[irun, ]
+ testSampleRun <- testRuns[irun, ];
+ x.in <- data[trainingSampleRun, ];
+ y.train <- cls[trainingSampleRun];
+ actualCls[[irun]] <- y.test <- cls[testSampleRun];
+
+ # Feature ranking using only training data,
+ imp.vec <- RankFeatures(x.in, y.train, rank.method, lvNum);
+
+ feat.outp[[irun]] <- imp.vec;
+ ord.inx <- order(imp.vec, decreasing = TRUE);
+ ordData <- data[, ord.inx];
+
+ # buliding classifiers for each number of selected features and test on the test data
+ for (inum in seq(along = nFeatures)){
+ x.train <- ordData[trainingSampleRun, 1:nFeatures[inum]];
+ x.test <- ordData[testSampleRun, 1:nFeatures[inum]];
+ prob.out <- Predict.class(x.train, y.train, x.test, cls.method, lvNum);
+
+ # calculate AUC for each
+ pred <- ROCR::prediction(prob.out, y.test);
+ auc.mat[irun, inum] <- slot(ROCR::performance(pred, "auc"), "y.values")[[1]];
+
+ perf.outp[[inum]][[irun]] <- prob.out;
+ pred.out <- as.factor(ifelse(prob.out > 0.5, 1, 0));
+ accu.mat[irun, inum] <- Get.Accuracy(table(pred.out, y.test));
+ }
+ }
+
+ #############################################################################
+ ## prepare results for default plotting
+ ## 1) get best model based on AUROC for prob.view and imp.feature calculation
+ ## 2) calculate accuracy and roc for all models under comparison
+ #############################################################################
+
+ preds <- vector(length = length(nFeatures), mode = "list");
+ act.vec <- unlist(actualCls); # same for all subsets
+ for(m in 1:length(nFeatures)){
+ prob.vec <- unlist(perf.outp[[m]]);
+ pred <- ROCR::prediction(prob.vec, act.vec);
+ preds[[m]] <- pred; # prediction obj
+ #auc.vec[m] <- slot(performance(pred, "auc"), "y.values")[[1]];
+ }
+
+ # accu.mat and preds are for all models
+ colnames(accu.mat) <- colnames(auc.mat) <- names(preds) <- paste(nFeatures, sep = "");
+ auc.vec <- colMeans(auc.mat);
+
+ auc.cis <- GetCIs(auc.mat);
+ # get the best based on AUROC
+ best.model.inx <- which.max(auc.vec);
+
+ mSetObj$analSet$multiROC <- list(
+ type = mSetObj$analSet$type, # note, do not forget to carry the type "roc"
+ train.mat = trainRuns,
+
+ # record raw output
+ test.feats = nFeatures,
+ pred.cv = perf.outp,
+ true.cv = actualCls,
+ imp.cv = feat.outp,
+
+ # record processed output
+ pred.list = preds,
+ accu.mat = accu.mat,
+ auc.vec = auc.vec,
+ auc.ci = auc.cis,
+ best.model.inx = best.model.inx
+ )
+ return(.set.mSet(mSetObj));
+}
+
+#'Perform MCCV for manually selected features
+#'@description MCCV for manually selected features (no additional feature selection)
+#'@usage PerformCV.test(mSetObj, method, lvNum, propTraining=2/3, nRuns=100)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param method Select the classification method, "rf" for random forest classification, "pls" for PLS-DA,
+#'and "svm" for support vector machine
+#'@param lvNum Input the number of latent variables to include in the analyis, only for PLS-DA classification
+#'@param propTraining Input the proportion of samples to use for training, by default it is 2/3
+#'@param nRuns Input the number of MCCV runs, by default it is 100
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+PerformCV.test <- function(mSetObj=NA, method, lvNum, propTraining=2/3, nRuns=100){
+
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$analMethod <- method;
+ data <- mSetObj$dataSet$norm;
+ cls <- mSetObj$dataSet$cls;
+
+ if(method == "lr") {
+ # check cls (response variable) whether it is number 0/1 or not
+ if( length(levels(mSetObj$dataSet$cls)) == 2 ) {
+ mSetObj$dataSet$cls.lbl <- levels(mSetObj$dataSet$cls); # already sorted
+ cls <- as.numeric(mSetObj$dataSet$cls)-1;
+ mSetObj$dataSet$cls.lbl.new <- sort(unique(cls));
+ mSetObj$dataSet$cls01 <- cls; # integer values for response of logistic regression
+ } else {
+ AddErrMsg("level of response variable y/class has more than 2!");
+ return(0);
+ }
+ } else {
+ if(method == "pls"){# make sure the feature # > comp #
+ if(lvNum > ncol(data)){
+ AddErrMsg("PLS components cannot be more than total features selected!");
+ return(0);
+ }
+ }
+ cls <- mSetObj$dataSet$cls;
+ }
+
+ splitMat <- GetTrainTestSplitMat(cls, propTraining, nRuns);
+ trainRuns <- splitMat$training.mat;
+ testRuns <- splitMat$testing.mat;
+
+ feat.outp <- actualCls <- perf.outp <- vector(length = nRuns, mode = "list");
+ auc.vec <- accu.vec <- vector(mode="numeric", length=nRuns);
+
+ for (irun in 1:nRuns){
+ trainingSampleRun <- trainRuns[irun, ]
+ testSampleRun <- testRuns[irun, ];
+ x.train <- data[trainingSampleRun, ,drop=F];
+ x.test <- data[testSampleRun, ,drop=F];
+ y.train <- cls[trainingSampleRun];
+ actualCls[[irun]] <- y.test <- cls[testSampleRun];
+
+ res <- Predict.class(x.train, y.train, x.test, method, lvNum, imp.out=T);
+ feat.outp[[irun]] <- res$imp.vec;
+ prob.out <- res$prob.out;
+
+ # calculate AUC for each
+ pred <- ROCR::prediction(prob.out, y.test);
+ auc.vec[irun] <- slot(ROCR::performance(pred, "auc"), "y.values")[[1]];
+ perf.outp[[irun]] <- prob.out;
+ pred.out <- as.factor(ifelse(prob.out > 0.5, 1, 0));
+ accu.vec[irun] <- Get.Accuracy(table(pred.out, y.test));
+ }
+
+ #############################################################################
+ ## prepare results for default plotting
+ ## 1) get best model based on AUROC for prob.view and imp.feature calculation
+ ## 2) calculate accuracy and roc for all models under comparison
+ #############################################################################
+
+ prob.vec <- unlist(perf.outp);
+ act.vec <- unlist(actualCls);
+ preds <- ROCR::prediction(prob.vec, act.vec);
+ auc <- mean(auc.vec);
+ auc.ci <- GetCIs(as.matrix(auc.vec));
+
+ #########################################
+ # if there is holdout sample, do prediction
+ if(!is.null(mSetObj$dataSet$test.data)){
+ test.res <- Predict.class(data, cls, mSetObj$dataSet$test.data, method, lvNum);
+ }else{
+ test.res <- NULL;
+ }
+ #######################
+ #########################################
+ # if there is new samples, do prediction
+ if(!is.null(mSetObj$dataSet$new.data)){
+ new.res <<- Predict.class(data, cls, mSetObj$dataSet$new.data, method, lvNum);
+ }else{
+ new.res <- NULL;
+ }
+
+ #########################################
+ # method = Logistic Regression
+ # generate report tables for model with 10-fold Cross-Validation
+ if( method == "lr") {
+ x.train.all <- data;
+ x.test.all <- data;
+ y.train.all <- as.character(cls);
+ y.test.all <- as.character(cls);
+
+ # generate LR model and AUROC statistics. Then assign to the analSet list
+ # return (list(model = mdlSummary, LR.auc=LR.auc));
+
+ tbl.cls <- table(cls);
+ if( (tbl.cls[[1]] < 10) & (tbl.cls[[2]] < 10) ) {
+ AddErrMsg("The sample size of each group should be more than 10!");
+ return (0);
+ } else {
+ genLogisticRegMdl(x.train.all, y.train.all, x.test.all, y.test.all);
+ }
+ }
+ #######################
+ mSetObj$analSet$ROCtest <- list(
+ type = mSetObj$analSet$type, # note, do not forget to carry the type "roc" when overwrite analSet
+ train.mat = trainRuns,
+ pred.cv = perf.outp,
+ true.cv = actualCls,
+ imp.cv = feat.outp,
+
+ # record processed output
+ pred.list = preds,
+ accu.mat = t(as.matrix(accu.vec)),
+ auc.ci = auc.ci,
+ auc.vec = auc,
+ test.res = test.res,
+ new.res = new.res
+ );
+ return(.set.mSet(mSetObj));
+}
+
+#'Get predicted class probability
+#'@description Get predicted class probability
+#'@param x.train Input the x training samples
+#'@param y.train Input the y training samples
+#'@param x.test Input the x testing samples
+#'@param clsMethod Se the classification method, default is set to pls
+#'@param lvNum Input the number of levels
+#'@param imp.out Logical, set to F by default
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+Predict.class <- function(x.train, y.train, x.test, clsMethod="pls", lvNum, imp.out=F){
+
+ # first convert class label to 0/1 so convert prob-> class will be easier
+ y.train <- as.factor(as.numeric(y.train)-1);
+
+ # note, we only need prob for class 1, pred can be inferred
+ if (clsMethod == "rf"){
+ model <- randomForest::randomForest(x.train, y.train, ntree=300, importance=T);
+ prob.out <- predict(model, x.test, type="prob")[,"1"];
+ if(imp.out){
+ imp.vec <- randomForest::importance(model)[ ,"MeanDecreaseAccuracy"];
+ return(list(imp.vec = imp.vec, prob.out = prob.out));
+ }
+ return(prob.out);
+ }else if(clsMethod == "pls"){ # plsda
+ model <- caret::plsda(x.train, y.train, method='oscorespls', ncomp=ifelse(ncol(x.train)>lvNum, lvNum, 2));
+ prob.out <- predict(model, x.test, type="prob")[,"1",1];
+ if(imp.out){
+ imp.vec <- Get.VIP(model, lvNum);
+ return(list(imp.vec = imp.vec, prob.out = prob.out));
+ }
+ return(prob.out);
+ }else if(clsMethod == "lr"){ # logistic regression with selected variables (only in Test)
+ x <- x.train;
+ y <- y.train;
+ xx.test <- x.test;
+
+ names.x.origin <- names(x);
+ names(x) <- paste0("V", 1:(ncol(x)));
+ names(xx.test) <- names(x);
+
+ data.xy <- data.frame(y, x);
+ model <- logisticReg(data.xy);
+ prob.out <- predict(model, xx.test, type="response");
+ if(imp.out){
+ imp.vec <- names(model$coefficients)[-1]
+ return(list(imp.vec = imp.vec, prob.out = prob.out));
+ }
+ return(prob.out);
+ }else{ # svm
+ model <- e1071::svm(x.train, y.train, type = 'C', kernel="linear", probability=TRUE);
+ prob.out <- attr(predict(model, x.test, probability=TRUE), "probabilities")[,"1"];
+ if(imp.out){
+ imp.vec <- (t(model$coefs) %*% model$SV)[1,]^2;
+ names(imp.vec) <- colnames(x.train);
+ return(list(imp.vec = imp.vec, prob.out = prob.out));
+ }
+ return(prob.out);
+ }
+}
+
+logisticReg <- function(d.xy) {
+ fmla <- as.formula(paste("y ~", paste(names(d.xy)[-1], collapse="+")));
+ model <- glm(fmla, data=d.xy, family=binomial(link="logit"), na.action="na.omit")
+ return(model);
+}
+
+genLREquation <- function(coef.mdl){
+ coef.mdl <- round(coef.mdl, 3);
+
+ eq <- coef.mdl[[1]];
+ for(i in 2:length(coef.mdl)) {
+ eq <- paste(eq, ifelse(sign(coef.mdl[[i]])==1,"+","-"), abs(round(coef.mdl[[i]],3)), names(coef.mdl)[i]);
+ }
+ return(eq);
+}
+
+#'Calculate ROC performance with CV
+#'@description Calculate ROC performance with CV
+#'@param data.in Input matrix of data
+#'@param fmla.in Input for generalized linear model
+#'@param kfold Numeric
+#'@param run.stepwise Logical
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+CVTest.LRmodel <- function(data.in, fmla.in, kfold=10, run.stepwise=FALSE){
+
+
+ dw.case <- data.in[which(data.in$y == 1), ]; nrow(dw.case)
+ dw.ctrl <- data.in[which(data.in$y == 0), ]; nrow(dw.ctrl)
+
+ random.seed <- 10063927;
+ grpIndice.case <- createCVset(nrow(dw.case), kfold, random.seed)
+ grpIndice.ctrl <- createCVset(nrow(dw.ctrl), kfold, random.seed)
+
+ all.trainning.y <- NULL
+ all.trainning.fit <- NULL
+ all.validation.y <- NULL
+ all.validation.fit <- NULL
+
+ for (i in 1:kfold)
+ {
+ d.train.case <- dw.case[-grpIndice.case[[i]], ]; nrow(d.train.case)
+ d.train.ctrl <- dw.ctrl[-grpIndice.ctrl[[i]], ]; nrow(d.train.ctrl)
+ d.train <- rbind(d.train.case, d.train.ctrl); names(d.train)
+
+ d.validation.case <- dw.case[grpIndice.case[[i]], ]; nrow(d.validation.case)
+ d.validation.ctrl <- dw.ctrl[grpIndice.ctrl[[i]], ]; nrow(d.validation.ctrl)
+ d.validation <- rbind(d.validation.case, d.validation.ctrl)
+
+ vnames <- names(d.train);
+
+ mdl <- glm(fmla.in, data=d.train, family=binomial(link="logit"))
+ if(run.stepwise) { mdl <- step(mdl) }
+
+ dval.pred <- predict(mdl, d.validation, type="response");
+
+ all.validation.y <- c(all.validation.y, d.validation$y)
+ all.validation.fit <- c(all.validation.fit, dval.pred)
+ all.trainning.y <- c(all.trainning.y, mdl$y)
+ all.trainning.fit <- c(all.trainning.fit, mdl$fitted.values)
+ }
+
+ # 10-fold cross validation
+ cv.r <- pROC::roc(all.validation.y ~ all.validation.fit, ci=T, ci.se=T, sp=seq(0,1,0.01)) # of: se (sensitivity), sp (specificity), thresholds, auc
+ # cv.threshold <- coords(cv.r, "best", ret=c("threshold"), best.method="youden", best.weights=c(5, nrow(dw.case)/nrow(data.in)) );
+ cv.threshold <- as.numeric(pROC::coords(cv.r, "best", ret=c("threshold"), best.method="closest.topleft", transpose=TRUE));
+ cv.rstat <- multi.stat(all.validation.fit > cv.threshold, all.validation.y);
+ if(length(cv.rstat) == 1 && cv.rstat == 0){
+ return(0);
+ }
+ cv.tbl <- table(all.validation.fit > cv.threshold, all.validation.y);
+
+ # training performance
+ train.r <- pROC::roc(all.trainning.y ~ all.trainning.fit, ci=T, ci.se=T, sp=seq(0,1,0.01)) # of: se (sensitivity), sp (specificity), thresholds, auc
+ train.threshold <- pROC::coords(train.r, "best", ret=c("threshold"), best.method="youden", transpose=TRUE);
+ train.rstat <- multi.stat(all.trainning.fit > cv.threshold, all.trainning.y)
+ if(length(train.rstat) == 1 && train.rstat == 0){
+ return(0);
+ }
+ return(list(
+ train.r = train.r$ci,
+ train.threshold = train.threshold,
+ train.rstat = train.rstat,
+ cv.robj = cv.r,
+ cv.r = cv.r$ci,
+ cv.threshold = cv.threshold,
+ cv.rstat = cv.rstat,
+ cv.tbl = cv.tbl,
+ cv.y = all.validation.y,
+ cv.pred = all.validation.fit,
+ cv.threshold = cv.threshold
+ ));
+}
+
+#'Develop a Logistic Regression Model with all of the combined k-fold CV subsets
+#'@description Develop a Logistic Regression Model with all of the combined k-fold CV subsets
+#'@param x.train Input the X training set
+#'@param y.train Input the Y training set
+#'@param x.test Input the X test set
+#'@param y.test Input the Y test set
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+genLogisticRegMdl <- function(x.train, y.train, x.test, y.test){
+
+ # use 10-fold CV as default; or LOOCV if sample size < 10
+ x <- x.train;
+ y <- y.train;
+ x.cv.test <- x.test;
+ y.cv.test <- y.test;
+
+ names.x.origin <- names(x);
+ names(x) <- paste0("V", 1:(ncol(x)));
+ names(x.cv.test) <- names(x);
+
+ # glm can only take numeric + factor
+ if(class(y) == "character"){
+ y <- as.factor(y)
+ }
+
+ # LR Model generation
+ data.xy <- data.frame(y, x);
+ fmla <- as.formula(paste("y ~", paste(names(data.xy)[-1], collapse="+")));
+
+ model <- glm(fmla, data=data.xy, family=binomial(link="logit"), na.action="na.omit");
+
+ # if model with selected variables is failed, the use the stepwise variable selection
+ if((!model$converged) | (model$deviance < 1)){
+ model <- step(model, trace=0);
+ fmla <- model$formula;
+ }
+
+ mdlSummary <- summary(model)$coefficients;
+ dimnames(mdlSummary)[[1]][-1] <- names.x.origin;
+ # prob.out <- predict(model, x.cv.test, type="response");
+
+ Odds <- round(exp(cbind(OR=coef(model), confint(model))), 2)[,1];
+ # Odds <- round(exp(OR=coef(model)), 2);
+ Odds[1] <- "-";
+ LRmodel <- cbind(round(mdlSummary,3), Odds);
+ LRmodel[,4] <- ifelse(LRmodel[,4] < 0.001, "< 0.001", LRmodel[,4]);
+
+ # LR model's summary table as html format
+ LRmodel.xtable <<- print(xtable::xtable(LRmodel, align="r|rrrcc"),
+ type = "html", print.results=F, xtable.width=600,
+ html.table.attributes="border=1 width=600" );
+
+ coefTable <- coef(model);
+ names(coefTable)[-1] <- names.x.origin;
+ if (model$converged & model$deviance > 1) {
+ LReq <<- genLREquation(coefTable);
+ LRConverged <<- "TRUE";
+ } else {
+ # (Error: Model was not converged)
+ LReq <<- "(Error: Model was not converged)";
+ LRConverged <<- "FALSE";
+ }
+
+ # ROC analysis with 10-fold CV test set
+ rStat <- CVTest.LRmodel(data.xy, fmla.in=fmla, kfold=10, run.stepwise=FALSE)
+ # r <- roc(y.cv.test ~ prob.out, ci=T, ci.se=T, sp=seq(0,1,0.01)) # of: se (sensitivity), sp (specificity), thresholds, auc
+
+ # ROC plot with k-fold CV test set for ROC plot
+ LR.r <<- rStat$cv.robj;
+ LR.y.origin <<- rStat$cv.y;
+ LR.y.pred <<- rStat$cv.pred;
+ LR.threshold <<- rStat$cv.threshold;
+
+ # training/discovery; 10-fold CV
+ auc <- c( sprintf("%.3f (%.3f ~ %.3f)", rStat$train.r[2], rStat$train.r[1], rStat$train.r[3]),
+ sprintf("%.3f (%.3f ~ %.3f)", round(rStat$cv.r[2],3), round(rStat$cv.r[1],3), round(rStat$cv.r[3],3)) );
+ sens <- c( sprintf("%.3f (%.3f ~ %.3f)", rStat$train.rstat$sens, rStat$train.rstat$sensCI[1], rStat$train.rstat$sensCI[2]),
+ sprintf("%.3f (%.3f ~ %.3f)", rStat$cv.rstat$sens, rStat$cv.rstat[1], rStat$cv.rstat$sensCI[2]) );
+ spec <- c( sprintf("%.3f (%.3f ~ %.3f)", rStat$train.rstat$spec, rStat$train.rstat$specCI[1], rStat$train.rstat$specCI[2]),
+ sprintf("%.3f (%.3f ~ %.3f)", rStat$cv.rstat$spec, rStat$cv.rstat$specCI[1], rStat$cv.rstat$specCI[2]) );
+
+ LRperf <- cbind(auc, sens, spec);
+ colnames(LRperf) <- c("AUC","Sensitivity","Specificity");
+ rownames(LRperf) <- c("Training/Discovery","10-fold Cross-Validation");
+
+ LRperf.xtable <<- print(xtable::xtable(LRperf, align="r|ccc"), include.rownames=TRUE, floating=FALSE,
+ type = "html", print.results=F, xtable.width=600,
+ html.table.attributes="border=1 width=600");
+}
+
+#'Plot ROC for the logistic regression model
+#'@description Plot ROC for the logistic regression model
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param show.conf Logical, show confidence intervals
+#'@param sp.bin Numeric, default is set to 0.01.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotROC.LRmodel <- function(mSetObj=NA, imgName, format="png", dpi=72, show.conf=FALSE, sp.bin=0.01) {
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ w <- h <- 8;
+ mSetObj$imgSet$roc.lr <- imgName;
+
+ roc.object <- LR.r;
+ y.origin <- LR.y.origin;
+ y.pred <- LR.y.pred;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ op <- par(mar=c(5,4,3,3));
+
+ # auc.ci <- ci.auc(roc.object, method="bootstrap", boot.n=500, progress="none");
+ auc.lbl <- paste("Area under the curve (AUC) = ", round(roc.object$ci[2],3), sep="");
+ ci.lbl <- paste("95% CI: ", round(roc.object$ci[1],3), " - ", round(roc.object$ci[3],3),sep="");
+ perform.lbl <- paste(auc.lbl,"\n", ci.lbl, sep="");
+
+ # plot ROC of specific model and save the table for details
+ if(show.conf){
+ # of: se (sensitivity), sp (specificity), thresholds, auc
+ r.new <- roc(y.origin ~ y.pred, ci=T, of="se", sp=seq(0,1,sp.bin));
+ pROC::plot.roc(r.new, add=F, ci.type="bars", ci.col="green", col="darkolivegreen", lty="dotted", legacy.axes=T,
+ xlab="1 - Specificity (False positive rate)", ylab="Sensitivity (True positive rate)",
+ cex.axis=1.0, cex.lab=1.0);
+ pROC::plot.roc(smooth(r.new, method="density", n=512), add=T, col="blue", lwd=1);
+ legend("bottomright", legend=c("Empirical","Smoothed", "95% CI"), cex=1.0, col=c(par("fg"), "blue", "green"), lwd=3, lty=c(3,1,1) );
+
+ text(0.7, 0.4, perform.lbl, adj=c(0,1), col="black", cex=1.0);
+ } else {
+ pROC::plot.roc(roc.object, add=F, ci.type="no", col="blue", legacy.axes=T,
+ xlab="1 - Specificity (False positive rate)", ylab="Sensitivity (True positive rate)",
+ cex.axis=1.0, cex.lab=1.0, lwd=2, lty=1 );
+ text(0.7, 0.4, perform.lbl, adj=c(0,1), col="black", cex=1.0);
+ }
+
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+
+#'Get multiple category statistics
+#'@description Get multiple category statistics
+#'@param pred Input predictions
+#'@param resp Input responses
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+multi.stat <- function(pred, resp) {
+
+ in.dat <- na.omit(cbind(pred,resp));
+
+ if(nrow(in.dat) < length(pred)/2){ # abort if over half is invalid
+ AddErrMsg("More than half of tests return NA! Insufficent sample size?");
+ return(0);
+ }
+
+ pred <- in.dat[,1];
+ resp <- in.dat[,2];
+
+ ts <- table(pred, resp)
+
+ TP <- ts[2,2]
+ FP <- ts[2,1] # identify as True/Positive but actually Negative/False (healthy)
+ FN <- ts[1,2] # identify as False/Negative but actually Positive/True
+ TN <- ts[1,1]
+
+ sensitivity <- TP / (TP + FN)
+ specificity <- TN / (FP + TN)
+ ppv <- TP / (TP + FP)
+ npv <- TN / (FN + TN)
+ likelihood_ratio_pos <- sensitivity / (1 - specificity) # positive
+ likelihood_ratio_neg <- (1-sensitivity) / specificity # positive
+ # (TP + TN) / (TP + TN + FP + FN)
+ accuracy <- (TP + TN) / sum(ts)
+ # fdr = fp / (fp + tp) : false discovery rate
+ fdr <- FP / (FP + TP)
+
+ SEsens <- sqrt(sensitivity * (1-sensitivity) / (TP + FN) )
+ SEspec <- sqrt(specificity * (1-specificity) / (FP + TN) )
+
+ cise.u <- sensitivity + 1.96 * SEsens
+ cisp.u <- specificity + 1.96 * SEspec
+ CIsens <- c(sensitivity - 1.96 * SEsens, ifelse( cise.u > 1.0, 1.0, cise.u) )
+ CIspec <- c(specificity - 1.96 * SEspec, ifelse( cisp.u > 1.0, 1.0, cisp.u) )
+
+ return(list(sens=sensitivity, sensCI=CIsens, spec=specificity, specCI=CIspec) );
+}
+
+#'Get confidence intervals
+#'@description For non-parametric tests, use quantiles,
+#'use normal (1.96*std.err) if parametric
+#'@param data Input data matrix
+#'@param param Logical, False by default
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+GetCIs <- function(data, param=F){
+ means <- colMeans(data, na.rm=T);
+ if(param){
+ sds <- apply(data, 2, sd, na.rm=T);
+ nn <- nrow(data);
+ std.err <- sds/sqrt(nn);
+ LCL <- round(means-1.96*std.err,3);
+ LCL[LCL<0] <- 0;
+ UCL <- round(means+1.96*std.err, 3);
+ UCL[UCL>1] <- 1;
+ res <- paste(LCL, "-", UCL, sep="");
+ }else{
+ cis <- apply(data, 2, quantile, probs=c(0.025, 0.975));
+ cis <- round(cis,3);
+ cis[cis<0] <- 0;
+ cis[cis>1] <- 1;
+ res <- paste(cis[1,], "-", cis[2,], sep="");
+ }
+ res;
+}
+
+#'Perform Classical Univariate ROC
+#'@description Perform Classical Univariate ROC
+#'@usage Perform.UnivROC(mSetObj=NA, feat.nm, imgName, format="png", dpi=72, isAUC, isOpt, optMethod, isPartial, measure, cutoff)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param feat.nm Input the name of the feature to perform univariate ROC analysis
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, png, of pdf.
+#'@param dpi Input the dpi. If the image format is pdf, users need not define the dpi. For png images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param isAUC Logical, select T to compute the 95 percent confidence interval band and "F" to not
+#'@param isOpt Logical, show the optimal cutoff, T to show it and F to not
+#'@param optMethod Select the optimal cutoff by using either closest.topleft for closest to top-left corner or
+#'youden for farthest to the diagonal line (Youden)
+#'@param isPartial Logical, input T to calculate a partial ROC curve, and F to not
+#'@param measure Select the parameter to limit the calculation of the partial ROC curve, se for the X-axis (maximum false-positive rate)
+#'and sp for the Y-axis, representing the minimum true positive-rate
+#'@param cutoff Input the threshold to limit the calculation of the partial ROC curve, the number must be between 0 and 1.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+Perform.UnivROC <- function(mSetObj=NA, feat.nm, version, format="png", dpi=72, isAUC, isOpt, optMethod, isPartial, measure, cutoff){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ imgName <- gsub("\\/", "_", feat.nm);
+ imgName = paste(imgName, "_", version, "dpi", dpi, ".", format, sep="");
+
+ x <- mSetObj$dataSet$norm[, feat.nm];
+ y <- mSetObj$dataSet$cls;
+
+ if(isPartial){
+ if(measure == "se"){
+ cutoff = cutoff;
+ }else{
+ cutoff = 1-cutoff;
+ }
+ roc.obj <- pROC::roc(y, x, partial.auc=c(1.0, cutoff), ci=TRUE, partial.auc.focus=measure, boot.n=50, percent = F, progress="none");
+ }else{
+ roc.obj <- pROC::roc(y, x, percent = F);
+ }
+
+ w <- h <- 6;
+
+ mSetObj$imgSet$roc.univ.plot <- imgName;
+ mSetObj$imgSet$roc.univ.name <- feat.nm;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ par(oma=c(0,0,1,0));
+ par(mar=c(4,4,4,4)+.1);
+
+ opt.thresh = NA;
+
+ # first plot ROC curve
+ if(isAUC){
+ pROC::plot.roc(roc.obj, print.auc=F, legacy.axes=TRUE, col="navy", grid=T,
+ xlab = "False positive rate", ylab="True positive rate", main=feat.nm);
+ ci.obj <- pROC::ci.se(roc.obj, specificities=seq(0, 1, 0.05), boot.n=200, progress="none");
+ ROCR::plot(ci.obj,type="shape",col="#0000ff22");
+ }else{
+ pROC::plot.roc(roc.obj, print.auc=F, legacy.axes=TRUE, col="navy", grid=T,
+ xlab = "False positive rate", ylab="True positive rate",
+ auc.polygon=TRUE, auc.polygon.col="#0000ff22", main=feat.nm);
+ }
+
+ auc.ci <- pROC::ci.auc(roc.obj, method="bootstrap", boot.n=500, progress="none");
+ roc.obj$ci <- auc.ci;
+ auc.lbl <- paste("AUC: ", round(roc.obj$ci[2],3), sep="");
+ ci.lbl <- paste("(", round(roc.obj$ci[1],3), "-", round(roc.obj$ci[3],3), ")", sep="");
+ text(0.5, 0.5, paste(auc.lbl, "\n", ci.lbl, sep=""), adj=c(0,1), col="navy");
+
+ if(isOpt){
+ par(xpd=T);
+ opt.ps <- data.frame(pROC::coords(roc.obj, "best", best.method=optMethod, transpose = TRUE));
+ opt.thresh <- opt.ps["threshold",]
+ points(opt.ps["specificity",], opt.ps["sensitivity",], pch=19, col="red");
+ lbls=paste(signif(opt.ps["threshold",],3), "(", round(opt.ps["specificity",],1), ", ", round(opt.ps["sensitivity",],1), ")", sep="");
+ text(opt.ps["specificity",], opt.ps["sensitivity",], adj=c(-.05,1.25), label=lbls);
+ }
+
+ dev.off();
+
+ mSetObj$analSet$opt.thresh <- opt.thresh
+
+ if(.on.public.web){
+ .set.mSet(mSetObj);
+ return(imgName);
+ }else{
+ return(.set.mSet(mSetObj));
+ }
+}
+
+#'Plot a boxplot view of a selected compound
+#'@description Plots a boxplot of the selected compound's concentration
+#'between the groups.
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param feat.nm Input the name of the selected compound.
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", of "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+PlotRocUnivBoxPlot <- function(mSetObj, feat.nm, version, format="png", dpi=72, isOpt, isQuery){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(.on.public.web){
+ load_ggplot()
+ }
+
+ imgName <- gsub("\\/", "_", feat.nm);
+ imgName = paste(imgName, "_box_", version, "dpi", dpi, ".", format, sep="");
+
+ x <- mSetObj$dataSet$norm[, feat.nm];
+ y <- mSetObj$dataSet$cls;
+ scale <- dpi/72;
+ w <- 200*scale;
+ h <- 400*scale;
+ col <- unique(GetColorSchema(y));
+
+ mSetObj$imgSet$roc.univ.boxplot <- imgName;
+
+ Cairo::Cairo(file=imgName, width=w, height=h, type=format, bg="white", dpi=dpi);
+
+ df <- data.frame(conc = x, class = y)
+ p <- ggplot2::ggplot(df, aes(x=class, y=conc, fill=class)) + geom_boxplot(notch=FALSE, outlier.shape = NA, outlier.colour=NA) + theme_bw() + geom_jitter(size=1)
+ p <- p + theme(axis.title.x = element_blank(), axis.title.y = element_blank(), legend.position = "none")
+ p <- p + stat_summary(fun=mean, colour="yellow", geom="point", shape=18, size=3, show.legend = FALSE)
+ p <- p + theme(text = element_text(size=15), plot.margin = margin(t=0.45, r=0.25, b=1.5, l=0.25, "cm"), axis.text = element_text(size=10))
+ p <- p + scale_fill_manual(values=col)
+
+ if(isOpt){
+ opt.thresh <- mSetObj$analSet$opt.thresh
+ p <- p + geom_hline(aes(yintercept=opt.thresh), colour="red")
+ }
+
+ if(isQuery){
+ thresh <- as.numeric(mSetObj$analSet$roc.obj$thresh)
+ p <- p + geom_hline(aes(yintercept=thresh), colour="red")
+ }
+
+ print(p)
+ dev.off()
+ if(.on.public.web){
+ .set.mSet(mSetObj);
+ return(imgName);
+ }else{
+ return(.set.mSet(mSetObj));
+ }
+
+}
+
+#'Plot a summary view of the classification result
+#'@description Plot of predicted class probabilities. On the x-axis is the proability,
+#'and the y-axis is the index of each predicted sample based on the probility.
+#'The samples are turned into separations at the x-axis.
+#'This plot can be created for multivariate ROC curve analysis using SVM, PLS, and RandomForest.
+#'Please note that sometimes, not all samples will be tested, instead they will be plotted
+#'at the 0.5 neutral line.
+#'@usage PlotProbView(mSetObj=NA, imgName, format="png", dpi=72, mdl.inx, show, showPred)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", of "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param mdl.inx Model index, 0 means to compare all models, -1 means to use the best model, input 1-6 to plot a ROC curve for one of the top six models
+#'@param show 1 or 0, if 1, label samples classified to the wrong groups
+#'@param showPred Show predicted samples
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+PlotProbView <- function(mSetObj=NA, imgName, format="png", dpi=72, mdl.inx, show, showPred) {
+
+ mSetObj <- .get.mSet(mSetObj);
+ anal.mode <- mSetObj$analSet$mode;
+
+ smpl.nms <- rownames(mSetObj$dataSet$norm);
+ prob.vec <- rep(0.5, length(smpl.nms));
+ names(prob.vec) <- smpl.nms;
+
+ if(anal.mode == "explore"){
+ if(mdl.inx == -1){
+ mdl.inx <- mSetObj$analSet$multiROC$best.model.inx;
+ }
+ probs <- MergeDuplicates(unlist(mSetObj$analSet$multiROC$pred.cv[[mdl.inx]]));
+ }else{
+ probs <- MergeDuplicates(unlist(mSetObj$analSet$ROCtest$pred.cv));
+ }
+ prob.vec[names(probs)] <- probs;
+
+ nms <- names(prob.vec);
+ ord.inx <- order(nms);
+ prob.vec <- prob.vec[ord.inx];
+ cls <- mSetObj$dataSet$cls[ord.inx];
+ # remember to update the nms itself!
+ nms <- names(prob.vec);
+
+ # get html confusion matrix
+ pred.out <- as.factor(ifelse(prob.vec > 0.5, 1, 0));
+ act.cls <- as.numeric(cls)-1;
+
+ prob.res <- data.frame(Probability=prob.vec, Predicted=pred.out, Actual=act.cls);
+
+ if(anal.mode == "explore"){
+ write.table(prob.res, file="roc_pred_prob.csv", sep=",", col.names = TRUE);
+ }else{
+ write.table(prob.res, file="roc_pred_prob1.csv", sep=",", col.names = TRUE);
+ }
+
+ conf.res <- table(pred.out, act.cls);
+ mSetObj$analSet$conf.table <- xtable::xtable(conf.res, caption="Confusion Matrix (Cross-Validation)");
+ mSetObj$analSet$conf.mat <- print(mSetObj$analSet$conf.table, type = "html", print.results=F, caption.placement="top", html.table.attributes="border=1 width=150" )
+
+ if(anal.mode == "test"){
+ if(!is.null(mSetObj$dataSet$test.data)){
+
+ test.pred <- ifelse(mSetObj$analSet$ROCtest$test.res > 0.5, 1, 0);
+ test.cls <- as.numeric(mSetObj$dataSet$test.cls)-1;
+
+ test.df <- data.frame(Prob_HoldOut=mSetObj$analSet$ROCtest$test.res, Predicted_HoldOut=test.pred, Actual_HoldOut=test.cls);
+ suppressMessages(write.table(test.df, file="roc_pred_prob1.csv", sep=",", append=TRUE, col.names = TRUE));
+
+ test.res <- table(test.pred, test.cls);
+ mSetObj$analSet$conf.mat.test <- print(xtable::xtable(test.res,
+ caption="Confusion Matrix (Hold-out)"),
+ type = "html", print.results=F, xtable.width=120, caption.placement="top",
+ html.table.attributes="border=1 width=150" );
+ }
+ }
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ w <- 9; h <- 8;
+
+ if(anal.mode == "explore"){
+ mSetObj$imgSet$roc.prob.plot <- imgName;
+ mSetObj$imgSet$roc.prob.name <- mdl.inx
+ }else{
+ mSetObj$imgSet$roc.testprob.plot <- imgName;
+ mSetObj$imgSet$roc.testprob.name <- mdl.inx
+ }
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+
+ set.seed(123);
+ y <- rnorm(length(prob.vec));
+ max.y <- max(abs(y));
+ ylim <- max.y*c(-1.05, 1.05);
+
+ xlim <- c(0, 1.0);
+
+ op <- par(mar=c(4,4,3,6));
+ pchs <- ifelse(as.numeric(cls) == 1, 1, 19);
+
+ colors <- ifelse(show==1, "darkgrey", "black");
+ ROCR::plot(prob.vec, y, pch=pchs, col=colors, xlim=xlim, ylim= ylim, xlab = "Predicted Class Probabilities", ylab="Samples");
+ abline(h = 0, lty = 2, col="grey");
+ abline(v = 0.5, lty = 2, col="grey");
+
+ par(xpd=T);
+ legend("right",inset=c(-0.11,0), legend = unique(as.character(cls)), pch=unique(pchs));
+
+ test.y <- test.x <- 0;
+ if(showPred){
+ if(anal.mode == "explore"){
+ test.y <- rnorm(length(mSetObj$analSet$multiROC$test.res));
+ test.x <- mSetObj$analSet$multiROC$test.res;
+ }else{
+ test.y <- rnorm(length(mSetObj$analSet$ROCtest$test.res));
+ test.x <- mSetObj$analSet$ROCtest$test.res;
+ }
+ pchs <- ifelse(as.numeric(mSetObj$dataSet$test.cls) == 1, 1, 19);
+ points(test.x, test.y, pch=pchs, cex=1.5, col="red");
+ }
+
+ if(show == 1){
+
+ # add labels for sample classified wrong
+ # the idea is to add labels to the left side for those with prob < 0.5
+ # and add labels to the right side of the point for those with prob > 0.5
+ # leave 0.5 out
+
+ # first wrong pred as 1 (right side)
+ act.ones <- as.numeric(cls)-1 == 1;
+ pred.vec <- ifelse(prob.vec > 0.5, 1, 0);
+
+ wrong.inx <- (pred.vec != as.numeric(cls)-1) & pred.vec == 1;
+ if(sum(wrong.inx) > 0){
+ text(prob.vec[wrong.inx], y[wrong.inx], nms[wrong.inx], pos=4);
+ }
+
+ # first wrong pred as 0 (left side)
+ act.zeros <- as.numeric(cls)-1 == 0;
+ pred.vec <- ifelse(prob.vec < 0.5, 0, 0.5);
+ wrong.inx <- pred.vec != as.numeric(cls)-1 & pred.vec == 0;
+ if(sum(wrong.inx) > 0){
+ text(prob.vec[wrong.inx], y[wrong.inx], nms[wrong.inx], pos=2);
+ }
+
+ if(showPred){
+ nms <- rownames(mSetObj$dataSet$test.data);
+
+ act.ones <- as.numeric(mSetObj$dataSet$test.cls)-1 == 1;
+ act.zeros <- as.numeric(mSetObj$dataSet$test.cls)-1 == 0;
+
+ # leave 0.5 there
+ pred.vec <- ifelse(test.x > 0.5, 1, 0.5);
+ wrong.inx <- (pred.vec != as.numeric(mSetObj$dataSet$test.cls)-1) & act.ones;
+ if(sum(wrong.inx) > 0){
+ text(test.x[wrong.inx], test.y[wrong.inx], nms[wrong.inx], pos=4, cex=0.9);
+ }
+
+ pred.vec <- ifelse(test.x < 0.5, 0, 0.5);
+ wrong.inx <- pred.vec != as.numeric(mSetObj$dataSet$test.cls)-1 & act.zeros;
+ if(sum(wrong.inx) > 0){
+ text(test.x[wrong.inx], test.y[wrong.inx], nms[wrong.inx], pos=2, cex=0.9);
+ }
+ }
+ }
+ par(op)
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+#'Plot ROC
+#'@description Pred and auroc are lists containing predictions
+#'and labels from different cross-validations
+#'@usage PlotROC(mSetObj=NA, imgName, format="png", dpi=72, mdl.inx, avg.method, show.conf, show.holdout, focus="fpr", cutoff = 1.0)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", of "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param mdl.inx Model index, 0 means to compare all models, input 1-6 to plot a ROC curve for one of the top six models
+#'@param avg.method Input the method to compute the average ROC curve, either "threshold", "vertical" or "horizontal"
+#'@param show.conf Logical, if 1, show confidence interval, if 0 do not show
+#'@param show.holdout Logical, if 1, show the ROC curve for hold-out validation, if 0 do not show
+#'@param focus "fpr"
+#'@param cutoff Input the threshold to limit the calculation of the ROC curve, the number must be between 0 and 1.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotROC <- function(mSetObj=NA, imgName, format="png", dpi=72, mdl.inx, avg.method, show.conf, show.holdout, focus="fpr", cutoff = 1.0){
+
+ mSetObj <- .get.mSet(mSetObj);
+ anal.mode <- mSetObj$analSet$mode;
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ w <- 8; h <- 8;
+
+ if(anal.mode == "test"){
+ mSetObj$imgSet$roc.testcurve.plot <- imgName;
+ mSetObj$imgSet$roc.testcurve.name <- mdl.inx
+ mSetObj$imgSet$roc.testcurve.method <- avg.method
+ }else{
+ mSetObj$imgSet$roc.multi.plot <- imgName;
+ mSetObj$imgSet$roc.multi.model <- mdl.inx
+ }
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+
+ op <- par(mar=c(5,4,3,3));
+
+ if(anal.mode=="explore" && mdl.inx == 0){ # compare all models
+ preds <- mSetObj$analSet$multiROC$pred.list;
+ auroc <- mSetObj$analSet$multiROC$auc.vec;
+ perf <- ROCR::performance(preds[[1]], "tpr", "fpr");
+ perf.avg <- ComputeAverageCurve(perf, avg.method);
+
+ cols <- (1:length(preds))+1;
+ ROCR::plot(perf.avg@x.values[[1]], perf.avg@y.values[[1]], type="n", axes=F,
+ xlim=c(0,1), ylim=c(0,1),
+ xlab="1-Specificity (False positive rate)",
+ ylab="Sensitivity (True positive rate)"
+ );
+
+ box()
+ axis(side=2)
+ lab.at <- seq(0, 1, 0.2);
+ grid.at <- seq(0, 1, 0.1);
+ lab.labels <- lab.at
+ axis(side=1, at=lab.at, labels=as.graphicsAnnot(sprintf( "%.1f", lab.labels)));
+ abline(v=grid.at, lty=3, col="lightgrey");
+ abline(h=grid.at, lty=3, col="lightgrey");
+ lines(perf.avg@x.values[[1]], perf.avg@y.values[[1]], col=cols[1]);
+ for(i in 2:length(preds)){
+ perf <- ROCR::performance(preds[[i]], "tpr", "fpr");
+ avg <- ComputeAverageCurve(perf, avg.method);
+ lines(avg@x.values[[1]], avg@y.values[[1]], col=cols[i]);
+ }
+
+ best.inx <- which.max(auroc);
+
+ # now add and format legends to the bottom right corner
+ feats <- c("Var.", names(preds));
+ feats <- substr(feats, 1, 8);
+ feats <- sprintf("%-5s", feats);
+
+ vals <- c("AUC", round(auroc, 3));
+
+ vals <- sprintf("%-8s", vals);
+
+ cis <- mSetObj$analSet$multiROC$auc.ci;
+ cis <- c("CI", cis);
+ legends <- paste(feats, vals, cis, sep="");
+
+ pch <- c(NA, rep(15, length(preds)));
+ cols <- c(NA, cols);
+
+ legend("bottomright", legend = legends, pch=15, col=cols);
+
+ }else if(mdl.inx > 0 && anal.mode=="explore"){
+
+ preds <- ROCR::prediction(mSetObj$analSet$multiROC$pred.cv[[mdl.inx]], mSetObj$analSet$multiROC$true.cv);
+ auroc <- round(mSetObj$analSet$multiROC$auc.vec[mdl.inx],3);
+ auc.ci <- mSetObj$analSet$multiROC$auc.ci[mdl.inx];
+ perf <- ROCR::performance(preds, "tpr", "fpr");
+ perf.avg <- ComputeAverageCurve(perf, avg.method);
+ y.all <- perf.avg@y.values[[1]];
+ x.all <- perf.avg@x.values[[1]];
+ lgd <- paste("Area under the curve (AUC) =", auroc, "\n",
+ "95% CI:", auc.ci);
+
+ ROCR::plot(x.all, y.all, type="n", axes=F,
+ xlim=c(0,1), ylim=c(0,1),
+ xlab="1-Specificity (False positive rate)",
+ ylab="Sensitivity (True positive rate)"
+ );
+
+ box()
+ axis(side=2)
+ lab.at <- seq(0, 1, 0.2);
+ grid.at <- seq(0, 1, 0.1);
+ lab.labels <- lab.at
+ axis(side=1, at=lab.at, labels=as.graphicsAnnot(sprintf( "%.1f", lab.labels)));
+ abline(v=grid.at, lty=3, col="lightgrey");
+ abline(h=grid.at, lty=3, col="lightgrey");
+ lines(x.all, y.all, type="l", lwd=2, col="blue");
+
+ if(show.conf){
+ res <- ComputeHighLow(perf);
+ suppressWarnings(polygon(c(x.all, rev(x.all)), c(res$con.low, rev(res$con.high)), col="#0000ff22"))
+ }
+
+ legend("center", legend = lgd, bty="n");
+
+ }else{ # plot ROC of specific model and save the table for details
+
+ preds <- ROCR::prediction(mSetObj$analSet$ROCtest$pred.cv, mSetObj$analSet$ROCtest$true.cv);
+ auroc <- round(mSetObj$analSet$ROCtest$auc.vec[1],3)
+ auc.ci <- mSetObj$analSet$ROCtest$auc.ci;
+
+ perf <- ROCR::performance(preds, "tpr", "fpr");
+ perf.avg <- ComputeAverageCurve(perf, avg.method);
+ y.all <- perf.avg@y.values[[1]];
+ x.all <- perf.avg@x.values[[1]];
+ # to draw a roc curve line from (0,0)
+ y.all <- c(0.0, y.all);
+ x.all <- c(0.0, x.all);
+
+ lgd <- paste("Area under the curve (AUC) =", auroc, "\n",
+ "95% CI:", auc.ci);
+
+ ROCR::plot(x.all, y.all, type="n", axes=F,
+ xlim=c(0,1), ylim=c(0,1),
+ xlab="1-Specificity (False positive rate)",
+ ylab="Sensitivity (True positive rate)"
+ );
+
+ box()
+ axis(side=2)
+ lab.at <- seq(0, 1, 0.2);
+ grid.at <- seq(0, 1, 0.1);
+ lab.labels <- lab.at
+ axis(side=1, at=lab.at, labels=as.graphicsAnnot(sprintf( "%.1f", lab.labels)));
+ abline(v=grid.at, lty=3, col="lightgrey");
+ abline(h=grid.at, lty=3, col="lightgrey");
+ lines(x.all, y.all, type="l", lwd=2, col="blue");
+
+ if(show.conf){
+ res <- ComputeHighLow(perf);
+ # to draw a roc curve line from (0,0)
+ # suppressWarnings(polygon(c(x.all, rev(x.all)), c(res$con.low, rev(res$con.high)), col="#0000ff22"))
+ suppressWarnings(polygon(c(x.all, rev(x.all)), c(c(0,res$con.low), c(rev(res$con.high),0)), col="#0000ff22"))
+ }
+ if(show.holdout){
+
+ roc.obj <- pROC::roc(mSetObj$dataSet$test.cls, mSetObj$analSet$ROCtest$test.res, percent = F);
+ test.x <- 1-roc.obj$spec;
+ test.y <- roc.obj$sens;
+
+ lbls <- c("Type", "CV","Holdout");
+ lbls <- sprintf("%-10s",lbls);
+
+ test.auc <- round(roc.obj$auc[[1]],3);
+ aucs <- c("AUC", auroc, test.auc);
+
+ lgd <- paste(lbls, aucs, sep="");
+ lines(test.x, test.y, type="l", lwd=2, col="magenta");
+ legend("bottomright", legend = lgd, pch=c(NA, 15, 15), col=c(NA, "blue", "magenta"));
+ }else{
+ legend("center", legend = lgd, bty="n");
+ }
+ }
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+#'Plot ROC for the ROC Curve Based Model Creation and Evaluation module
+#'@description Plot the ROC curve of the biomarker model created using a user-selected subset of features.
+#'Pred and auroc are lists containing predictions and labels from different cross-validations.
+#'@usage PlotROCTest(mSetObj=NA, imgName, format="png", dpi=72, mdl.inx, avg.method, show.conf, show.holdout, focus="fpr", cutoff = 1.0)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", of "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param mdl.inx Model index, 0 means to compare all models, input 1-6 to plot a ROC curve for one of the top six models
+#'@param avg.method Input the method to compute the average ROC curve, either "threshold", "vertical" or "horizontal"
+#'@param show.conf Logical, if 1, show confidence interval, if 0 do not show
+#'@param show.holdout Logical, if 1, show the ROC curve for hold-out validation, if 0 do not show
+#'@param focus "fpr"
+#'@param cutoff Input the threshold to limit the calculation of the ROC curve, the number must be between 0 and 1.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+PlotROCTest<-function(mSetObj=NA, imgName, format="png", dpi=72, mdl.inx, avg.method, show.conf, show.holdout, focus="fpr", cutoff = 1.0){
+
+ mSetObj <- .get.mSet(mSetObj);
+ anal.mode <- mSetObj$analSet$mode;
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ w <- 8; h <- 8;
+ mSetObj$imgSet$roc.testcurve.plot <- imgName;
+ mSetObj$imgSet$roc.testcurve.name <- mdl.inx
+ mSetObj$imgSet$roc.testcurve.method <- avg.method
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+
+ op <- par(mar=c(5,4,3,3));
+
+ if(anal.mode=="explore" && mdl.inx == 0){ # compare all models
+ preds <- mSetObj$analSet$ROCtest$pred.list;
+ auroc <- mSetObj$analSet$ROCtest$auc.vec;
+ perf <- ROCR::performance(preds[[1]], "tpr", "fpr");
+ perf.avg <- ComputeAverageCurve(perf, avg.method);
+
+ cols <- (1:length(preds))+1;
+ ROCR::plot(perf.avg@x.values[[1]], perf.avg@y.values[[1]], type="n", axes=F,
+ xlim=c(0,1), ylim=c(0,1),
+ xlab="1-Specificity (False positive rate)",
+ ylab="Sensitivity (True positive rate)"
+ );
+
+ box()
+ axis(side=2)
+ lab.at <- seq(0, 1, 0.2);
+ grid.at <- seq(0, 1, 0.1);
+ lab.labels <- lab.at
+ axis(side=1, at=lab.at, labels=as.graphicsAnnot(sprintf( "%.1f", lab.labels)));
+ abline(v=grid.at, lty=3, col="lightgrey");
+ abline(h=grid.at, lty=3, col="lightgrey");
+ lines(perf.avg@x.values[[1]], perf.avg@y.values[[1]], col=cols[1]);
+ for(i in 2:length(preds)){
+ perf <- ROCR::performance(preds[[i]], "tpr", "fpr");
+ avg <- ComputeAverageCurve(perf, avg.method);
+ lines(avg@x.values[[1]], avg@y.values[[1]], col=cols[i]);
+ }
+
+ best.inx <- which.max(auroc);
+
+ # now add and format legends to the bottom right corner
+ feats <- c("Var.", names(preds));
+ feats <- substr(feats, 1, 8);
+ feats <- sprintf("%-5s", feats);
+
+ vals <- c("AUC", round(auroc, 3));
+
+ vals <- sprintf("%-8s", vals);
+
+ cis <- mSetObj$analSet$multiROC$auc.ci;
+ cis <- c("CI", cis);
+ legends <- paste(feats, vals, cis, sep="");
+
+ pch <- c(NA, rep(15, length(preds)));
+ cols <- c(NA, cols);
+
+ legend("bottomright", legend = legends, pch=15, col=cols);
+
+ }else if(mdl.inx > 0 && anal.mode=="explore"){
+
+ preds <- ROCR::prediction(mSetObj$analSet$ROCtest$pred.cv[[mdl.inx]], mSetObj$analSet$ROCtest$true.cv);
+ auroc <- round(mSetObj$analSet$ROCtest$auc.vec[mdl.inx],3);
+ auc.ci <- mSetObj$analSet$ROCtest$auc.ci[mdl.inx];
+ perf <- ROCR::performance(preds, "tpr", "fpr");
+ perf.avg <- ComputeAverageCurve(perf, avg.method);
+ y.all <- perf.avg@y.values[[1]];
+ x.all <- perf.avg@x.values[[1]];
+ lgd <- paste("Area under the curve (AUC) =", auroc, "\n",
+ "95% CI:", auc.ci);
+
+ ROCR::plot(x.all, y.all, type="n", axes=F,
+ xlim=c(0,1), ylim=c(0,1),
+ xlab="1-Specificity (False positive rate)",
+ ylab="Sensitivity (True positive rate)"
+ );
+
+ box()
+ axis(side=2)
+ lab.at <- seq(0, 1, 0.2);
+ grid.at <- seq(0, 1, 0.1);
+ lab.labels <- lab.at
+ axis(side=1, at=lab.at, labels=as.graphicsAnnot(sprintf( "%.1f", lab.labels)));
+ abline(v=grid.at, lty=3, col="lightgrey");
+ abline(h=grid.at, lty=3, col="lightgrey");
+ lines(x.all, y.all, type="l", lwd=2, col="blue");
+
+ if(show.conf){
+ res <- ComputeHighLow(perf);
+ suppressWarnings(polygon(c(x.all, rev(x.all)), c(res$con.low, rev(res$con.high)), col="#0000ff22"))
+ }
+
+ legend("center", legend = lgd, bty="n");
+
+ }else{ # plot ROC of specific model and save the table for details
+
+ preds <- ROCR::prediction(mSetObj$analSet$ROCtest$pred.cv, mSetObj$analSet$ROCtest$true.cv);
+ auroc <- round(mSetObj$analSet$ROCtest$auc.vec[1],3)
+ auc.ci <- mSetObj$analSet$ROCtest$auc.ci;
+
+ perf <- ROCR::performance(preds, "tpr", "fpr");
+ perf.avg <- ComputeAverageCurve(perf, avg.method);
+ y.all <- perf.avg@y.values[[1]];
+ x.all <- perf.avg@x.values[[1]];
+ # to draw a roc curve line from (0,0)
+ y.all <- c(0.0, y.all);
+ x.all <- c(0.0, x.all);
+
+ lgd <- paste("Area under the curve (AUC) =", auroc, "\n",
+ "95% CI:", auc.ci);
+
+ ROCR::plot(x.all, y.all, type="n", axes=F,
+ xlim=c(0,1), ylim=c(0,1),
+ xlab="1-Specificity (False positive rate)",
+ ylab="Sensitivity (True positive rate)"
+ );
+
+ box()
+ axis(side=2)
+ lab.at <- seq(0, 1, 0.2);
+ grid.at <- seq(0, 1, 0.1);
+ lab.labels <- lab.at
+ axis(side=1, at=lab.at, labels=as.graphicsAnnot(sprintf( "%.1f", lab.labels)));
+ abline(v=grid.at, lty=3, col="lightgrey");
+ abline(h=grid.at, lty=3, col="lightgrey");
+ lines(x.all, y.all, type="l", lwd=2, col="blue");
+
+ if(show.conf){
+ res <- ComputeHighLow(perf);
+ # to draw a roc curve line from (0,0)
+ # suppressWarnings(polygon(c(x.all, rev(x.all)), c(res$con.low, rev(res$con.high)), col="#0000ff22"))
+ suppressWarnings(polygon(c(x.all, rev(x.all)), c(c(0,res$con.low), c(rev(res$con.high),0)), col="#0000ff22"))
+ }
+ if(show.holdout){
+
+ roc.obj <- pROC::roc(mSetObj$dataSet$test.cls, mSetObj$analSet$ROCtest$test.res, percent = F);
+ test.x <- 1-roc.obj$spec;
+ test.y <- roc.obj$sens;
+
+ lbls <- c("Type", "CV","Holdout");
+ lbls <- sprintf("%-10s",lbls);
+
+ test.auc <- round(roc.obj$auc[[1]],3);
+ aucs <- c("AUC", auroc, test.auc);
+
+ lgd <- paste(lbls, aucs, sep="");
+ lines(test.x, test.y, type="l", lwd=2, col="magenta");
+ legend("bottomright", legend = lgd, pch=c(NA, 15, 15), col=c(NA, "blue", "magenta"));
+ }else{
+ legend("center", legend = lgd, bty="n");
+ }
+ }
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+#'Plot classification performance using different features for Multi-Biomarker
+#'@description Plot of the accuracy of classification with an increasing number of features.
+#'@usage PlotAccuracy(mSetObj=NA, imgName, format="png", dpi=72)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", of "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+PlotAccuracy<-function(mSetObj=NA, imgName, format="png", dpi=72){
+
+ mSetObj <- .get.mSet(mSetObj);
+ anal.mode <- mSetObj$analSet$mode;
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ w <- 9; h <- 7;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+
+ if(is.null(mSetObj$analSet$multiROC$accu.mat)){
+ accu.mat <- mSet$analSet$ROCtest$accu.mat;
+ }else{
+ accu.mat <- mSetObj$analSet$multiROC$accu.mat;
+ }
+
+ mn.accu <- apply(accu.mat, 2, mean);
+ ylabl <- 'Predictive Accuracy';
+ ylim <- c(0,1);
+ title <- 'Predictive accuracies with different features';
+ txt.lbls <- paste(100*round(mn.accu,3),'%');
+
+ matplot(t(accu.mat),type='l', lty=2, col="grey", xlab='Number of features',ylab=ylabl, ylim=ylim,
+ axes=F,main=title);
+
+ lines(1:ncol(accu.mat), mn.accu, lwd=2);
+ points(mn.accu, pch=19, col=ifelse(1:length(mn.accu)==which.max(mn.accu),"red","blue"));
+ text(mn.accu,labels=txt.lbls, adj=c(-0.3, -0.5), srt=45, xpd=T)
+ axis(2);
+
+ lbls <- colnames(accu.mat);
+ axis(1, 1:length(mn.accu), labels=lbls);
+
+ mSetObj$imgSet$roc.pred <- imgName;
+
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+#'Plot classification performance using different features for Biomarker Tester
+#'@description Plot of the accuracy of classification with an increasing number of features.
+#'@usage PlotTestAccuracy(mSetObj=NA, imgName, format="png", dpi=72)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", of "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+PlotTestAccuracy<-function(mSetObj=NA, imgName, format="png", dpi=72){
+
+ mSetObj <- .get.mSet(mSetObj);
+ anal.mode <- mSetObj$analSet$mode;
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ w <- 9; h <- 7;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+
+ y.vec <- mSetObj$analSet$ROCtest$accu.mat[1,];
+ ylim.ext <- GetExtendRange (y.vec, 12); # first increase ylim by 1/12
+ boxplot(y.vec, col="#0000ff22", ylim=ylim.ext, outline=FALSE, boxwex=c(0.5, 0.5), ylab="Predictive Accuracy");
+ stripchart(t(mSetObj$analSet$ROCtest$accu.mat), method = "jitter", vertical=T, add = T, pch=19);
+
+ accu.info <- paste ("The average accuracy based on 100 cross validations is", round(mean(y.vec), 3));
+
+ mSetObj$imgSet$roc.testpred <- imgName;
+
+ if(!is.null(mSetObj$dataSet$test.cls)){
+ test.pred <- ifelse(mSetObj$analSet$ROCtest$test.res > 0.5, 1, 0);
+ test.cls <- as.numeric(mSetObj$dataSet$test.cls)-1;
+
+ hit <- sum(test.pred == test.cls);
+ percent <- round(hit/length(test.cls), 3);
+ accu.info <- paste(accu.info, ". The accuracy for hold out data prediction is ", percent,
+ "(", hit, "/", length(test.cls), ").", sep="");
+ }
+
+ mSetObj$analSet$ROCtest$accu.info <- accu.info;
+
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+#'Plot selected compounds by their percentage frequency
+#'@description Plot the important variables of single biomarker model ranked by order of importance
+#'@usage PlotImpVars(mSetObj=NA, imgName, format="png", dpi=72, mdl.inx, measure = "freq", feat.num = 15)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param imgName Input a name for the plot
+#'@param format elect the image format, "png", of "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param mdl.inx Model index, -1 selects the model with the best AUC, input 1-6 to view the important features of one of the top six models
+#'@param measure Choose to rank features by the frequency of being selected "freq", or the
+#'mean importance measure "mean"
+#'@param feat.num Input the number of features to include in the plot, by default it is 15.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+PlotImpVars <- function(mSetObj=NA, imgName, format="png", dpi=72, mdl.inx, measure = "freq", feat.num = 15){
+
+ mSetObj <- .get.mSet(mSetObj);
+ anal.mode <- mSetObj$analSet$mode;
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ w <- 8; h <- 8;
+ mSetObj$imgSet$roc.imp.plot <- imgName;
+ mSetObj$imgSet$roc.imp.name <- mdl.inx
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+
+ data <- mSetObj$dataSet$norm;
+ cls <- mSetObj$dataSet$cls;
+ op <- par(mar=c(6,10,3,7));
+
+ if(anal.mode == "explore"){
+ if(mdl.inx == -1){
+ mdl.inx <- mSetObj$analSet$multiROC$best.model.inx;
+ }
+ imp.mat <- GetImpFeatureMat(mSetObj, mSetObj$analSet$multiROC$imp.cv, mSetObj$analSet$multiROC$test.feats[mdl.inx]);
+ }else{
+ imp.mat <- GetImpFeatureMat(mSetObj, mSetObj$analSet$multiROC$imp.cv, null);
+ }
+
+ if(measure=="freq"){
+ imp.vec <- imp.mat[,1];
+ xlbl <- "Selected Frequency (%)";
+ }else{ # default sort by freq, need to reorder
+ imp.vec <- sort(imp.mat[,2], decreasing=T);
+ xlbl <- "Average Importance";
+ }
+ hit.nms <- rev(names(imp.vec)[names(imp.vec) %in% colnames(data)]);
+ data <- data[, hit.nms];
+
+ # note, tapply can only be applied to a vector, we need
+ # to combine with apply in order to used on a data frame
+ mds <- apply(data, 2,
+ function(x){
+ tapply(x, cls, median);
+ });
+
+ lowhigh <- apply(mds, 2,
+ function(x){
+ ifelse(rank(x)==1, "Low", "High")
+ });
+ lowhigh <- t(lowhigh);
+ rownames(lowhigh) <- names(imp.vec);
+ colnames(lowhigh) <- levels(cls);
+ mSetObj$analSet$multiROC$lowhigh <- lowhigh;
+
+ temp.dat <- data.frame(imp.mat, lowhigh);
+ colnames(temp.dat) <- c(colnames(imp.mat), levels(cls));
+ fast.write.csv(temp.dat, file="imp_features_cv.csv");
+ temp.dat <- NULL;
+
+ # record the imp.mat for table show
+ mSetObj$analSet$multiROC$imp.mat <- imp.mat;
+
+ var.len <- length(imp.vec);
+
+ if(feat.num <= 0){
+ feat.num = 15;
+ }
+
+ if(feat.num > var.len){
+ feat.num <- var.len;
+ }
+
+ imp.vec<-rev(imp.vec[1:feat.num]);
+
+ nms.orig <- names(imp.vec);
+ vip.nms <-substr(nms.orig, 1, 20);
+ names(imp.vec) <- NULL;
+
+ xlim.ext <- GetExtendRange(imp.vec, 12);
+ dotchart(imp.vec, bg="blue", xlab= xlbl, xlim=xlim.ext);
+
+ mtext(side=2, at=1:feat.num, vip.nms, las=2, line=1)
+ names(imp.vec) <- nms.orig;
+
+ axis.lims <- par("usr"); # x1, x2, y1 ,y2
+
+ # get character width
+ shift <- 2*par("cxy")[1];
+ lgd.x <- axis.lims[2] + shift;
+
+ x <- rep(lgd.x, feat.num);
+ y <- 1:feat.num;
+
+ par(xpd=T);
+
+ # now synchronize lowhigh with imp.vec
+ lowhigh <- mSetObj$analSet$multiROC$lowhigh[feat.num:1,];
+
+ nc <- ncol(lowhigh);
+ col <- colorRampPalette(RColorBrewer::brewer.pal(10, "RdYlBu"))(nc);
+
+ # calculate background
+ bg <- matrix("", nrow(lowhigh), nc);
+ for (m in 1:nrow(lowhigh)){
+ bg[m,] <- ifelse(lowhigh[m,]=="High", col[1], col[2]);
+ }
+
+ cls.lbl <- levels(cls);
+
+ for (n in 1:ncol(lowhigh)){
+ points(x,y, bty="n", pch=22, bg=bg[,n], cex=3);
+ # now add label
+ text(x[1], axis.lims[4], cls.lbl[n], srt=45, adj=c(0.2,0.5));
+ # shift x, note, this is good for current size
+ x <- x + shift/1.25;
+ }
+
+ # now add color key, padding with more intermediate colors for contiuous band
+ col <- colorRampPalette(RColorBrewer::brewer.pal(10, "RdYlBu"))(20)
+ nc <- length(col);
+ x <- rep(x[1] + shift, nc);
+
+ shifty <- (axis.lims[4]-axis.lims[3])/3;
+ starty <- axis.lims[3] + shifty;
+ endy <- axis.lims[3] + 2*shifty;
+ y <- seq(from = starty, to = endy, length = nc);
+
+ points(x,y, bty="n", pch=15, col=rev(col), cex=2);
+
+ text(x[1], endy+shifty/8, "High");
+ text(x[1], starty-shifty/8, "Low");
+ par(op);
+ dev.off();
+
+ return(.set.mSet(mSetObj));
+
+}
+
+#'Perform permutation tests only for ROC Tester
+#'@description Perform permutation tests for the ROC Curve Based Model Creation and Evaluation module
+#'@usage Perform.Permut(mSetObj=NA, perf.measure, perm.num, propTraining = 2/3)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param perf.measure Input the performance measure to rate the performance of the model, either the area
+#'under the ROC curve ("auroc") or the predictive accuracy ("accu")
+#'@param perm.num Input the number of permutations to perform
+#'@param propTraining Numeric, input the fraction of samples to set aside for training. Default is set to 2/3.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+Perform.Permut<-function(mSetObj=NA, perf.measure, perm.num, propTraining = 2/3){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ cvRuns = perm.num;
+ propTraining = propTraining
+
+ cls <- mSetObj$dataSet$cls;
+ datmat <- mSetObj$dataSet$norm;
+ clsMethod <- mSetObj$analMethod;
+
+ splitMat <- GetTrainTestSplitMat(cls, propTraining, cvRuns);
+ trainInx <- splitMat$training.mat;
+ testInx <- splitMat$testing.mat;
+
+ # now, do the permutation
+ perf.outp <- actualCls <- vector(length = cvRuns, mode = "list");
+ # for (irun in 1:cvRuns){
+ irun <- 1;
+ while(irun < cvRuns){
+ cls <- cls[order(runif(length(cls)))];
+ trainingSampleRun <- trainInx[irun, ]
+ testSampleRun <- testInx[irun, ];
+ y.in <- cls[trainingSampleRun];
+ # make sure the y.in contain only one group
+ if(length(unique(as.numeric(y.in))) > 1){
+ y.out <- cls[testSampleRun];
+ actualCls[[irun]] <- as.numeric(y.out);
+ perf.outp[[irun]] <- Get.pred(datmat[trainingSampleRun,], y.in,
+ datmat[testSampleRun, ], y.out, clsMethod);
+ irun <- irun + 1;
+ }else{
+ print("redo....");
+ }
+ }
+
+ # get the AUROC for permuted data
+ pred <- ROCR::prediction(perf.outp, actualCls);
+ perf.obj <- ROCR::performance(pred, "tpr", "fpr");
+ aucs <- unlist(slot(ROCR::performance(pred, "auc"), "y.values"));
+ accs <- unlist(slot(ROCR::performance(pred, "acc"), "y.values"));
+
+ # now, insert the average value of the original performance
+ accs <- c(mean(mSetObj$analSet$ROCtest$accu.mat[1,]), accs);
+ aucs <- c(mean(mSetObj$analSet$ROCtest$auc.vec), aucs);
+ mSetObj$analSet$ROCtest$perm.res <- list(perf.measure=perf.measure, perf.obj=perf.obj, auc.vec=aucs, acc.vec=accs);
+ return(.set.mSet(mSetObj));
+}
+
+#'Get predicted class probability
+#'@description Get predicted class probability, used in higher function
+#'@param x.train Training X
+#'@param y.train Training Y
+#'@param x.test Test X
+#'@param y.test Test Y
+#'@param clsMethod Method to predict class, by default it is PLS
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+Get.pred <- function(x.train, y.train, x.test, y.test, clsMethod="pls"){
+
+ # first convert class label to 0/1 so convert prob-> class will be easier
+ y.train <- as.factor(as.numeric(y.train)-1);
+ y.test <- as.factor(as.numeric(y.test)-1);
+
+ # note, we only need prob for class 1, pred can be inferred
+ if (clsMethod == "rf"){
+ model <- randomForest::randomForest(x.train, y.train, ntree=100, importance=F);
+ prob.out <- predict(model, x.test, type="prob")[,"1"];
+ return(prob.out);
+ }else if(clsMethod == "pls"){ # plsda
+ model <- caret::plsda(x.train, y.train, method='oscorespls');
+ prob.out <- predict(model, x.test, type="prob")[,"1",1];
+ return(prob.out);
+ }else{ # svm
+ model <- e1071::svm(x.train, y.train, type = 'C', kernel="linear", probability=TRUE);
+ prob.out <- attr(predict(model, x.test, probability=TRUE), "probabilities")[,"1"];
+ return(prob.out);
+ }
+}
+
+#'Prepare report for permutation tests
+#'@description Function to prepare a report for permutation tests, used in higher functions
+#'@param perm.vec Input permutation vector
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PreparePermResult<-function(perm.vec){
+
+ # check for infinite since with group variance could be zero for perfect classification
+ inf.found = TRUE;
+ if(sum(is.finite(perm.vec))==length(perm.vec)){
+ inf.found = FALSE;
+ }else {
+ if(sum(is.finite(perm.vec))==0){ # all are infinite, give a random number 10
+ perm.vec<-rep(10, length(perm.vec));
+ }else{ # if not all inf, replace with the 10 fold of non-inf values
+ perm.vec[!is.finite(perm.vec)]<-10*max(perm.vec[is.finite(perm.vec)]);
+ }
+ }
+
+ better.hits <- sum(perm.vec[-1]>=perm.vec[1]);
+ num <- length(perm.vec);
+ if(better.hits == 0) {
+ p <- paste("p <", 1/num);
+ }else{
+ p <- better.hits/num;
+ p <- paste("p =", signif(p, digits=5));
+ }
+
+ list(permut.p = p,
+ permut.inf = F,
+ permut = perm.vec);
+}
+
+#'Plot results of permutation tests
+#'@description Plot results of permutation tests
+#'@usage Plot.Permutation(mSetObj=NA, imgName, format="png", dpi=72)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param imgName Input a name for the plot
+#'@param format elect the image format, "png", of "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+Plot.Permutation<-function(mSetObj=NA, imgName, format="png", dpi=72){
+
+ mSetObj <- .get.mSet(mSetObj);
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ w <- 8; h <- 8;
+ mSetObj$imgSet$roc.perm.plot <- imgName;
+
+ if(mSetObj$analSet$ROCtest$perm.res$perf.measure == "auroc"){
+ mSetObj$imgSet$roc.perm.method <- "auroc"
+ }else{
+ mSetObj$imgSet$roc.perm.method <- "predictive accuracy"
+ }
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+
+ if(mSetObj$analSet$ROCtest$perm.res$perf.measure == "auroc"){
+ ROCR::plot(mSetObj$analSet$ROCtest$perm.res$perf.obj, col="grey", lwd=1, lty=2,
+ xlab="1-Specificity (False Positive rate)",
+ ylab="Sensitivity (True Positive rate)");
+
+ # now add the original ROC
+
+ preds <- ROCR::prediction(mSetObj$analSet$ROCtest$pred.cv, mSetObj$analSet$ROCtest$true.cv);
+ auroc <- round(mSetObj$analSet$ROCtest$auc.vec[1],3)
+ perf <- ROCR::performance(preds, "tpr", "fpr");
+ # need to replace Inf with 1
+ alpha.vals <- perf@alpha.values;
+ perf@alpha.values <- lapply(alpha.vals, function(x){
+ x[x==Inf] <- 1;
+ x[x==-Inf] <- 0;
+ x
+ });
+
+
+ ROCR::plot(perf,lwd=2,avg="threshold", col="blue", add=T);
+
+ # calculate p value
+ perm.vec <- mSetObj$analSet$ROCtest$perm.res$auc.vec;
+ better.hits <- sum(perm.vec[-1]>=perm.vec[1]);
+ num <- length(perm.vec);
+ if(better.hits == 0) {
+ p <- paste("p <", 1/num);
+ }else{
+ p <- better.hits/num;
+ p <- paste("p =", signif(p, digits=5));
+ }
+ legend("center", legend = paste('Empirical p-value: ', p), bty="n", cex=1.5);
+ }else{ # accuracies
+ perms <- PreparePermResult(mSetObj$analSet$ROCtest$perm.res$acc.vec);
+ perm.vec <- perms$permut;
+ perm.p <- perms$permut.p;
+
+ op<-par(mar=c(5,5,2,4));
+
+ xlim.ext <- GetExtendRange (perm.vec, 10);
+ hst <- hist(perm.vec[-1], breaks = "FD", freq=T, ylab="Frequency", xlim=xlim.ext, xaxt="n", xlab= 'Permutation test statistics', col="lightblue", main="");
+ axis(1);
+
+ # add the indicator using original label
+ h <- max(hst$counts)
+ arrows(perm.vec[1], h/5, perm.vec[1], 0, col="red", lwd=2);
+ text(perm.vec[1], h/3.5, paste('Observed \n statistic \n', perm.p), xpd=T);
+ par(op);
+ }
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+#'Calculate partial area under ROC curve
+#'@description Calculate partial area under ROC curve
+#'@param x Input X
+#'@param y Input Y
+#'@param focus Method
+#'@param cutoff Numeric
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+Get.pAUC <- function(x, y, focus, cutoff) {
+
+ finite.bool <- is.finite(x) & is.finite(y);
+ if(focus == "fpr"){
+ x <- x[finite.bool];
+ y <- y[finite.bool];
+ }else{
+ x <- rev(1-y[finite.bool]);
+ y <- rev(1-x[finite.bool]);
+ cutoff <- 1-cutoff;
+ }
+ if (length(x) < 2) {
+ return (NA);
+ }
+
+ if (cutoff < 1) {
+ ind <- max(which(x <= cutoff));
+ stop <- try(approxfun(x[ind:(ind+1)], y[ind:(ind+1)])(cutoff));
+ if(class(stop) == "try-error"){
+ return(NA);
+ }else{
+ x <- c(x[1:ind], cutoff);
+ y <- c(y[1:ind], stop);
+ }
+ }
+
+ auc <- 0
+ for (i in 2:length(x)) {
+ auc <- auc + 0.5 * (x[i] - x[i-1]) * (y[i] + y[i-1])
+ }
+ return(round(auc,3));
+}
+
+#'Compute average ROC curve
+#'@description Compute the average ROC curve
+#'@param perf Input the average
+#'@param avg.method Input the name of the method to compute the average curve
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+ComputeAverageCurve<-function(perf, avg.method){
+ # now get the average curve
+ perf.avg = perf;
+ if(avg.method == "vertical"){
+ x.values <- seq(min(unlist(perf@x.values)), max(unlist(perf@x.values)),
+ length=max( sapply(perf@x.values, length)))
+ for (i in 1:length(perf@y.values)) {
+ perf.avg@y.values[[i]] <-
+ approxfun(perf@x.values[[i]], perf@y.values[[i]],
+ ties=mean, rule=2)(x.values)
+ }
+ perf.avg@y.values <- list(rowMeans(data.frame(perf.avg@y.values )))
+ perf.avg@x.values <- list(x.values)
+ }else if(avg.method == "horizontal"){
+ y.values <- seq(min(unlist(perf@y.values)), max(unlist(perf@y.values)),
+ length=max(sapply(perf@y.values, length)))
+ for (i in 1:length(perf@x.values)) {
+ perf.avg@x.values[[i]] <- approxfun(perf@y.values[[i]],
+ perf@x.values[[i]],
+ ties=mean, rule=2)(y.values)
+ }
+ perf.avg@x.values <- list(rowMeans( data.frame( perf.avg@x.values )));
+ perf.avg@y.values <- list(y.values);
+ }else{ # threshold
+ all.alphas <- unlist(perf@alpha.values);
+ min.alpha <- min(all.alphas);
+ if(min.alpha == -Inf){
+ min.alpha <- 0;
+ }
+ max.alpha <- max(all.alphas);
+ if(max.alpha == Inf){
+ max.alpha <- 1.0;
+ }
+
+ alpha.values <- rev(seq(min.alpha, max.alpha,length=max(sapply(perf@alpha.values, length))));
+ perf.sampled <- perf;
+ for (i in 1:length(perf.sampled@y.values)) {
+ perf.sampled@x.values[[i]] <-
+ approxfun(perf@alpha.values[[i]],perf@x.values[[i]],
+ rule=2, ties=mean)(alpha.values)
+ perf.sampled@y.values[[i]] <-
+ approxfun(perf@alpha.values[[i]], perf@y.values[[i]],
+ rule=2, ties=mean)(alpha.values)
+ }
+ ## compute average curve
+ perf.avg <- perf.sampled
+ perf.avg@x.values <- list(rowMeans(data.frame(perf.avg@x.values)))
+ perf.avg@y.values <- list(rowMeans(data.frame(perf.avg@y.values)))
+ }
+ return(perf.avg);
+}
+
+#'Compute the 95 percent interval for threshold ROC
+#'@description Computes the 95 percent interval only for the y-axis.
+#'Utility function, called upon by higher functions
+#'@param perf Input the performance
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+ComputeHighLow <- function(perf){
+ all.alphas <- unlist(perf@alpha.values);
+ min.alpha <- min(all.alphas);
+ if(min.alpha == -Inf){
+ min.alpha <- 0;
+ }
+ max.alpha <- max(all.alphas);
+ if(max.alpha == Inf){
+ max.alpha <- 1.0;
+ }
+
+ alpha.values <- rev(seq(min.alpha, max.alpha,length=max(sapply(perf@alpha.values, length))));
+ perf.sampled <- perf;
+ for (i in 1:length(perf.sampled@y.values)) {
+ perf.sampled@x.values[[i]] <-
+ approxfun(perf@alpha.values[[i]],perf@x.values[[i]],
+ rule=2, ties=mean)(alpha.values)
+ perf.sampled@y.values[[i]] <-
+ approxfun(perf@alpha.values[[i]], perf@y.values[[i]],
+ rule=2, ties=mean)(alpha.values)
+ }
+ ## compute average curve
+ y.data <- data.frame(perf.sampled@y.values)
+ con.low <- apply(y.data, 1, quantile, 0.05);
+ con.high <- apply(y.data, 1, quantile, 0.95);
+ res <- list(
+ con.low = con.low,
+ con.high = con.high
+ );
+ return (res);
+}
+
+#'Prepare data for ROC analysis
+#'@description Prepare data for ROC analysis
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PrepareROCData <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(is.null(mSetObj$dataSet$norm.all)){
+ mSetObj$dataSet$norm.all <- mSetObj$dataSet$norm;
+ mSetObj$dataSet$cls.all<- mSetObj$dataSet$cls;
+ }
+
+ new.inx <- is.na(mSetObj$dataSet$cls.all) | mSetObj$dataSet$cls.all == "";
+ if(sum(new.inx) > 0){
+ mSetObj$dataSet$new.samples <- TRUE;
+ mSetObj$dataSet$new.data <- mSetObj$dataSet$norm.all[new.inx, ,drop=F];
+ mSetObj$dataSet$norm <- mSetObj$dataSet$norm.all[!new.inx, ,drop=F];
+ mSetObj$dataSet$cls <- factor(mSetObj$dataSet$cls.all[!new.inx])
+ }else{
+ mSetObj$dataSet$new.samples <- FALSE;
+ mSetObj$dataSet$new.data <- NULL;
+ mSetObj$dataSet$norm <- mSetObj$dataSet$norm.all;
+ mSetObj$dataSet$cls <- mSetObj$dataSet$cls.all;
+ }
+ return(.set.mSet(mSetObj));
+}
+
+#'Set custom data
+#'@description The "selected.cmpds" should be for extraction
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param selected.cmpds Input the vector containing the compounds
+#'@param selected.smpls Input the vector containing the samples
+#'@export
+#'
+SetCustomData <- function(mSetObj=NA, selected.cmpds, selected.smpls){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ data.norm.orig <- mSetObj$dataSet$norm;
+ cls <- mSetObj$dataSet$cls;
+
+ if(length(selected.cmpds) > 0){
+ data.norm <- data.norm.orig[, selected.cmpds, drop=F];
+ if(!is.null(mSetObj$dataSet$new.data)){
+ mSetObj$dataSet$new.data <- mSetObj$dataSet$new.data[, selected.cmpds, drop=F];
+ }
+ }
+
+ if(length(selected.smpls) > 0){
+ hit.inx <- rownames(data.norm) %in% selected.smpls;
+ mSetObj$dataSet$test.data <- data.norm[hit.inx, ,drop=F];
+ mSetObj$dataSet$test.cls <- cls[hit.inx];
+ data.norm <- data.norm[!hit.inx, ,drop=F];
+ cls <- cls[!hit.inx];
+ }else{
+ mSetObj$dataSet$test.data <- NULL;
+ mSetObj$dataSet$test.cls <- NULL;
+ }
+
+ mSetObj$dataSet$norm.orig <- data.norm.orig;
+ mSetObj$dataSet$norm <- data.norm;
+ mSetObj$dataSet$cls <- cls;
+ return(.set.mSet(mSetObj));
+}
+
+#'ROC with CI for AUC
+#'@description ROC with CI for AUC
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param feat.nm Input the feature name
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PrepareROCDetails <- function(mSetObj=NA, feat.nm){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ x <- mSetObj$dataSet$norm[, feat.nm];
+ y <- mSetObj$dataSet$cls;
+
+ roc.res <- pROC::roc(y, x, ci = T, of = "auc");
+
+ roc.mat <- as.matrix(data.frame(
+ "Cut.Offs" = roc.res$thresholds,
+ "Sensitivity" = roc.res$sensitivities,
+ "Specificity" = roc.res$specificities,
+ "Sens.Spec." = roc.res$sensitivities + roc.res$specificities,
+ "LRP" = roc.res$sensitivities/(1-roc.res$specificities),
+ "LRN" = (1-roc.res$sensitivities)/roc.res$specificities
+ ));
+
+ filename <- paste(gsub("\\/", "_", feat.nm), "_roc.csv", sep="");
+ fast.write.csv(signif(roc.mat,4), file=filename, row.names=F);
+ # need to clean NA/Inf/-Inf
+ #analSet$roc.mat <- ClearNumerics(roc.mat);
+ mSetObj$analSet$roc.mat <- signif(roc.mat, 6);
+ mSetObj$analSet$roc.obj <- roc.res;
+
+ current.feat.nm <<- feat.nm;
+
+ return(.set.mSet(mSetObj));
+
+ #PNG.PlotUnivROC.CI(imgName);
+}
+
+#'Plot detailed ROC
+#'@description Plot detailed ROC
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param imgName Input a name for the plot
+#'@param thresh Input the threshold
+#'@param sp Specificity
+#'@param se Sensitivity
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param format Select the image format, "png", or "pdf".
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotDetailROC <- function(mSetObj=NA, imgName, thresh, sp, se, dpi=72, format="png"){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ imgName = paste(imgName, "_dpi", dpi, ".", format, sep="");
+
+ roc.obj <- mSetObj$analSet$roc.obj;
+
+ w <- h <- 6;
+ mSetObj$imgSet$roc.univ <- imgName;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ par(oma = c(0,0,1,0));
+ par(mar=c(4,4,4,4) + .1);
+
+ pROC::plot.roc(roc.obj, print.auc=F, legacy.axes=TRUE, col="navy", grid=T,
+ xlab = "False positive rate", ylab="True positive rate",
+ auc.polygon=TRUE, auc.polygon.col="#0000ff22", main=current.feat.nm);
+
+ points(sp, se, cex=1.8, col="red");
+
+ dev.off();
+ return(.set.mSet(mSetObj));
+
+}
+
+##############################################
+##############################################
+########## Utilities for web-server ##########
+##############################################
+##############################################
+#'Export biomarker accuracy information
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@export
+GetAccuracyInfo<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$analSet$ROCtest$accu.info);
+}
+
+#'Get the text description of a recursive partitioning (rpart) result
+#'@description x must be an rpart object
+#'@param x An Rpart object
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+Get.rpart.summary <- function(x) {
+ frame <- x$frame
+ ylevel <- attr(x, "ylevels")
+ node <- as.numeric(row.names(frame))
+
+ depth <- floor(log(node, base = 2) + 1e-7)
+ depth <- depth - min(depth) # doesn't seem to need as.vector.
+
+ indent <- paste(rep(" ", 5 * 32L), collapse = "")
+
+ if(length(node) > 1L) {
+ indent <- substring(indent, 1L, 5 * seq(depth))
+ indent <- paste(c("", indent[depth]), format(node), ")", sep = "")
+ } else {
+ indent <- paste(format(node), ")", sep = "")
+ }
+ tfun <- (x$functions)$print
+ if (!is.null(tfun)) {
+ if (is.null(frame$yval2)){
+ yval <- tfun(frame$yval, ylevel, 4)
+ }else{
+ yval <- tfun(frame$yval2, ylevel, 4)
+ }
+ }else{
+ yval <- format(signif(frame$yval, digits = 4))
+ }
+ term <- rep(" ", length(depth))
+ term[frame$var == "<leaf>"] <- "*"
+ z <- labels(x, digits=4, minlength=0)
+ n <- frame$n
+ z <- paste(indent, z, n, format(signif(frame$dev, digits = 4)),
+ yval, term);
+
+ msg <- NULL;
+ if (x$method=="class"){
+ msg <- "node), split, n, loss, yval, (yprob)";
+ }else {
+ msg <- "node), split, n, deviance, yval";
+ }
+ msg <- c(msg, " * denotes terminal node\n");
+ msg <- paste(c(msg, z), collapse="\n");
+ return(msg)
+}
+
+#'Compute data points on the ROC curve
+#'@description perf is the performance object from ROCR
+#'@param perf Performance object from ROCR
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+GetMeanROC<-function(perf){
+ perf@alpha.values <- lapply(perf@alpha.values,
+ function(x) { isfin <- is.finite(x);
+ x[is.infinite(x)] <-
+ (max(x[isfin]) +
+ mean(abs(x[isfin][-1] -
+ x[isfin][-length(x[isfin])])));
+ x } );
+ ## remove samples with x or y not finite
+ for (i in 1:length(perf@x.values)) {
+ ind.bool <- (is.finite(perf@x.values[[i]]) & is.finite(perf@y.values[[i]]))
+
+ if (length(perf@alpha.values)>0){
+ perf@alpha.values[[i]] <- perf@alpha.values[[i]][ind.bool]
+ }
+ perf@x.values[[i]] <- perf@x.values[[i]][ind.bool]
+ perf@y.values[[i]] <- perf@y.values[[i]][ind.bool]
+ }
+
+
+ perf.sampled <- perf;
+ alpha.values <- rev(seq(min(unlist(perf@alpha.values)),
+ max(unlist(perf@alpha.values)),
+ length=max( sapply(perf@alpha.values, length))))
+ for (i in 1:length(perf.sampled@y.values)) {
+ perf.sampled@x.values[[i]] <- approxfun(perf@alpha.values[[i]],perf@x.values[[i]], rule=2, ties=mean)(alpha.values)
+ perf.sampled@y.values[[i]] <- approxfun(perf@alpha.values[[i]], perf@y.values[[i]],rule=2, ties=mean)(alpha.values)
+ }
+
+ ## return the average value
+ return (cbind(alpha.values, rowMeans(data.frame(perf.sampled@x.values)), rowMeans(data.frame(perf.sampled@y.values))));
+}
+
+ContainNewSamples <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ ifelse(mSetObj$dataSet$new.samples, 1, 0);
+}
+
+#'Obtain sample names and their class labels
+#'@description Obtain sample names and their class labels
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+GetNewSampleNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ if(!is.null(mSetObj$dataSet$new.data)){
+ smplInfo <- paste(rownames(mSetObj$dataSet$new.data), collapse="\n");
+ }else{
+ smplInfo <- "No new samples found";
+ }
+ return(smplInfo);
+}
+
+GetNewSampleNameVec <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ rownames(mSetObj$dataSet$new.data);
+}
+
+GetNewSampleProbs <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+ new.res <- mSetObj$analSet$ROCtest$new.res;
+ # new res is the prob for class in level 1,
+ # need to adjust it
+ lvls <- levels(mSetObj$dataSet$cls);
+ grps <- ifelse(mSetObj$analSet$ROCtest$new.res >= 0.5, lvls[2], lvls[1]);
+ new.res <- ifelse(new.res >= 0.5, new.res, 1-new.res);
+ return(round(new.res, 5));
+}
+
+GetNewSampleGrps <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ # need to figure out which is 1 or 0
+ lvls <- levels(mSetObj$dataSet$cls);
+ grps <- ifelse(mSetObj$analSet$ROCtest$new.res >= 0.5, lvls[2], lvls[1]);
+ return(grps);
+}
+
+Get.Fisher <- function(x, fac, var.equal=TRUE) {
+ inx1 <- which(y==levels(y)[1]);
+ inx2 <- which(y==levels(y)[2]);
+ p.value <- apply(as.matrix(x), 2,
+ function(x) {
+ tmp <- try(fisher.test(x[inx1], x[inx2]));
+ if(class(tmp) == "try-error") {
+ return(NA);
+ }else{
+ return(tmp$p.value);
+ }
+ });
+ -log10(p.value);
+}
+
+Get.Fstat <- function(x, fac, var.equal=TRUE) {
+
+ x = t(x);
+ sqr = function(x) x*x;
+ stopifnot(length(fac)==ncol(x), is.factor(fac), is.matrix(x))
+ x <- x[,!is.na(fac), drop=FALSE]
+ fac <- fac[!is.na(fac)]
+
+ ## Number of levels (groups)
+ k <- nlevels(fac)
+
+ ## xm: a nrow(x) x nlevels(fac) matrix with the means of each factor level
+ xm <- matrix(
+ sapply(levels(fac), function(fl) rowMeans(x[,which(fac==fl), drop=FALSE])),
+ nrow = nrow(x),
+ ncol = nlevels(fac))
+
+ ## x1: a matrix of group means, with as many rows as x, columns correspond to groups
+ x1 <- xm[,fac, drop=FALSE]
+
+ ## degree of freedom 1
+ dff <- k - 1
+
+ ## x0: a matrix of same size as x with overall means
+ x0 <- matrix(rowMeans(x), ncol=ncol(x), nrow=nrow(x))
+
+ ## degree of freedom 2
+ dfr <- ncol(x) - dff - 1
+
+ ## mean sum of squares
+ mssf <- rowSums(sqr(x1 - x0)) / dff
+ mssr <- rowSums(sqr( x - x1)) / dfr
+
+ ## F statistic
+ fstat <- mssf/mssr
+ return(fstat)
+}
+
+#'Return ROC corodinates with confidence intervals
+#'@description Return ROC corodinates with confidence intervals
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param fld.nm The kind of input coordinate
+#'@param val The coordinates to look for
+#'@param plot Logical, by default set to TRUE
+#'@param imgNm Input the image name
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+GetROC.coords <- function(mSetObj=NA, fld.nm, val, plot=TRUE, imgNm){
+
+ mSetObj <- .get.mSet(mSetObj);
+ res <- pROC::coords(mSetObj$analSet$roc.obj, val, input=fld.nm, transpose=TRUE);
+
+ sp <- res[2];
+ se <- res[3];
+ res <- round(res, 3);
+
+ mSetObj$analSet$thresh.obj <- NULL;
+ if(fld.nm == "threshold"){
+ ci.s <- pROC::ci.thresholds(mSetObj$analSet$roc.obj, boot.n=100, thresholds=val, progress="none");
+ specs <- round(ci.s$specificity,3);
+ sens <- round(ci.s$sensitivity, 3);
+ res[2] <- paste(res[2], "(", specs[1], "-", specs[3], ")", sep="");
+ res[3] <- paste(res[3], "(", sens[1], "-", sens[3], ")", sep="");
+
+ mSetObj$analSet$thresh.obj <- ci.s;
+
+ # update pos with the thresh obj coords
+ sp <- ci.s$specificity[2];
+ se <- ci.s$sensitivity[2];
+ }
+
+ mythresh <- res[1];
+ if(is.na(res[1])){
+ if(fld.nm == "sensitivity"){
+ fld.vals <- mSetObj$analSet$roc.obj$sensitivities;
+ }else{
+ fld.vals <- mSetObj$analSet$roc.obj$specificities;
+ }
+
+ inx1 <- which.min(abs(fld.vals-val));
+
+ if(inx1 == 1){
+ inxb1 <- inx1;
+ }else{
+ inxb1 <- inx1 - 1;
+ }
+
+ if(inx1 == length(fld.vals)){
+ inxb2 <- inx1;
+ }else{
+ inxb2 <- inx1 + 1;
+ }
+
+ if(fld.vals[inx1] > val){
+ inx2 <-ifelse(fld.vals[inxb1] > val, inxb2, inxb1);
+ }else{
+ inx2 <-ifelse(fld.vals[inxb1] > val, inxb1, inxb2);
+ }
+
+ threshs <- mSetObj$analSet$roc.obj$thresholds;
+
+ if(inx1 == inx2){ # out of the threshod range
+ if(threshs[inx1] > threshs[2]){ #max
+ res[1] <- paste(">",threshs[inx1], sep="");
+ }else{
+ res[1] <- paste("<",threshs[inx1], sep="");
+ }
+ }else{
+ inx.thresh <- c(inx1, inx2)
+ ord.inx <- order(threshs[inx.thresh]);
+ inx.thresh <- inx.thresh[ord.inx];
+ res[1] <- paste(threshs[inx.thresh], collapse="-")
+ }
+ }
+ if(plot){
+ PlotDetailROC(mSetObj, imgNm, mythresh, sp, se);
+ mSetObj$analSet$roc.obj$thresh <- mythresh;
+ }
+ if(.on.public.web){
+ .set.mSet(mSetObj)
+ return(res);
+ }else{
+ return(.set.mSet(mSetObj));
+ }
+}
+
+#'Compute lasso frequency
+#'@description Not part of default, need to perform function
+#'to compute lasso frequency
+#'msg: There are more than 500 variables and n<m
+#'You may wish to restart and set use.Gram=FALSE
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+GetLassoFreqs <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+ if(ncol(mSetObj$dataSet$norm) < 500){
+ lassoFreq <- try(GetROCLassoFreq(mSetObj$dataSet$norm, mSetObj$dataSet$cls));
+ if(class(lassoFreq) == "try-error"){
+ err.msg <<- "Unknown errors occured during computing lasso!";
+ lassoFreq <- rep(0, ncol(mSetObj$dataSet$norm));
+ }
+ }else{
+ err.msg <<- "Too many variables (>500) with small sample size, computing aborted!";
+ lassoFreq <- rep(0, ncol(mSetObj$dataSet$norm));
+ }
+ names(lassoFreq) <- colnames(mSetObj$dataSet$norm);
+ lassoFreq <- sort(lassoFreq, decreasing =TRUE);
+ lassoFreq <<- lassoFreq;
+ return(lassoFreq);
+}
+
+#'Get p-values for ROC
+#'@description ROC p-vaues, used in higher function
+#'@param data Input data
+#'@param cls Input class labels
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+GetROCTtestP <- function(data, cls){
+ if(ncol(data) < 1000){
+ inx1 <- which(cls==levels(cls)[1]);
+ inx2 <- which(cls==levels(cls)[2]);
+ p.value <- apply(as.matrix(data), 2, function(x) {
+ tmp <- try(t.test(x[inx1], x[inx2], paired = F, var.equal = T));
+ if(class(tmp) == "try-error") {
+ return(NA);
+ }else{
+ return(tmp$p.value);
+ }
+ })
+ }else{ # use fast version
+ p.value <- try(genefilter::rowttests(t(as.matrix(data)), cls)$p.value);
+ if(class(p.value) == "try-error") {
+ p.value <- NA;
+ }
+ }
+ return(p.value);
+}
+
+#'Separate data set using k-fold cross validation (CV)
+#'@description Separate data set with k-fold CV, used in higher function
+#'@param groupN Input the size of the group
+#'@param kfold Input the number of cross-validations
+#'@param rseed Input the random seed
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'
+createCVset <- function(groupN, kfold, rseed)
+{
+ set.seed(rseed)
+ idxlist <- sample(1:groupN, size=groupN, replace=FALSE)
+ CVsize <- floor(groupN / kfold)
+ CV.groupIndexes <- vector(mode="list", length=kfold)
+ for (i in 1:kfold) {
+ CV.groupIndexes[i] <- list(idxlist[(1+CVsize*(i-1)):(CVsize*i)])
+ }
+
+ if((groupN %% kfold) > 0) {
+ i<-1
+ while( i <= (groupN %% kfold) ) {
+ CV.groupIndexes[[i]] <- c(CV.groupIndexes[[i]], idxlist[CVsize*kfold + i])
+ i <- i+1
+ }
+ }
+
+ return (CV.groupIndexes)
+}
+
+#'Get p-values from lasso
+#'@description Get p-values from lasso
+#'@param data Input data
+#'@param cls Input class labels
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'
+GetROCLassoFreq <- function(data, cls){
+
+ data <- cbind(cls, data);
+ d.headers <- names(data);
+ names(data) <- c("cls", paste0("V", 1:(ncol(data)-1)));
+
+ inx1 <- which(cls==levels(cls)[1]);
+ inx2 <- which(cls==levels(cls)[2]);
+ data1 <- data[inx1, ];
+ data2 <- data[inx2, ];
+
+ min.n <- ifelse(length(inx1) <= length(inx2), length(inx1), length(inx2));
+ kfold.origin <- ifelse(min.n >= 10, 10, ifelse(min.n >= 5, 5, 0));
+
+ if(kfold.origin > 0) {
+ random.seed <- 10063927;
+ kfold <- kfold.origin;
+ CV.inx1 <- createCVset(length(inx1), kfold, random.seed);
+ CV.inx2 <- createCVset(length(inx2), kfold, random.seed);
+ } else {
+ kfold <- 10;
+ }
+
+ varlist <- NULL;
+ for (i in 1:kfold) {
+ # i<-1
+ if (kfold.origin > 0) {
+ dw1 <- data1[-CV.inx1[[i]], ];
+ dw2 <- data2[-CV.inx2[[i]], ];
+ } else {
+ # resampling if sample size is less than 5
+ CV.inx1 <- sample(inx1, size=length(inx1), replace=TRUE);
+ CV.inx2 <- sample(inx2, size=length(inx2), replace=TRUE);
+ dw1 <- data1[as.character(CV.inx1), ];
+ dw2 <- data2[as.character(CV.inx2), ];
+ }
+
+ dw.all <- rbind(dw1, dw2);
+ #rownames(dw.all) <- c(1:nrow(dw.all))
+
+ # To create a formula for model with large number of independent vars
+ xnam <- names(dw.all)[-1];
+ (fmla <- as.formula(paste("cls ~ ", paste(xnam, collapse= "+"))));
+
+ if (is.numeric(dw.all$cls)) {
+ dw.all$cls <- as.numeric(as.character(dw.all$cls));
+ } else {
+ # label/cls should be integer as 0 and 1
+ dw.all$cls <- as.numeric(dw.all$cls)-1;
+ }
+
+ x <- model.matrix(as.formula(fmla), dw.all)[, -1];
+ o <- lars::lars(x, dw.all$cls, type="lasso", trace=FALSE, intercept=TRUE, normalize=FALSE, use.Gram=FALSE);
+
+ cvfit <- NULL;
+ m <- NULL;
+ tryCatch({
+ cvfit <- lars::cv.lars(x, dw.all$cls, type="lasso", mode="fraction", plot.it=FALSE); ## Cross-Validation
+ m <- ( o$beta[which.min(cvfit$cv),] != 0 );
+ varlist10 <- names(m[m==TRUE]);
+ }, error = function(e) {
+ ## print(e);
+ tryCatch ( {
+ cvfit <- lars::cv.lars(x, dw.all$cls, type="lar", mode="step", plot.it=FALSE);
+ m <- ( o$beta[which.min(cvfit$cv),] != 0 );
+ }, error=function(e) {
+ ## print(e);
+ }, finally = {
+ if(is.null(cvfit)) {
+ m <- ( o$beta[5,] != 0 );
+ }
+ })
+ }, finally = {
+ # cat("\n Finished CV Lasso\n");
+ })
+
+ varlist <- c(varlist, names(m[m==TRUE]));
+ }
+ var.lasso.10CV <- unique(varlist);
+ dt <- table(varlist);
+
+ compnames <- names(dw.all)[-1];
+ selfreq <- 0.0;
+ compselfreq <- cbind(compnames, selfreq);
+ for (i in 1:length(dt)) {
+ compselfreq[which(compnames == names(dt[i])), "selfreq"] <- dt[i]/kfold * 100.0;
+ }
+
+ return(as.numeric(compselfreq[,"selfreq"]));
+}
+
+#'Get important feature matrix
+#'@description feat.outp is a list that contains the ranked features in each
+#'cross validation (CV) and returns a two column matrix, col 1 = median ranking
+#'and col 2 = mean importance measure
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param feat.outp Input the list that contains the ranked features in each
+#'cross validation (CV) and returns a two column matrix, col 1 = median ranking
+#'and col 2 = mean importance measure
+#'@param bestFeatNum Numeric
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+GetImpFeatureMat <- function(mSetObj=NA, feat.outp, bestFeatNum){
+
+ mSetObj <- .get.mSet(mSetObj);
+ anal.mode <- mSetObj$analSet$mode;
+
+ # first order each run by cmpd names so that can be combined to a data frame
+ feat.outp <- lapply(feat.outp, function(x) x[order(names(x))]);
+
+ ####################################################################
+ # First rank by frequencies of being selected in the given model ###
+ ####################################################################
+ # obtain their ranks
+ freqRank <- lapply(feat.outp, function(x) rank(-x));
+ runRanksMat <- do.call("cbind", freqRank);
+
+ # order by their median rank across runs
+ ordRunRanksMat <- as.data.frame(runRanksMat[order(apply(runRanksMat, 1, median)),]);
+
+ # Then rank by mean importance measures
+ impsMat <- as.data.frame(do.call("cbind", feat.outp));
+ impsVec <- apply(impsMat, 1, mean);
+
+ if(anal.mode == "explore"){
+ # now count the number being selected in the bestFeatNum
+ selectedMat <- apply(ordRunRanksMat, 2, function(x) x <= bestFeatNum);
+ }else{
+ selectedMat <- ordRunRanksMat;
+ }
+
+ # calculate percentage of being selected in the best subsets
+ percentVec <- apply(selectedMat, 1, sum)/ncol(ordRunRanksMat);
+
+ # remove ones never being selected
+ percentVec <- percentVec[percentVec > 0];
+
+ # reorder the imps to percentVec
+ impsVec <- impsVec[names(percentVec)];
+
+ ###################################
+ # combine and return the result
+ ####################################
+ imp.mat <- cbind(percentVec, impsVec);
+ ord.inx <- order(imp.mat[,1], imp.mat[,2], decreasing=T);
+ imp.mat <- imp.mat[ord.inx,];
+ colnames(imp.mat) <- c("Rank Freq.", "Importance");
+
+ return(imp.mat);
+}
+
+#'Calculate variable importance of projection (VIP) score for PLS object
+#'@description Users give a pls object ('oscorespls'=T), function calculates VIP score
+#'usually one VIP for each component, return is the average of all VIP
+#'@param pls.obj Input the PLS object
+#'@param comp Numeric, input the number of components, by default it is 2
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+Get.VIP <- function(pls.obj, comp=2){
+ # only use the top two comps
+ b <- c(pls.obj$Yloadings)[1:comp];
+ T <- pls.obj$scores[,1:comp, drop = FALSE]
+ SS <- b^2 * colSums(T^2)
+ W <- pls.obj$loading.weights[,1:comp, drop = FALSE]
+ Wnorm2 <- colSums(W^2);
+ SSW <- sweep(W^2, 2, SS / Wnorm2, "*")
+ vips <- sqrt(nrow(SSW) * apply(SSW, 1, cumsum) / cumsum(SS));
+ if(is.null(dim(vips))){
+ vip.mns<-vips;
+ }else{
+ vip.mns<-apply(vips, 2, mean);
+ }
+ vip.mns;
+}
+
+GetLR_clsLbl <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(paste(mSetObj$dataSet$cls.lbl, collapse="/"));
+}
+
+GetLR_clsLblNew <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(paste(mSetObj$dataSet$cls.lbl.new, collapse="/"));
+}
+
+GetLassoFreqNames <- function(){
+ return(names(lassoFreq));
+}
+
+
+GetLRConvergence <- function(){
+ return(LRConverged);
+}
+
+GetLREquation <- function(){
+ return(LReq);
+}
+
+GetLRmodelTable <- function(){
+ return(LRmodel.xtable);
+}
+
+GetLRperformTable <- function() {
+ return(LRperf.xtable);
+}
+
+GetLRthreshold <- function() {
+ return(round(LR.threshold,2));
+}
+
+GetCurrentConfMat <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$analSet$conf.mat);
+}
+GetCurrentConfMatTest <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$analSet$conf.mat.test);
+}
+
+GetImpValues <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ as.matrix(mSetObj$analSet$imp.mat);
+}
+
+GetImpHighLow <- function(mSetObj=NA, inx){
+ mSetObj <- .get.mSet(mSetObj);
+ analSet$lowhigh[,levels(mSetObj$dataSet$cls)[inx]];
+}
+
+GetImpRowNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ rownames(mSetObj$analSet$imp.mat);
+}
+
+GetImpColNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ colnames(mSetObj$analSet$imp.mat);
+}
+
+GetModelNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ test.nums <- mSetObj$analSet$multiROC$test.feats;
+ paste("Model", 1:length(test.nums), "(", test.nums, "features)");
+}
+
+GetBestModelIndex <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$analSet$multiROC$best.model.inx;
+}
+
+GetUnivRankedFeatureNames <- function(){
+ rownames(feat.rank.mat);
+}
+
+# do the ordering before return
+GetFeatureRankingMat <- function(){
+ feat.rank.mat;
+}
+
+Get.Accuracy <- function(cm) {
+ sum(diag(cm)) / sum(cm);
+}
+
+#'Merge duplicated columns or rows by their mean
+#'@description dim 1 => row, dim 2 => column
+#'@param data Input the data
+#'@param dim Numeric, input the dimensions, default is set to 2
+#'@export
+#'
+MergeDuplicates <- function(data, dim=2){
+
+ if(is.null(dim(data))){ # a vector
+ if(is.null(names(data))){
+ print("Cannot detect duplicate data without names!!!");
+ return();
+ }
+ nm.cls <- as.factor(names(data));
+ uniq.len <- length(levels(nm.cls));
+ if(uniq.len == length(data)){
+ return(data);
+ }
+ new.data <- vector (mode="numeric",length=uniq.len);
+ for(i in 1:uniq.len){
+ dup.inx <- nm.cls == levels(nm.cls)[i];
+ new.data[i] <- mean(data[dup.inx]);
+ }
+ names(new.data) <- levels(nm.cls);
+ rem.len <- length(data) - length(new.data);
+ }else{
+ if(dim == 1){
+ data <- t(data);
+ }
+ if(is.null(colnames(data))){
+ print("Cannot detect duplicate data without var names!!!");
+ return();
+ }
+
+ nm.cls <- as.factor(colnames(data));
+ uniq.len <- length(levels(nm.cls));
+
+ if(uniq.len == ncol(data)){
+ if(dim == 1){
+ data <- t(data);
+ }
+ return(data);
+ }
+
+ new.data <- matrix (nrow=nrow(data), ncol=uniq.len);
+ for(i in 1:uniq.len){
+ dup.inx <- which(nm.cls == levels(nm.cls)[i]);
+ new.data[,i] <- apply(data[,dup.inx, drop=F], 1, mean);
+ }
+ rownames(new.data) <- rownames(data);
+ colnames(new.data) <- levels(nm.cls);
+
+ rem.len <- ncol(data) - ncol(new.data);
+ if(dim == 1){
+ new.data <- t(new.data);
+ }
+ }
+ print(paste(rem.len, "duplicates are merged to their average"));
+ new.data;
+}
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/data_trimming.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/data_trimming.R
new file mode 100755
index 0000000000000000000000000000000000000000..24cd2d00dc1ad294913faca64f15a6666475c86f
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/data_trimming.R
@@ -0,0 +1,807 @@
+#' Data inspectation
+#' @description This functions provide a path for users to visually inspect their raw data before the data
+#' trimming so as to remove the dirty or significantly uneluted peaks.
+#' @param datapath Character, the path of the raw MS data files (.mzXML, .CDF and .mzML)
+#' for the visual and intuitive data inspectation or the file folder (if only a folder path provided, the first file will
+#' be inspected).
+#' @param rt.range Numerics, a congregation of two values to define the lower and upper RT range (seconds) for
+#' users to inspect. This is an optional parameter, if absent, will display the MS of the whole RT range.
+#' @param mz.range Numerics, a congregation of two values to define the lower and upper mz range for
+#' users to inspect. This is an optional parameter, if absent, will display the MS of the whole mz range.
+#' @param dimension Character, the dimension for sample to display, including '2D' or '3D'. The default is '3D'.
+#' @param res Numeric, the resolution for data inspectation. The larger the value, the higher the resolution.
+#' The default value is 100. This value is usually clearly enough and also give consideration to the speed.
+#' @export
+#' @import MSnbase
+#' @author Zhiqiang Pang \email{zhiqiang.pang@mail.mcgill.ca} Jeff Xia \email{jeff.xia@mcgill.ca}
+#' Mcgill University
+#' License: GNU GPL (>= 2)
+
+PerformDataInspect<-function(datapath, rt.range, mz.range, dimension="3D", res=100){
+
+ suppressMessages(require("MSnbase"))
+
+ if (!grepl(pattern = c("*.mzXML"),basename(datapath)) &
+ !grepl(pattern = c("*.mzML"),basename(datapath)) &
+ !grepl(pattern = c("*.CDF"),basename(datapath))){
+
+ print(paste("First file in ", datapath, " will be inspected !"))
+
+ mzf<-list.files(datapath,recursive = F,full.names = T)[1]
+
+ } else {
+ mzf <- datapath
+ }
+
+ cat(basename(mzf),"\n")
+ ms <- openMSfile(mzf)
+ hd <- header(ms)
+
+ ms1 <- which(hd$msLevel == 1)
+
+ if (missing(rt.range)){
+
+ rtsel <- hd$retentionTime[ms1] > min(hd$retentionTime) & hd$retentionTime[ms1] < max(hd$retentionTime);
+ rt.extension <- F
+ print(paste("RT range is:",min(hd$retentionTime), "and",max(hd$retentionTime),"seconds !"))
+
+
+ } else{
+
+ if (rt.range[2]<rt.range[1]){
+ a1<-rt.range[1];
+ rt.range[1]<-rt.range[2];
+ rt.range[2]<-a1;
+ }
+ print(paste("RT range is:",rt.range[1], "and",rt.range[2],"seconds !"))
+
+ rtsel <- hd$retentionTime[ms1] > rt.range[1] & hd$retentionTime[ms1] < rt.range[2]
+
+ rt.min <- min(hd$retentionTime[ms1]);
+ rt.max <- max(hd$retentionTime[ms1]);
+
+ if (rt.range[1] < rt.min | rt.range[2] > rt.max){
+ rt.extension <- T
+ } else {
+ rt.extension <- F
+ }
+
+ }
+
+ if (missing(mz.range)){
+
+ min.mz<-min(hd$lowMZ);
+ max.mz<-max(hd$highMZ);
+
+ if (min.mz==0 & max.mz==0 | min.mz==max.mz){
+ print("mz.range information is missing in your data file. mz between 100 and 1200 will be shown here !")
+ min.mz <- 100;
+ max.mz <- 1200;
+ }
+
+ print(paste("MZ range is:",min.mz, "and",max.mz,"Thomson !"))
+
+ res.mz<-(max.mz-min.mz)/res
+ M <- MSmap(ms,
+ ms1[rtsel],
+ min.mz,
+ max.mz,
+ res.mz,
+ hd,
+ zeroIsNA = TRUE)
+
+ } else{
+
+ if (mz.range[2]<mz.range[1]){
+ a1<-mz.range[1];
+ mz.range[1]<-mz.range[2];
+ mz.range[2]<-a1;
+ }
+
+ print(paste("MZ range is:",mz.range[1], "and",mz.range[2],"Thomson !"))
+
+ res.mz<-(mz.range[2]-mz.range[1])/res
+ M <- MSmap(ms,
+ ms1[rtsel],
+ mz.range[1],
+ mz.range[2],
+ res.mz,
+ hd,
+ zeroIsNA = TRUE)
+ }
+
+
+ if (rt.extension){
+
+ if (min(M@rt) > rt.range[1]){
+ M@rt <- c(rt.range[1],M@rt);
+ M@map <- rbind(rep(NA,dim(M@map)[2]),M@map);
+ M@ms <- c(M@ms,1)
+ }
+
+ if (max(M@rt) < rt.range[2]){
+ M@rt <- c(M@rt,rt.range[2]);
+ M@map <- rbind(M@map,rep(NA,dim(M@map)[2]));
+ M@ms <- c(M@ms,1)
+ }
+ }
+
+ if (missing(dimension) | dimension=="3D"){
+ plot.MS_3D(M)
+ } else {
+ plot(M, aspect = 1, allTicks = FALSE)
+ }
+}
+
+#' Perform raw MS data trimming
+#' @description This function performs the raw data trimming. This function will output
+#' an trimmed MSnExp file to memory or hardisk according to the choice of users must
+#' provide the data path for 'datapath', and optionally provide other corresponding parameters.
+#' @param datapath Character, the path of the raw MS data files' folder/path (.mzXML, .CDF and .mzML)
+#' for parameters training.
+#' @param mode Character, mode for data trimming to select the chraracteristic peaks.
+#' Default is 'ssm'. Users could select random trimed according to mz value (mz_random) or
+#' RT value (rt_random). Besides, specific peaks at certain mz (mz_specific) or
+#' RT (rt_specific) could also be extracted. 'none' will not trim the data.
+#' @param mz Numeric, mz value(s) for specific selection. Positive values means including (the values
+#' indicted) and negative value means excluding/removing.
+#' @param mzdiff Numeric, the deviation (ppm) of mz value(s).
+#' @param rt Numeric, rt value for specific selection. Positive values means including
+#' and negative value means excluding.
+#' @param rtdiff Numeric, the deviation (seconds) of rt value(s).
+#' @param rt.idx Numeric, the relative rt (retention time) range, from 0 to 1. 1 means all retention time
+#' will be retained, while 0 means none. Default is 1/15. If default rt.idx produce too few peaks,
+#' please consider increasing this value.
+#' @param write Logical, if true, will write the trimed data to the directory 'trimed' folder
+#' in the datapath. The data in memory will be kept.
+#' @param plot Logical, if ture, will plot the chromatogram of the trimed data.
+#' @export
+#' @import MSnbase
+#' @import progress
+#' @author Zhiqiang Pang \email{zhiqiang.pang@mail.mcgill.ca} Jeff Xia \email{jeff.xia@mcgill.ca}
+#' Mcgill University
+#' License: GNU GPL (>= 2)
+
+PerformDataTrimming<-function(datapath, mode="ssm", write=F, mz, mzdiff, rt, rtdiff,
+ rt.idx=1/15, plot=T){
+
+ require(progress);require(Biobase);
+
+ match.arg(mode,choices = c("ssm","mz_random","rt_random","mz_specific","rt_specific"))
+
+ start.time<-Sys.time();
+
+ dda_file1 <- list.files(datapath, recursive = T, full.names = TRUE)
+
+ pd <- data.frame(sample_name = sub(basename(dda_file1), pattern = ".mzXML",
+ replacement = "", fixed = TRUE),
+ stringsAsFactors = FALSE)
+
+ message("Data Loading...")
+
+ raw_data <- #suppressMessages(try(
+ read.MSdata(dda_file1, pdata = new("NAnnotatedDataFrame", pd), msLevel. = 1, mode = "inMemory")#,
+ # silent = T))
+
+ message("Data Loaded !")
+
+ if (!mode=="none"){
+ ## Data Trim
+ a<-suppressMessages(unlist(lapply(ls(raw_data@assayData), FUN=function(x){unlockBinding(sym = x,env = raw_data@assayData)})))
+ ms_list<-sapply(ls(raw_data@assayData),FUN=function(x) raw_data@assayData[[x]]@mz)
+
+ message("Data Trimming...")
+
+ if (missing(rt.idx)){
+ rt.idx <- 1/15
+ };
+
+ if (mode=="ssm"){
+ trimed_MSnExp<-ssm_trim(raw_data,ms_list,rt.idx=rt.idx)
+ }
+
+ if (mode=="mz_random"){
+ suppressWarnings(try(trimed_MSnExp<-mz.trim_random(raw_data,ms_list),silent = T))
+ }
+
+ if (mode=="rt_random"){
+ suppressWarnings(try(trimed_MSnExp<-rt.trim_random(raw_data,ms_list),silent = T))
+ }
+
+ if (mode=="mz_specific"){
+ trimed_MSnExp<-mz.trim_specific(raw_data,ms_list,mz,mzdiff=mzdiff)
+ }
+
+ if (mode=="rt_specific"){
+ trimed_MSnExp<-rt.trim_specific(raw_data,ms_list,rt,rtdiff=rtdiff)
+ }
+
+ message("Data Trimmed !")
+
+ # remove the empty scans in the ms data
+
+ trimed_MSnExp<-.emptyscan.remove(trimed_MSnExp,ms_list)
+
+ }else{
+ # keep the data without trimming.
+ trimed_MSnExp<-raw_data
+
+ }
+ if (write==T){
+ message("Data Writing...")
+
+ writenames<-paste0(datapath,"/trimmed/Trimmed_",pd$sample_name,".mzML",sep = "")
+ dir.create(paste0(datapath,"/trimmed",collapse = ""))
+ suppressMessages(writeMSData(trimed_MSnExp, writenames, outformat = "mzml"))
+
+ message("Data Writing Finished !")
+ }
+ if (plot==T){
+ require(RColorBrewer);
+
+ message("Chromatogram Plotting Begin...")
+
+ ch.xdata<-chromatogram(trimed_MSnExp)
+ group.col<-paste0(brewer.pal(length(trimed_MSnExp@processingData@files),"Blues"))
+ plot(ch.xdata,col=group.col[1:length(trimed_MSnExp@processingData@files)])
+ }
+
+ message("Data Trimming Finished !")
+
+ end.time<-Sys.time();
+ message("Time Spent In Total:",round((as.numeric(end.time) - as.numeric(start.time))/60, 1),"mins","\n");
+
+ return(trimed_MSnExp)
+}
+
+#' Standards Simulation Method
+#' @description Whole mass spectra will be divided as 4 bins according to the mz range. Trimming
+#' the raw with slide window method in every bins and retained the windows with highest scan intensity
+#' and remove other scan signal in mz dimension. Then the data will be trimed again in the RT dimension
+#' with slide window method. The window with highest intensity scans will be kept. After the timming
+#' alongside mz and RT dimension, the peaks not only the high intensity peaks, but also the relatively
+#' low intensity peaks will also be retained as the 'simulated standards' data for parameters optimization.
+#' @param raw_data MSnExp object, the raw data that has been read in memory.
+#' @param ms_list List, the names list of all scans.
+#' @param rt.idx Numeric, the retention time percentage, from 0 to 1. Default is 1/15.
+#' @import progress
+#' @import BiocParallel
+#' @author Zhiqiang Pang \email{zhiqiang.pang@mail.mcgill.ca} Jeff Xia \email{jeff.xia@mcgill.ca}
+#' Mcgill University
+#' License: GNU GPL (>= 2)
+
+ssm_trim <- function(raw_data, ms_list, rt.idx){
+
+ # mzdata_points<-unique(unlist(ms_list))
+
+
+ # Slide window to choose the high abundance bins in every districts
+ message("MS data Parsing ...")
+
+ #if(length(names(ms_list))>1000){
+ # ms_list_s<-sort(sample(names(ms_list),1000))
+ #} else {
+ # ms_list_s<-sort(names(ms_list))
+ #}
+
+ spectra_mz <- unlist(lapply(MSnbase::spectra(raw_data),mz))
+
+ highestmz<-max(spectra_mz)
+ lowestmz<-min(spectra_mz)
+
+ # Split MS into 5 large districts
+ bins.boundary<-seq(from=lowestmz, to= highestmz,length.out = 5)
+
+
+ if (length(spectra_mz)>1000000){
+ rannum<- sort(sample(length(spectra_mz),ceiling(length(spectra_mz)/50)),decreasing = F)
+ } else if (length(spectra_mz)>100000){
+ rannum<-sort(sample(length(spectra_mz),ceiling(length(spectra_mz)/5)),decreasing = F)
+ } else {
+ rannum<-seq(length(spectra_mz))
+ }
+
+ spectra_abundance <- unlist(lapply(MSnbase::spectra(raw_data),intensity))[rannum]
+ spectra_mz <- spectra_mz[rannum]
+
+ spectra_mz_set <- sapply(1:4,FUN=function(ii){
+
+ spectra_mz[spectra_mz > bins.boundary[ii] & spectra_mz < bins.boundary[ii+1]]
+
+ })
+
+ spectra_abundance_set <- sapply(1:4,FUN=function(ii){
+
+ spectra_abundance[spectra_mz > bins.boundary[ii] & spectra_mz < bins.boundary[ii+1]]
+
+ })
+
+ rm(spectra_abundance); rm(spectra_mz)
+
+ good.bins.list<-bplapply(c(1:4),
+ FUN = function(i,spectra_abundance_set,spectra_mz_set,bins.boundary){
+
+ binsb.low<-bins.boundary[i];
+
+ binsb.high<-bins.boundary[i+1];
+
+ w<-1
+
+ bins.width<-(binsb.high-binsb.low)/5;
+
+ wind.up<-wind.down<-0
+
+ inten.sum.set<-numeric()
+
+ while (!wind.up>binsb.high) {
+
+ wind.down<-binsb.low+(w-1);
+
+ wind.up<-binsb.low+bins.width+(w-1);
+
+ #inten.sum<-numeric()
+
+
+ inten.sum.set<-c(inten.sum.set,
+ sum (spectra_abundance_set[[i]]
+ [spectra_mz_set[[i]] > wind.down & spectra_mz_set[[i]] < wind.up]))
+
+ #for (j in 1:length(ms_list_s)){
+ # mz.set<-raw_data@assayData[[ms_list_s[j]]]@mz
+ # a1<-which(sapply(mz.set, FUN=function(x){x>wind.down && x<wind.up}))
+ # inten.sum<-c(inten.sum,sum(raw_data@assayData[[ms_list_s[j]]]@intensity[a1]))
+ #}
+
+ #inten.sum.set<-c(inten.sum.set,sum(inten.sum))
+ w<-w+1;
+ }
+
+ selected.bin.down<-binsb.low+which(max(inten.sum.set)==inten.sum.set)-1;
+ selected.bin.up<-binsb.low+which(max(inten.sum.set)==inten.sum.set)-1+bins.width
+
+ return(list(selected.bin.down,selected.bin.up))
+
+ },
+ spectra_abundance_set=spectra_abundance_set,
+ spectra_mz_set=spectra_mz_set,
+ bins.boundary=bins.boundary,
+ BPPARAM = SnowParam(type="SOCK"))
+
+ message("MS Data Pasing Done !")
+
+ # Remove the peaks out of the bins
+ message("M/Z Data Trimming...")
+ pb <- progress_bar$new(format = "Data Trimming in MZ Dimension [:bar] :percent Time left: :eta", total = length(ms_list), clear = T, width= 80)
+
+ for (i in 1:length(ms_list)){
+ pb$tick();
+
+ ms.set<-raw_data@assayData[[names(ms_list)[i]]]@mz
+ k<-which(sapply(ms.set,FUN = function(x){(x > good.bins.list[[1]][[1]] && x < good.bins.list[[1]][[2]]) | (x > good.bins.list[[2]][[1]] && x < good.bins.list[[2]][[2]]) | (x > good.bins.list[[3]][[1]] && x < good.bins.list[[3]][[2]]) | (x > good.bins.list[[4]][[1]] && x < good.bins.list[[4]][[2]])}))
+
+ raw_data@assayData[[names(ms_list)[i]]]@mz<-raw_data@assayData[[names(ms_list)[i]]]@mz[k];
+ raw_data@assayData[[names(ms_list)[i]]]@intensity<-raw_data@assayData[[names(ms_list)[i]]]@intensity[k];
+ raw_data@assayData[[names(ms_list)[i]]]@tic<-sum(raw_data@assayData[[names(ms_list)[i]]]@intensity);
+ raw_data@assayData[[names(ms_list)[i]]]@peaksCount<-length(raw_data@assayData[[names(ms_list)[i]]]@mz)
+ }
+
+ message("M/Z Data Trimming Done !")
+
+ ## Trimed data outside the RT bins
+ rt_set<-sapply(names(ms_list),FUN=function(x) raw_data@assayData[[x]]@rt)
+ rt.bin.width<-(max(rt_set)-min(rt_set))*rt.idx
+
+ # Slide window to determin the location of the RT trim boundary
+ tic<-1;w<-0;rt.window.min<-min(rt_set);tic.sum<-numeric()
+
+ while (!rt.window.min>max(rt_set)) {
+ rt.window.min<-min(rt_set)+w*0.75
+ rt.window.max<-min(rt_set)+rt.bin.width+w*0.75
+ rt.name.set<-names(which(sapply(rt_set,FUN = function(x){x>rt.window.min && x<rt.window.max})))
+
+ if(!identical(rt.name.set,character(0))){
+ tic.sum<-c(tic.sum,sum(sapply(rt.name.set,FUN=function(x){raw_data@assayData[[x]]@tic})))
+ }
+
+ w<-w+1
+ }
+
+ rt.boundary.lowlimit<-min(rt_set)+which(max(tic.sum)==tic.sum)[ceiling(length(which(max(tic.sum)==tic.sum))/2)]*0.75
+ rt.boundary.uplimit<-min(rt_set)+which(max(tic.sum)==tic.sum)[ceiling(length(which(max(tic.sum)==tic.sum))/2)]*0.75+rt.bin.width
+
+ message("Trim data outside the RT bins...")
+
+ pb <- progress_bar$new(format = "Data Trimming in RT Dimension [:bar] :percent Time left: :eta", total = length(ms_list), clear = T, width= 80)
+ ncount<-numeric();
+
+ for (w in 1:length(ms_list)){
+ pb$tick();
+ if (raw_data@assayData[[names(ms_list)[w]]]@rt>rt.boundary.lowlimit && raw_data@assayData[[names(ms_list)[w]]]@rt<rt.boundary.uplimit){
+ ncount<-c(ncount,w)
+ }
+ }
+
+ for (j in 1:length(ms_list)){
+ if (!(j %in% ncount)){
+ raw_data@assayData[[names(ms_list)[j]]]@mz<-raw_data@assayData[[names(ms_list)[j]]]@intensity<-as.double();
+ raw_data@assayData[[names(ms_list)[j]]]@peaksCount<-as.integer(0);
+ raw_data@assayData[[names(ms_list)[j]]]@tic<-as.double(0);
+ }
+ }
+ return(raw_data)
+}
+
+#' Data trimming Method Based on Random MS
+#' @description Trim raw data scan signal randomly in the mz dimension.
+#' @param raw_data MSnExp object, the raw data that has been read in memory.
+#' @param ms_list List, the names list of all scans.
+#' @import progress
+#' @author Zhiqiang Pang \email{zhiqiang.pang@mail.mcgill.ca} Jeff Xia \email{jeff.xia@mcgill.ca}
+#' Mcgill University
+#' License: GNU GPL (>= 2)
+
+mz.trim_random <- function(raw_data, ms_list){
+
+ mzdata_points <- unique(unlist(ms_list))
+ highestmz <- max(mzdata_points)
+ lowestmz <- min(mzdata_points)
+
+ # Randomly select 100 mz center points
+ mzdata_points <- sample(unique(mzdata_points),size = 100)
+
+ pb <- progress_bar$new(format = "Data Trimming [:bar] :percent Time left: :eta", total = length(raw_data@assayData), clear = T, width= 60)
+
+ for (i in 1:length(raw_data@assayData)){
+ pb$tick();
+ mz.data<-ms_list[[i]];
+ remove.num.set<-numeric();k<-1
+
+ for (j in 1:length(mz.data)){
+ if (!(T %in% (abs(mz.data[j]-mzdata_points)<=(highestmz-lowestmz)/10000))){
+ remove.num.set[k]<-j;
+ k<-k+1
+ }
+ }
+ raw_data@assayData[[names(ms_list[i])]]@mz<-mz.data[-remove.num.set];
+ raw_data@assayData[[names(ms_list[i])]]@intensity<-raw_data@assayData[[names(ms_list[i])]]@intensity[-remove.num.set];
+ raw_data@assayData[[names(ms_list[i])]]@tic<-sum(raw_data@assayData[[names(ms_list[i])]]@intensity);
+ raw_data@assayData[[names(ms_list[i])]]@peaksCount<-length(raw_data@assayData[[names(ms_list[i])]]@mz);
+ }
+ return(raw_data)
+}
+
+#' Data trimming Method Based on Random RT
+#' @description Trim raw data scan signal randomly in the RT dimension.
+#' @param raw_data MSnExp object, the raw data that has been read in memory.
+#' @param ms_list List, the names list of all scans.
+#' @import progress
+#' @author Zhiqiang Pang \email{zhiqiang.pang@mail.mcgill.ca} Jeff Xia \email{jeff.xia@mcgill.ca}
+#' Mcgill University
+#' License: GNU GPL (>= 2)
+
+rt.trim_random <- function(raw_data, ms_list){
+
+ rt_set<-sapply(names(ms_list),FUN=function(x) raw_data@assayData[[x]]@rt)
+ rt_begin<-min(rt_set);
+ rt_end<-max(rt_set);
+
+ xn2<-character();xn3<-xn<-xcount<-ncount<-rt_var_sum<-numeric();
+ rt_width_aver<-(rt_end-rt_begin)/200
+ xn_list<-list()
+
+ pb <- progress_bar$new(format = "Data Trimming [:bar] :percent Time left: :eta", total = 200, clear = T, width= 60)
+
+ for (w in 1:200){
+ pb$tick();
+
+ rt_var<-rt_begin+rt_width_aver*(w-0.5);
+ rt_var_sum<-c(rt_var_sum,rt_var);
+
+ xn_list[w][[1]]<-0
+ }
+
+ xn<-sapply(names(ms_list),FUN= function(x) which(abs(raw_data@assayData[[x]]@rt-rt_var_sum)<=(rt_width_aver/2+0.000001)))
+
+ for (i in 1:length(xn)){xn_list[[xn[i]]]<-sum(xn_list[[xn[i]]],raw_data@assayData[[names(xn[i])]]@peaksCount)}
+
+ rt_peakcounts<-unlist(xn_list)
+ #rtslots<-rt_var_sum[sapply(tail(sort(unlist(xn_list)),10),FUN = function(x){which(x==rt_peakcounts)})]
+
+ # randomly select 10 RT slots
+ rtslots<-rt_var_sum[sapply(sample(unlist(xn_list),10),FUN = function(x){which(x==rt_peakcounts)})]
+
+ for (j in 1:length(ms_list)){
+
+ if (T %in% (abs(raw_data@assayData[[names(ms_list)[j]]]@rt-rtslots)<=(rt_width_aver/2+0.000001))){
+ xn2<-c(xn2,names(ms_list)[j]);xn3<-c(xn3,j)
+ }
+ }
+
+ for (k in 1:length(ms_list)) {
+
+ if (!(k %in% xn3)){
+ raw_data@assayData[[names(ms_list)[k]]]@peaksCount<-as.integer(0);
+ raw_data@assayData[[names(ms_list)[k]]]@mz<-as.double();
+ raw_data@assayData[[names(ms_list)[k]]]@intensity<-as.double();
+ raw_data@assayData[[names(ms_list)[k]]]@tic<-as.double(0);
+ }
+ }
+ return(raw_data)
+}
+
+#' Data trimming Method Based on Specific MS
+#' @description Trim data based on specific mz values. Positive values will be specially retained,
+#' while the negative values will be removed.
+#' @param raw_data MSnExp object, the raw data that has been read in memory.
+#' @param ms_list List, the names list of all scans.
+#' @param mz Numeric, the specifric mz value that will be kept or removed.
+#' @param mzdiff Numeric, the deviation (ppm) for the 'mz' values. Default is 100.
+#' @import progress
+#' @author Zhiqiang Pang \email{zhiqiang.pang@mail.mcgill.ca} Jeff Xia \email{jeff.xia@mcgill.ca}
+#' Mcgill University
+#' License: GNU GPL (>= 2)
+
+mz.trim_specific<-function(raw_data, ms_list, mz, mzdiff=100){
+
+ #mz<-c(72.323,100,120,240,360,480,720,780.524,1080);
+ if (missing(mz)){
+ stop("'mz' must be provided for mz_specific mode as a numeric vector!")
+ }
+
+ if (missing(mzdiff)){
+ stop("'mzdiff' must be provided for mz_specific mode as a numeric value!")
+ }
+
+ if (mz[1] == 0 | mzdiff==0){
+ stop("'mz' or 'mzdiff' cannot be zero!")
+ }
+
+ mz.neg<-mz[which(mz<0)];
+ mz.pos<-mz[which(mz>0)];
+
+ if (!identical(mz.pos,numeric(0))){
+ pb <- progress_bar$new(format = "Data Trimming_keeping [:bar] :percent Time left: :eta", total = length(ms_list), clear = T, width= 60)
+
+ for (w in 1:length(ms_list)){
+ pb$tick();
+ xn<-unlist(sapply(mz.pos,FUN=function(x){which((abs(x-raw_data@assayData[[names(ms_list)[w]]]@mz)/(x)*1000000)<=mzdiff)}));
+
+ raw_data@assayData[[names(ms_list)[w]]]@mz<-raw_data@assayData[[names(ms_list)[w]]]@mz[xn];
+ raw_data@assayData[[names(ms_list)[w]]]@intensity<-raw_data@assayData[[names(ms_list)[w]]]@intensity[xn];
+ raw_data@assayData[[names(ms_list)[w]]]@peaksCount<-length(raw_data@assayData[[names(ms_list)[w]]]@mz);
+ raw_data@assayData[[names(ms_list)[w]]]@tic<-sum(raw_data@assayData[[names(ms_list)[w]]]@intensity);
+ }
+
+ for (w in 1:length(ms_list)){
+ if (identical(raw_data@assayData[[names(ms_list)[w]]]@mz,numeric(0))){
+ raw_data@assayData[[names(ms_list)[w]]]@mz<-as.double();
+ raw_data@assayData[[names(ms_list)[w]]]@intensity<-as.double();
+ }
+ }
+ }
+
+ if (!identical(mz.neg,numeric(0))){
+
+ pb <- progress_bar$new(format = "Data Trimming_removing [:bar] :percent Time left: :eta", total = length(ms_list), clear = T, width= 60)
+
+ for (w in 1:length(ms_list)){
+ pb$tick();
+ xn<-unlist(sapply(abs(mz.neg),FUN=function(x){which((abs(x-raw_data@assayData[[names(ms_list)[w]]]@mz)/(x)*1000000)<=mzdiff)}));
+
+ if (!identical(xn, numeric(0))){
+ raw_data@assayData[[names(ms_list)[w]]]@mz<-raw_data@assayData[[names(ms_list)[w]]]@mz[-xn];
+ raw_data@assayData[[names(ms_list)[w]]]@intensity<-raw_data@assayData[[names(ms_list)[w]]]@intensity[-xn];
+ raw_data@assayData[[names(ms_list)[w]]]@peaksCount<-length(raw_data@assayData[[names(ms_list)[w]]]@mz);
+ raw_data@assayData[[names(ms_list)[w]]]@tic<-sum(raw_data@assayData[[names(ms_list)[w]]]@intensity);
+ }
+ }
+
+ for (w in 1:length(ms_list)){
+
+ if (identical(raw_data@assayData[[names(ms_list)[w]]]@mz,numeric(0))){
+ raw_data@assayData[[names(ms_list)[w]]]@mz<-as.double();
+ raw_data@assayData[[names(ms_list)[w]]]@intensity<-as.double();
+ }
+ }
+ }
+ return(raw_data)
+}
+
+#' Data trimming Method Based on Specific RT
+#' @description Trim data based on specific RT values. Positive values will be specially retained,
+#' while the negative values will be removed.
+#' @param raw_data MSnExp object, the raw data that has been read in memory.
+#' @param ms_list List, the names list of all scans.
+#' @param mz Numeric, the specifric RT value that will be kept or removed.
+#' @param mzdiff Numeric, the deviation (ppm) for the 'rt' values. Default is 100.
+#' @import progress
+#' @author Zhiqiang Pang \email{zhiqiang.pang@mail.mcgill.ca} Jeff Xia \email{jeff.xia@mcgill.ca}
+#' Mcgill University
+#' License: GNU GPL (>= 2)
+
+rt.trim_specific<-function(raw_data,ms_list,rt,rtdiff=10){
+
+ if (missing(rt)){
+ stop("'rt' must be provided for rt_specific mode with a vector !")
+ }
+
+ if (missing(rtdiff)){
+ stop("'rtdiff' must be provided for rt_specific mode with a numeric !")
+ }
+
+ if (rt[1] == 0 | rtdiff==0){
+ stop("'rt' or 'rtdiff' can not be zero !")
+ }
+
+ if (rt[1] > 0){
+ pb <- progress_bar$new(format = "Data Trimming [:bar] :percent Time left: :eta", total = length(ms_list), clear = T, width= 60)
+
+ ncount<-numeric();
+ for (w in 1:length(ms_list)){
+ pb$tick();
+ if (T %in% (abs(raw_data@assayData[[names(ms_list)[w]]]@rt-rt)<=rtdiff)){
+ ncount<-c(ncount,w)
+ }
+ }
+
+ for (j in 1:length(ms_list)){
+
+ if (!(j %in% ncount)){
+ raw_data@assayData[[names(ms_list)[j]]]@mz<-raw_data@assayData[[names(ms_list)[j]]]@intensity<-as.double();
+ raw_data@assayData[[names(ms_list)[j]]]@peaksCount<-as.integer(0);
+ raw_data@assayData[[names(ms_list)[j]]]@tic<-as.double(0);
+ }
+
+ }
+ } else {
+
+ pb <- progress_bar$new(format = "Data Trimming [:bar] :percent Time left: :eta", total = length(ms_list), clear = T, width= 60)
+
+ ncount<-numeric();
+ for (w in 1:length(ms_list)){
+ pb$tick();
+ if (T %in% (abs(raw_data@assayData[[names(ms_list)[w]]]@rt-abs(rt))<=rtdiff)){
+ ncount<-c(ncount,w)
+ }
+
+ }
+ for (j in 1:length(ms_list)){
+
+ if (j %in% ncount){
+ raw_data@assayData[[names(ms_list)[j]]]@mz<-raw_data@assayData[[names(ms_list)[j]]]@intensity<-as.double();
+ raw_data@assayData[[names(ms_list)[j]]]@peaksCount<-as.integer(0);
+ raw_data@assayData[[names(ms_list)[j]]]@tic<-as.double(0);
+ }
+ }
+ }
+ return(raw_data)
+}
+
+#' Empty scan removal
+#' @description Function for 'Empty scan' removal
+#' @param datapath Character, the path of the raw MS data files' folder/path (.mzXML, .mzData, .CDF and .mzML).
+#' The empty scan free MS will be save as .mzXML format automaticaly.
+#' @import MSnbase
+#' @author Zhiqiang Pang \email{zhiqiang.pang@mail.mcgill.ca}
+#' License: GNU GPL (>= 2)
+#' @export
+RemoveEmptyScan <- function(datapath){
+
+ dda_file1 <- list.files(datapath, recursive = T, full.names = TRUE)
+ format <- unique(sapply(dda_file1, FUN=function(x){tail(strsplit(basename(x), split="\\.")[[1]],1)}));
+ if (length(format) > 1){
+ stop("Cannot Handle Multiple formats at the same time !")
+ }
+ pd <- data.frame(sample_name = sub(basename(dda_file1), pattern = paste0(".",format),
+ replacement = "", fixed = TRUE),
+ stringsAsFactors = FALSE)
+
+ message("Data Loading...")
+
+ raw_data <- #suppressMessages(try(
+ MetaboAnalystR:::read.MSdata(dda_file1, pdata = new("NAnnotatedDataFrame", pd), msLevel. = 1, mode = "inMemory")#,
+ # silent = T))
+
+ a<-suppressMessages(unlist(lapply(ls(raw_data@assayData), FUN=function(x){unlockBinding(sym = x,env = raw_data@assayData)})));
+ ms_list<-sapply(ls(raw_data@assayData),FUN=function(x) raw_data@assayData[[x]]@mz);
+
+ raw_data_to_write<-.emptyscan.remove(raw_data,ms_list);
+
+ writenames<-paste0(datapath,"EmptyScanFree_",pd$sample_name,".mzML",sep = "")
+ suppressMessages(writeMSData(raw_data_to_write, writenames, outformat = "mzml"))
+
+ message("Removed successfully !")
+
+}
+
+#' Function for 'Empty scan' removal
+#' @description Function for 'Empty scan' removal (internal use only)
+#' @author Zhiqiang Pang \email{zhiqiang.pang@mail.mcgill.ca}
+.emptyscan.remove<-function(raw_data,ms_list){
+
+ name.set<-sort(names(raw_data@assayData))
+
+ sample.set<-unique(sapply(c(1:length(name.set)),FUN=function(x){sub(".[S][0-9]+","",name.set[x])}))
+ assayData<-list();assayData1<-new.env();ki<-k<-1
+
+ df.data0<-raw_data@featureData@data;
+ df.data<-data.frame();
+
+ nchar.num<-nchar(names(ms_list)[1])-4
+ suppressWarnings(for (i in 1:length(raw_data@assayData)){
+
+ if (!raw_data@assayData[[name.set[i]]]@tic==0){
+
+ if (!k==1){
+ if (!sample.set[which(sub(".[S][0-9]+","",name.set[i])==sample.set)]==sub(".[S][0-9]+","",names(assayData)[ki-1])){
+ k<-1
+ }
+ }
+
+ name0<-paste0(sample.set[which(sub(".[S][0-9]+","",name.set[i])==sample.set)],".S",formatC(k, width=nchar.num, digits = nchar.num, flag="0"))
+
+ assayData[name0]<-raw_data@assayData[[name.set[i]]];
+ assayData[[name0]]@acquisitionNum<-as.integer(k);
+ assayData[[name0]]@scanIndex<-as.integer(k);
+
+ df.data[ki,1]<-k;
+ row.names(df.data)[ki]<-name0;
+
+ k<-k+1;ki<-ki+1;
+ }
+ })
+
+ list2env(assayData,envir = assayData1)
+ raw_data@assayData<-assayData1
+ names(df.data)<-"spectrum"
+
+ metaData<-raw_data@featureData@varMetadata;
+ featureData<-AnnotatedDataFrame(data=df.data, varMetadata=metaData);
+ raw_data@featureData<-featureData;
+
+ return(raw_data)
+}
+
+#' Function MS Generation
+#' @description Output the MS data. This function will generate .mzML MS data in the working dirctory.
+#' @param raw_data MS data in R environment with "MSnExp" class.
+#' @import MSnbase
+#' @export
+#' @author Zhiqiang Pang \email{zhiqiang.pang@mail.mcgill.ca} Jeff Xia \email{jeff.xia@mcgill.ca}
+#' Mcgill University
+#' License: GNU GPL (>= 2)
+PerformMSDataOutput<-function(raw_data){
+ message("Data Writing...")
+ writenames<-paste0("new_",raw_data@phenoData@data[["sample_name"]],sep = "")
+ #dir.create(paste0(datapath,"/trimed",collapse = ""))
+ suppressMessages(writeMSData(raw_data, writenames, outformat = "mzML"))
+ message("Output Data:","\n");
+ message(writenames)
+ message(paste("Depositing Folder:",getwd()))
+ message("Data Writing Finished !")
+}
+
+#' Function for 3D ms plotting
+#' @description Function for 3D ms plotting (internal use only)
+#' @author Zhiqiang Pang \email{zhiqiang.pang@mail.mcgill.ca}
+plot.MS_3D<-function(object) {
+
+ dd <- as(object, "data.frame")
+
+ ms <- NULL ## get rid of 'no visible global function definition' note
+ par.set <- list(box.3d = list(lwd=.2))
+
+ cloud(intensity ~ mz + rt , data = dd,
+ type="h",
+ scales= list(
+ arrows=FALSE,
+ cex=.65,
+ draw=TRUE),
+ aspect=c(.8, 1),
+ group = ms,
+ zoom = 1,
+ par.settings = par.set,
+ axis.line = list(col = "transparent"),
+ xlab="M/Z", ylab="Retention time", zlab=NULL)
+
+}
\ No newline at end of file
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/dependencies_function_imported.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/dependencies_function_imported.R
new file mode 100755
index 0000000000000000000000000000000000000000..0787923384f8bf24ee4e35d523c40830eab46427
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/dependencies_function_imported.R
@@ -0,0 +1,682 @@
+#' I. Internal Functions from Plotly Package
+#' THe functions are from Plotly Package and was called internally only
+#' @references https://cran.r-project.org/package=plotly
+#' @references Sievert C (2020). Interactive Web-Based Data Visualization with R, plotly, and shiny. Chapman and Hall/CRC. ISBN 9781138331457, https://plotly-r.com.
+#' @import htmltools
+#' @import jsonlite
+#' @importFrom graphics layout
+#' @importFrom tibble as_tibble
+#' @importFrom purrr transpose
+#'
+
+# (1). Add_markers & add_data
+add_trace <- function(p, ...,data = NULL, inherit = TRUE) {
+
+ # "native" plotly arguments
+ attrs <- list(...)
+ attrs$inherit <- inherit
+
+ if (!is.null(attrs[["group"]])) {
+ warning("The group argument has been deprecated. Use group_by() or split instead.")
+ }
+
+ p <- add_data(p, data)
+
+ # inherit attributes from the "first layer" (except the plotly_eval class)
+ if (inherit) {
+ attrs <- modify_list(unclass(p$x$attrs[[1]]), attrs)
+ }
+
+ p$x$attrs <- c(
+ p$x$attrs %||% list(),
+ setNames(list(attrs), p$x$cur_data)
+ )
+
+ p
+}
+add_markers <- function(p, x = NULL, y = NULL, z = NULL, ..., data = NULL, inherit = TRUE) {
+ if (inherit) {
+ x <- x %||% p$x$attrs[[1]][["x"]]
+ y <- y %||% p$x$attrs[[1]][["y"]]
+ z <- z %||% p$x$attrs[[1]][["z"]]
+ }
+ if (is.null(x) || is.null(y)) {
+ stop("Must supply `x` and `y` attributes", call. = FALSE)
+ }
+ type <- if (!is.null(z)) "scatter3d" else "scatter"
+ add_trace(
+ p, x = x, y = y, z = z, type = type, mode = "markers", ...,
+ data = data, inherit = inherit
+ )
+}
+add_data <- function(p, data = NULL) {
+ if (is.null(data)) return(p)
+ if (!is.plotly(p)) {
+ stop("Don't know how to add traces to an object of class: ",
+ class(p), call. = FALSE)
+ }
+ id <- new_id()
+ p$x$visdat[[id]] <- function() data
+ p$x$cur_data <- id
+ # TODO: should this also override the data used for the most recent trace?
+ p
+}
+
+# (2). layout
+layout <- function(p, ..., data = NULL) {
+ UseMethod("layout")
+}
+layout.matrix <- function(p, ..., data = NULL) {
+ # workaround for the popular graphics::layout() function
+ # https://github.com/ropensci/plotly/issues/464
+ graphics::layout(p, ...)
+}
+layout.shiny.tag.list <- function(p, ..., data = NULL) {
+ idx <- which(vapply(p, is.plotly, logical(1)))
+ for (i in idx) {
+ p[[i]] <- layout.plotly(p[[i]], ..., data = NULL)
+ }
+ p
+}
+layout.plotly <- function(p, ..., data = NULL) {
+ p <- add_data(p, data)
+ attrs <- list(...)
+ if (!is.null(attrs[["height"]]) || !is.null(attrs[["width"]])) {
+ warning("Specifying width/height in layout() is now deprecated.\n",
+ "Please specify in ggplotly() or plot_ly()", call. = FALSE)
+ }
+ # similar to add_trace()
+ p$x$layoutAttrs <- c(
+ p$x$layoutAttrs %||% list(),
+ setNames(list(attrs), p$x$cur_data)
+ )
+ p
+}
+
+# (3). plotly
+plot_ly <- function(data = data.frame(), ..., type = NULL, name,
+ color, colors = NULL, alpha = NULL,
+ stroke, strokes = NULL, alpha_stroke = 1,
+ size, sizes = c(10, 100),
+ span, spans = c(1, 20),
+ symbol, symbols = NULL,
+ linetype, linetypes = NULL,
+ split, frame,
+ width = NULL, height = NULL, source = "A") {
+
+ if (!is.data.frame(data) && !crosstalk::is.SharedData(data)) {
+ stop("First argument, `data`, must be a data frame or shared data.", call. = FALSE)
+ }
+
+ # "native" plotly arguments
+ attrs <- list(...)
+
+ # warn about old arguments that are no longer supported
+ for (i in c("filename", "fileopt", "world_readable")) {
+ if (is.null(attrs[[i]])) next
+ warning("Ignoring ", i, ". Use `plotly_POST()` if you want to post figures to plotly.")
+ attrs[[i]] <- NULL
+ }
+ if (!is.null(attrs[["group"]])) {
+ warning(
+ "The group argument has been deprecated. Use `group_by()` or split instead.\n",
+ "See `help('plotly_data')` for examples"
+ )
+ attrs[["group"]] <- NULL
+ }
+ if (!is.null(attrs[["inherit"]])) {
+ warning("The inherit argument has been deprecated.")
+ attrs[["inherit"]] <- NULL
+ }
+
+ # tack on variable mappings
+ attrs$name <- if (!missing(name)) name
+ attrs$color <- if (!missing(color)) color
+ attrs$stroke <- if (!missing(stroke)) stroke
+ attrs$size <- if (!missing(size)) size
+ attrs$span <- if (!missing(span)) span
+ attrs$symbol <- if (!missing(symbol)) symbol
+ attrs$linetype <- if (!missing(linetype)) linetype
+ attrs$split <- if (!missing(split)) split
+ attrs$frame <- if (!missing(frame)) frame
+
+ # tack on scale ranges
+ attrs$colors <- colors
+ attrs$strokes <- strokes
+ attrs$alpha <- alpha
+ attrs$alpha_stroke <- alpha_stroke
+ attrs$sizes <- sizes
+ attrs$spans <- spans
+ attrs$symbols <- symbols
+ attrs$linetypes <- linetypes
+
+ # and, of course, the trace type
+ attrs$type <- type
+
+ # id for tracking attribute mappings and finding the most current data
+ id <- new_id()
+ # avoid weird naming clashes
+ plotlyVisDat <- data
+ p <- list(
+ visdat = setNames(list(function() plotlyVisDat), id),
+ cur_data = id,
+ attrs = setNames(list(attrs), id),
+ # we always deal with a _list_ of traces and _list_ of layouts
+ # since they can each have different data
+ layout = list(
+ width = width,
+ height = height,
+ # sane margin defaults (mainly for RStudio)
+ margin = list(b = 40, l = 60, t = 25, r = 10)
+ ),
+ source = source
+ )
+ # ensure the collab button is shown (and the save/edit button is hidden) by default
+ config(as_widget(p))
+}
+
+# (4). new_id
+new_id <- function() {
+ basename(tempfile(""))
+}
+
+# (5). config
+config <- function(p, ..., cloud = FALSE, showSendToCloud = cloud, locale = NULL, mathjax = NULL) {
+
+ if (!is.null(locale)) {
+ p$x$config$locale <- locale
+ # Plotly.js defaults to US English (en-US) and includes
+ # British English (en) in the standard bundle.
+ if (!locale %in% c("en", "en-US")) {
+ p$dependencies <- c(
+ p$dependencies,
+ list(locale_dependency(locale))
+ )
+ }
+ }
+
+ if (!is.null(mathjax)) {
+ mj <- switch(
+ match.arg(mathjax, c("cdn", "local")),
+ cdn = mathjax_cdn(),
+ local = mathjax_local()
+ )
+ # if mathjax is already supplied overwrite it; otherwise, prepend it
+ depNames <- sapply(p$dependencies, "[[", "name")
+ if (any(idx <- depNames %in% "mathjax")) {
+ p$dependencies[[which(idx)]] <- mathjax
+ } else {
+ p$dependencies <- c(list(mj), p$dependencies)
+ }
+ }
+
+ args <- list(...)
+ if ("collaborate" %in% names(args)) warning("The collaborate button is no longer supported")
+ p$x$config <- modify_list(p$x$config, args)
+ if (cloud) warning("The `cloud` argument is deprecated. Use `showSendToCloud` instead.")
+ p$x$config$showSendToCloud <- showSendToCloud
+
+ p
+}
+
+# (6). modify_list & modifyList (which is in R base package)
+modify_list <- function(x, y, ...) {
+ modifyList(x %||% list(), y %||% list())
+}
+"%||%" <- function(x, y) {
+ if (length(x) > 0 || is_blank(x)) x else y
+}
+is_blank <- function(x) {
+ inherits(x, "element_blank") && inherits(x, "element")
+}
+
+# (7). as_widget
+as_widget <- function(x, ...) {
+ if (inherits(x, "htmlwidget")) return(x)
+ # add plotly class mainly for printing method
+ # customize the JSON serializer (for htmlwidgets)
+ attr(x, 'TOJSON_FUNC') <- to_JSON
+ htmlwidgets::createWidget(
+ name = "plotly",
+ x = x,
+ width = x$layout$width,
+ height = x$layout$height,
+ sizingPolicy = htmlwidgets::sizingPolicy(
+ browser.fill = TRUE,
+ defaultWidth = '100%',
+ defaultHeight = 400
+ ),
+ preRenderHook = plotly_build,
+ dependencies = c(
+ # phantomjs doesn't support Object.setPrototypeOf() and a
+ # plotly.js dependency (buffer) uses it to detect TypedArray support.
+ # Thus, we add a polyfill if this is running in shinytest, but otherwise
+ # we shouldn't need it because Object.setPrototypeOf() is pretty widely supported
+ # https://github.com/plotly/plotly.js/issues/4556#issuecomment-583061419
+ # https://caniuse.com/#search=setPrototypeOf
+ if (isTRUE(getOption("shiny.testmode"))) {
+ list(setPrototypeOfPolyfill())
+ },
+ list(typedArrayPolyfill()),
+ crosstalk::crosstalkLibs(),
+ list(plotlyHtmlwidgetsCSS()),
+ list(plotlyMainBundle())
+ )
+ )
+}
+to_JSON <- function(x, ...) {
+ jsonlite::toJSON(x, digits = 50, auto_unbox = TRUE, force = TRUE,
+ null = "null", na = "null", ...)
+}
+typedArrayPolyfill <- function() {
+ htmltools::htmlDependency(
+ name = "typedarray",
+ version = "0.1",
+ package = "plotly",
+ src = dependency_dir("typedarray"),
+ script = "typedarray.min.js",
+ all_files = FALSE
+ )
+}
+dependency_dir <- function(...) {
+ file.path('htmlwidgets', 'lib', ...)
+}
+plotlyHtmlwidgetsCSS <- function() {
+ htmltools::htmlDependency(
+ name = "plotly-htmlwidgets-css",
+ version = plotlyMainBundle()$version,
+ package = "plotly",
+ src = dependency_dir("plotlyjs"),
+ stylesheet = "plotly-htmlwidgets.css",
+ all_files = FALSE
+ )
+}
+plotlyMainBundle <- function() {
+ htmltools::htmlDependency(
+ name = "plotly-main",
+ version = "1.52.2",
+ package = "plotly",
+ src = dependency_dir("plotlyjs"),
+ script = "plotly-latest.min.js",
+ all_files = FALSE
+ )
+}
+
+# (8). plotly build
+plotly_build <- function(p, registerFrames = TRUE) {
+ UseMethod("plotly_build")
+}
+plotly_build.NULL <- function(...) {
+ htmltools::browsable(htmltools::div(...))
+}
+plotly_build.list <- function(p, registerFrames = TRUE) {
+ plotly_build(as_widget(p))
+}
+plotly_build.gg <- function(p, registerFrames = TRUE) {
+ # note: since preRenderHook = plotly_build in as_widget(),
+ # plotly_build.plotly() will be called on gg objects as well
+ plotly_build(ggplotly(p))
+}
+plotly_build.plotly <- function(p, registerFrames = TRUE) {
+
+ # make this plot retrievable
+ set_last_plot(p)
+
+ layouts <- Map(function(x, y) {
+
+ d <- plotly_data(p, y)
+ x <- rapply(x, eval_attr, data = d, how = "list")
+
+ # if an annotation attribute is an array, expand into multiple annotations
+ nAnnotations <- max(lengths(x$annotations) %||% 0)
+ if (!is.null(names(x$annotations))) {
+ # font is the only list object, so store it, and attach after transposing
+ font <- x$annotations[["font"]]
+ x$annotations <- purrr::transpose(lapply(x$annotations, function(x) {
+ as.list(rep(x, length.out = nAnnotations))
+ }))
+ for (i in seq_len(nAnnotations)) {
+ x$annotations[[i]][["font"]] <- font
+ }
+ }
+
+ x[lengths(x) > 0]
+
+ }, p$x$layoutAttrs, names2(p$x$layoutAttrs))
+
+ # get rid of the data -> layout mapping
+ p$x$layoutAttrs <- NULL
+
+ # accumulate, rather than override, annotations.
+ annotations <- Reduce(c, c(
+ list(p$x$layout$annotations),
+ setNames(compact(lapply(layouts, "[[", "annotations")), NULL)
+ ))
+
+ # merge layouts into a single layout (more recent layouts will override older ones)
+ p$x$layout <- modify_list(p$x$layout, Reduce(modify_list, layouts))
+ p$x$layout$annotations <- annotations
+
+ # keep frame mapping for populating layout.slider.currentvalue in animations
+ frameMapping <- unique(unlist(
+ lapply(p$x$attrs, function(x) deparse2(x[["frame"]])),
+ use.names = FALSE
+ ))
+ if (length(frameMapping) > 1) {
+ warning("Only one `frame` variable is allowed", call. = FALSE)
+ }
+
+ # Attributes should be NULL if none exist (rather than an empty list)
+ if (length(p$x$attrs) == 0) p$x$attrs <- NULL
+
+ # If there is just one (unevaluated) trace, and the data is sf, add an sf layer
+ if (length(p$x$attrs) == 1 && !inherits(p$x$attrs[[1]], "plotly_eval") && is_sf(plotly_data(p))) {
+ p <- add_sf(p)
+ }
+
+ # If type was not specified in plot_ly(), it doesn't create a trace unless
+ # there are no other traces
+ if (is.null(p$x$attrs[[1]][["type"]]) && length(p$x$attrs) > 1) {
+ p$x$attrs[[1]] <- NULL
+ }
+
+ # have the attributes already been evaluated?
+ is.evaled <- function(x) inherits(x, "plotly_eval")
+ attrsToEval <- p$x$attrs[!vapply(p$x$attrs, is.evaled, logical(1))]
+
+ # trace type checking and renaming for plot objects
+ if (is_mapbox(p) || is_geo(p)) {
+ p <- geo2cartesian(p)
+ attrsToEval <- lapply(attrsToEval, function(tr) {
+ if (!grepl("scatter|choropleth", tr[["type"]] %||% "scatter")) {
+ stop("Cant add a '", tr[["type"]], "' trace to a map object", call. = FALSE)
+ }
+ if (is_mapbox(p)) tr[["type"]] <- tr[["type"]] %||% "scattermapbox"
+ if (is_geo(p)) {
+ tr[["type"]] <- if (!is.null(tr[["z"]])) "choropleth" else "scattergeo"
+ }
+ tr
+ })
+ }
+
+ dats <- Map(function(x, y) {
+
+ # grab the data for this trace
+ dat <- plotly_data(p, y)
+
+ # formula/symbol/attribute evaluation
+ trace <- structure(
+ rapply(x, eval_attr, data = dat, how = "list"),
+ class = oldClass(x)
+ )
+
+ # determine trace type (if not specified, can depend on the # of data points)
+ # note that this should also determine a sensible mode, if appropriate
+ trace <- verify_type(trace)
+ # verify orientation of boxes/bars
+ trace <- verify_orientation(trace)
+ # supply sensible defaults based on trace type
+ trace <- coerce_attr_defaults(trace, p$x$layout)
+
+
+
+ # attach crosstalk info, if necessary
+ if (crosstalk_key() %in% names(dat) && isTRUE(trace[["inherit"]] %||% TRUE)) {
+ trace[["key"]] <- trace[["key"]] %||% dat[[crosstalk_key()]]
+ trace[["set"]] <- trace[["set"]] %||% attr(dat, "set")
+ }
+
+ # if appropriate, tack on a group index
+ grps <- if (has_group(trace)) tryNULL(dplyr::group_vars(dat))
+ if (length(grps) && any(lengths(trace) == NROW(dat))) {
+ trace[[".plotlyGroupIndex"]] <- interaction(dat[, grps, drop = F])
+ }
+
+ # add sensible axis names to layout
+ for (i in c("x", "y", "z")) {
+ nm <- paste0(i, "axis")
+ idx <- which(names(trace) %in% i)
+ if (length(idx) == 1) {
+ title <- default(deparse2(x[[idx]]))
+ if (is3d(trace$type) || i == "z") {
+ p$x$layout$scene[[nm]]$title <<- p$x$layout$scene[[nm]]$title %||% title
+ } else {
+ p$x$layout[[nm]]$title <<- p$x$layout[[nm]]$title %||% title
+ }
+ }
+ }
+
+ if (inherits(trace, c("plotly_surface", "plotly_contour"))) {
+ # TODO: generate matrix for users?
+ # (1) if z is vector, and x/y are null throw error
+ # (2) if x/y/z are vectors and length(x) * length(y) == length(z), convert z to matrix
+ if (!is.matrix(trace[["z"]]) || !is.numeric(trace[["z"]])) {
+ stop("`z` must be a numeric matrix", call. = FALSE)
+ }
+ }
+
+ # collect non-positional scales, plotly.js data_arrays, and "special"
+ # array attributes for "data training"
+ Attrs <- Schema$traces[[trace[["type"]]]]$attributes
+ isArray <- vapply(Attrs, function(x) {
+ tryFALSE(identical(x[["valType"]], "data_array"))
+ }, logical(1))
+ arrayOk <- vapply(Attrs, function(x) tryNULL(x[["arrayOk"]]) %||% FALSE, logical(1))
+ # "non-tidy" traces allow x/y of different lengths, so ignore those
+ dataArrayAttrs <- if (is_tidy(trace)) names(Attrs)[isArray | arrayOk]
+ allAttrs <- c(
+ dataArrayAttrs, special_attrs(trace), npscales(), "frame",
+ # for some reason, text isn't listed as a data array in some traces
+ # I'm looking at you scattergeo...
+ ".plotlyGroupIndex", "text", "key", "fillcolor", "name", "legendgroup"
+ )
+ tr <- trace[names(trace) %in% allAttrs]
+ # TODO: does it make sense to "train" matrices/2D-tables (e.g. z)?
+ tr <- tr[vapply(tr, function(x) is.null(dim(x)) && is.atomic(x), logical(1))]
+ # white-list customdata as this can be a non-atomic vector
+ tr$customdata <- trace$customdata
+ builtData <- tibble::as_tibble(tr)
+ # avoid clobbering I() (i.e., variables that shouldn't be scaled)
+ for (i in seq_along(tr)) {
+ if (inherits(tr[[i]], "AsIs")) builtData[[i]] <- I(builtData[[i]])
+ }
+
+ if (NROW(builtData) > 0) {
+ # Build the index used to split one "trace" into multiple traces
+ isAsIs <- vapply(builtData, function(x) inherits(x, "AsIs"), logical(1))
+ isDiscrete <- vapply(builtData, is.discrete, logical(1))
+ # note: can only have one linetype per trace
+ isSplit <- names(builtData) %in% c("split", "linetype", "frame", "fillcolor", "name") |
+ !isAsIs & isDiscrete & names(builtData) %in% c("symbol", "color")
+ if (any(isSplit)) {
+ paste2 <- function(x, y) if (identical(x, y)) x else paste(x, y, sep = br())
+ splitVars <- builtData[isSplit]
+ builtData[[".plotlyTraceIndex"]] <- Reduce(paste2, splitVars)
+ # in registerFrames() we need to strip the frame from .plotlyTraceIndex
+ # so keep track of which variable it is...
+ trace$frameOrder <- which(names(splitVars) %in% "frame")
+ }
+ # Build the index used to determine grouping (later on, NAs are inserted
+ # via group2NA() to create the groups). This is done in 3 parts:
+ # 1. Sort data by the trace index since groups are nested within traces.
+ # 2. Translate missing values on positional scales to a grouping variable.
+ # If grouping isn't relevant for this trace, a warning is thrown since
+ # NAs are removed.
+ # 3. The grouping from (2) and any groups detected via dplyr::groups()
+ # are combined into a single grouping variable, .plotlyGroupIndex
+ builtData <- arrange_safe(builtData, ".plotlyTraceIndex")
+ isComplete <- complete.cases(builtData[names(builtData) %in% c("x", "y", "z")])
+ # warn about missing values if groups aren't relevant for this trace type
+ if (any(!isComplete) && !has_group(trace)) {
+ warning("Ignoring ", sum(!isComplete), " observations", call. = FALSE)
+ }
+ builtData[[".plotlyMissingIndex"]] <- cumsum(!isComplete)
+ builtData <- builtData[isComplete, ]
+ if (length(grps) && has_group(trace) && isTRUE(trace[["connectgaps"]])) {
+ stop(
+ "Can't use connectgaps=TRUE when data has group(s).", call. = FALSE
+ )
+ }
+ builtData[[".plotlyGroupIndex"]] <- interaction(
+ builtData[[".plotlyGroupIndex"]] %||% "",
+ builtData[[".plotlyMissingIndex"]]
+ )
+ builtData <- arrange_safe(builtData,
+ c(".plotlyTraceIndex", ".plotlyGroupIndex",
+ if (inherits(trace, "plotly_line")) "x")
+ )
+ builtData <- train_data(builtData, trace)
+ trace[[".plotlyVariableMapping"]] <- names(builtData)
+ # copy over to the trace data
+ for (i in names(builtData)) {
+ trace[[i]] <- builtData[[i]]
+ }
+ }
+ # TODO: provide a better way to clean up "high-level" attrs
+ trace[c("ymin", "ymax", "yend", "xend")] <- NULL
+ trace[lengths(trace) > 0]
+
+ }, attrsToEval, names2(attrsToEval))
+
+ p$x$attrs <- lapply(p$x$attrs, function(x) structure(x, class = "plotly_eval"))
+
+ # traceify by the interaction of discrete variables
+ traces <- list()
+ for (i in seq_along(dats)) {
+ d <- dats[[i]]
+ scaleAttrs <- names(d) %in% paste0(npscales(), "s")
+ traces <- c(traces, traceify(d[!scaleAttrs], d$.plotlyTraceIndex))
+ if (i == 1) traces[[1]] <- c(traces[[1]], d[scaleAttrs])
+ }
+
+ # insert NAs to differentiate groups
+ traces <- lapply(traces, function(x) {
+ d <- tibble::as_tibble(x[names(x) %in% x$.plotlyVariableMapping])
+ d <- group2NA(
+ d, if (has_group(x)) ".plotlyGroupIndex",
+ ordered = if (inherits(x, "plotly_line")) "x",
+ retrace.first = inherits(x, "plotly_polygon")
+ )
+ for (i in x$.plotlyVariableMapping) {
+ # try to reduce the amount of data we have to send for non-positional scales
+ entry <- if (i %in% npscales()) uniq(d[[i]]) else d[[i]]
+ if (is.null(entry)) {
+ x[[i]] <- NULL
+ } else {
+ x[[i]] <- structure(entry, class = oldClass(x[[i]]))
+ }
+ }
+ x
+ })
+
+ # Map special plot_ly() arguments to plotly.js trace attributes.
+ # Note that symbol/linetype can modify the mode, so those are applied first
+ # TODO: use 'legends 2.0' to create legends for these discrete mappings
+ # https://github.com/plotly/plotly.js/issues/1668
+ if (length(traces)) {
+ traces <- map_symbol(traces)
+ traces <- map_linetype(traces)
+ traces <- map_size(traces)
+ traces <- map_size(traces, stroke = TRUE) #i.e., span
+ colorTitle <- unlist(lapply(p$x$attrs, function(x) { deparse2(x[["color"]] %||% x[["z"]]) }))
+ strokeTitle <- unlist(lapply(p$x$attrs, function(x) deparse2(x[["stroke"]])))
+ traces <- map_color(traces, title = paste(colorTitle, collapse = br()), colorway = colorway(p))
+ traces <- map_color(traces, stroke = TRUE, title = paste(strokeTitle, collapse = br()), colorway = colorway(p))
+ }
+
+ for (i in seq_along(traces)) {
+ # remove special mapping attributes
+ mappingAttrs <- c(
+ "alpha", "alpha_stroke", npscales(), paste0(npscales(), "s"),
+ ".plotlyGroupIndex", ".plotlyMissingIndex",
+ ".plotlyTraceIndex", ".plotlyVariableMapping", "inherit"
+ )
+ for (j in mappingAttrs) {
+ traces[[i]][[j]] <- NULL
+ }
+ }
+
+ # .crossTalkKey -> key
+ traces <- lapply(traces, function(x) {
+ setNames(x, sub(crosstalk_key(), "key", names(x), fixed = TRUE))
+ })
+
+ # it's possible that the plot object already has some traces
+ # (like figures pulled from a plotly server)
+ p$x$data <- setNames(c(p$x$data, traces), NULL)
+
+ # supply linked highlighting options/features
+ p <- supply_highlight_attrs(p)
+
+ # supply trace anchor and domain information
+ p <- supply_defaults(p)
+
+ # attribute naming corrections for "geo-like" traces
+ p <- cartesian2geo(p)
+
+ # Compute sensible bounding boxes for each mapbox/geo subplot
+ p <- fit_bounds(p)
+
+ # polar charts don't like null width/height keys
+ if (is.null(p$x$layout[["height"]])) p$x$layout[["height"]] <- NULL
+ if (is.null(p$x$layout[["width"]])) p$x$layout[["width"]] <- NULL
+
+ # ensure we get the order of categories correct
+ # (plotly.js uses the order in which categories appear by default)
+ p <- populate_categorical_axes(p)
+ # translate '\n' to '<br />' in text strings
+ p <- translate_linebreaks(p)
+ # if it makes sense, add markers/lines/text to mode
+ p <- verify_mode(p)
+ # annotations & shapes must be an array of objects
+ # TODO: should we add anything else to this?
+ p <- verify_arrays(p)
+ # set a sensible hovermode if it hasn't been specified already
+ p <- verify_hovermode(p)
+ # try to convert to webgl if toWebGl was used
+ p <- verify_webgl(p)
+ # throw warning if webgl is being used in shinytest
+ # currently, shinytest won't rely this warning, but it should
+ # https://github.com/rstudio/shinytest/issues/146
+ if (isTRUE(getOption("shiny.testmode"))) {
+ if (is.webgl(p)) warning("shinytest can't currently render WebGL-based graphics.")
+ }
+ # crosstalk dynamically adds traces, meaning that a legend could be dynamically
+ # added, which is confusing. So here we populate a sensible default.
+ p <- verify_showlegend(p)
+
+ # NOTE: this needs to occur *before* registering frames so simple/nested key
+ # flags get passed onto frame data.
+ p <- verify_key_type(p)
+
+ if (registerFrames) {
+ p <- registerFrames(p, frameMapping = frameMapping)
+ }
+
+ # set the default plotly.js events to register in shiny
+ p <- shiny_defaults_set(p)
+
+ p <- verify_guides(p)
+
+ # verify colorscale attributes are in a sensible data structure
+ p <- verify_colorscale(p)
+
+ # verify plot attributes are legal according to the plotly.js spec
+ p <- verify_attr_names(p)
+ # box up 'data_array' attributes where appropriate
+ p <- verify_attr_spec(p)
+
+ # make sure we're including mathjax (if TeX() is used)
+ p <- verify_mathjax(p)
+
+ # if a partial bundle was specified, make sure it supports the visualization
+ p <- verify_partial_bundle(p)
+
+ # scattergl currently doesn't render in RStudio on Windows
+ # https://github.com/ropensci/plotly/issues/1214
+ p <- verify_scattergl_platform(p)
+
+ # make sure plots don't get sent out of the network (for enterprise)
+ p$x$base_url <- get_domain()
+ p
+}
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/enrich_graphics.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/enrich_graphics.R
new file mode 100755
index 0000000000000000000000000000000000000000..1938ce2e4c1cc07584b622424e52170fa147df5e
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/enrich_graphics.R
@@ -0,0 +1,905 @@
+#'View individual compounds related to a given metabolite set
+#'@description View individual compounds related to a given metabolite set
+#'Functions for various plots for enrichment analysis
+#'@usage PlotQEA.MetSet(mSetObj=NA, setNM, format="png", dpi=72, width=NA)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param setNM Input the name of the metabolite set
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+PlotQEA.MetSet<-function(mSetObj=NA, setNM, format="png", dpi=72, width=NA){
+#browser() #Disabled by ZZY on 3/16/2021.
+ mSetObj <- .get.mSet(mSetObj);
+ # clean the name, some contains space and special characters, will
+ # cause trouble as image name
+ imgNM <- gsub("\\|", "_", setNM);
+ imgNM <- gsub("/", "_", imgNM);
+ imgNM <- gsub(" *", "", imgNM);
+ if(nchar(imgNM) > 18){
+ imgNM <-substr(imgNM, 0, 18);
+ }
+ imgName <- paste(imgNM, "dpi", dpi, ".", format, sep="");
+
+ if(is.na(width)){
+ w <- 7;
+ }else if(width == 0){
+ w <- 7;
+ }else{
+ w <- width;
+ }
+
+ h <- w;
+
+ mSetObj$imgSet$qea.mset<-imgName;
+
+ # hits in the current mset
+ mset <- current.msetlib$member[[setNM]];
+ hit.cmpds <- mSetObj$analSet$qea.hits[[setNM]];
+ hit.pvals <- mSetObj$analSet$qea.pvals[hit.cmpds];
+
+ #reorder based on p vals
+ ord.inx <- order(hit.pvals);
+ hit.cmpds <- hit.cmpds[ord.inx];
+ hit.pvals <- signif(hit.pvals[ord.inx],3);
+
+ if(.on.public.web){
+ load_lattice()
+ load_ggplot()
+ }
+
+ # get p values
+ mSetObj$analSet$qea.pvals[];
+
+ # need to reshape data to be one vector
+ num <- length(hit.cmpds);
+ len <- length(mSetObj$dataSet$cls);
+ conc.vec <- lbl.vec <- cls.vec <- NULL;
+
+ for(i in 1:num){
+ cmpd <- hit.cmpds[i];
+ conc.vec <- c(conc.vec, mSetObj$analSet$msea.data[,cmpd]);
+ cls.vec <- c(cls.vec, as.character(mSetObj$dataSet$cls));
+ cmpd.p <- paste(cmpd, " (p=", hit.pvals[i], ")", sep="");
+ lbl.vec <- c(lbl.vec, rep(cmpd.p, len));
+ }
+
+ cls.vec <- as.factor(cls.vec);
+ lbl.vec <- factor(lbl.vec, levels = unique(lbl.vec));
+
+ num <- length(hit.cmpds);
+ boxdata <- data.frame(Feature = lbl.vec, Abundance = conc.vec, Class = cls.vec)
+
+ # calculate width based on the dataset number
+ if(num == 1){
+
+ p <- ggplot(data = boxdata, aes(x=Class, y=Abundance)) + geom_boxplot(aes(fill=Class), outlier.shape = NA, outlier.colour=NA)
+ p <- p + theme(plot.title = element_text(hjust = 0.5)) + guides(fill=guide_legend(title="Group"))
+ p <- p + xlab("") + ylab("Relative Abundance") + theme_bw()
+
+ ggsave(p, filename = imgName, dpi=dpi, width=7, height=6, limitsize = FALSE)
+
+ }else{
+
+ if(num<10){
+ w = 10
+ h <- 10 * num/10
+ cols = 3
+ }else if(num<5){
+ w = 7
+ h = 7
+ cols = 2
+ }else{
+ w = 10
+ h <- num * 0.55
+ cols = 4
+ }
+
+ bp <- ggplot(boxdata, aes(x=Class, y=Abundance, group=Class)) +
+ geom_boxplot(aes(fill=Class), outlier.shape = NA, outlier.colour=NA) + theme_bw()
+
+ bp <- bp + facet_wrap(. ~ Feature) + theme(strip.text.x = element_text(size=7), strip.background = element_rect(size=1)) +
+ xlab("") + ylab("Relative Abundance")
+
+ ggsave(bp, filename = imgName, dpi=dpi, width=w, height=h, limitsize = FALSE)
+ }
+
+ mSetObj$imgSet$current.img <- imgName;
+
+ if(.on.public.web){
+ .set.mSet(mSetObj);
+ return(imgName);
+ }
+ return(.set.mSet(mSetObj));
+}
+
+#'Plot the compound concentration data compared to the reference concentration range
+#'@description Plot the compound concentration data compared to the reference concentration range
+#'@usage PlotConcRange(mSetObj, nm, format="png", dpi=72, width=NA)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param nm of the input compound
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+PlotConcRange<-function(mSetObj=NA, nm, format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ inx <- which(names(mSetObj$analSet$ssp.lows)==nm);
+ lows <- mSetObj$analSet$ssp.lows[[inx]];
+
+ if(length(lows)==1 && is.na(lows)){
+ return();
+ }
+
+ #conc<-dataSet$norm[inx];
+ means <- mSetObj$analSet$ssp.means[[inx]];
+ highs <- mSetObj$analSet$ssp.highs[[inx]];
+
+ cmpdNm <- mSetObj$analSet$ssp.mat[inx,1];
+ conc <- as.numeric(mSetObj$analSet$ssp.mat[inx,2]);
+ hmdbID <- mSetObj$analSet$ssp.mat[inx,3];
+ imgName <<- paste(hmdbID, "dpi", dpi, ".png", sep="");
+
+ if(is.na(width)){
+ w <- h <- 7;
+ }else if(width == 0){
+ w <- 7;
+ }else{
+ w <- h <- width;
+ }
+
+ mSetObj$imgSet$conc.range <- imgName;
+ mSetObj$imgSet$current.img <- imgName;
+
+ rng <- range(lows, highs, conc);
+ ext <- (rng[2]-rng[1])/8;
+ max.rg <- rng[2]+ext;
+ min.rg <- ifelse(rng[1]-ext>=0, rng[1]-ext, 0);
+ unit <- "(umol)"
+ if(mSetObj$dataSet$biofluid =="urine"){
+ unit <- "(umol/mmol_creatine)"
+ }
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ concplot(means, lows, highs, xlim=c(min.rg, max.rg), labels = paste("Study ", 1:length(lows)),
+ main=cmpdNm, xlab=paste("Concentration Range", unit), ylab="Study Reference")
+ abline(v=c(range(lows, highs), conc), col=c("lightgrey", "lightgrey", "orange"), lty=c(5, 5, 5), lwd=c(1,1,2));
+
+ # label the measured the concentration to the side
+ text(conc, 0, conc, pos=4, col="orange");
+ # extend the left end of axis to look natural without labeling
+ axis(1, at=c(min.rg-ext, min.rg), label=F, lwd.tick=0);
+
+ dev.off();
+
+ mSetObj$imgSet$current.img <- imgName;
+
+ if(.on.public.web){
+ .set.mSet(mSetObj);
+ return(imgName);
+ }
+
+ return(.set.mSet(mSetObj));
+}
+
+#'Plot over-representation analysis (ORA)
+#'@description Plot over-representation analysis (ORA)
+#'@usage PlotORA(mSetObj=NA, imgName, imgOpt, format="png", dpi=72, width=NA)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param imgName Input a name for the plot
+#'@param imgOpt "net"
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+PlotORA1<-function(mSetObj=NA, imgName, imgOpt, format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ #calculate the enrichment fold change
+ folds <- mSetObj$analSet$ora.mat[,3]/mSetObj$analSet$ora.mat[,2];
+ names(folds) <- GetShortNames(rownames(mSetObj$analSet$ora.mat));
+ pvals <- mSetObj$analSet$ora.mat[,4];
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+
+ if(is.na(width)){
+ w <- 9;
+ }else if(width == 0){
+ w <- 7;
+ }else{
+ w <-width;
+ }
+ h <- w;
+
+ #record img
+ mSetObj$imgSet$ora <- imgName
+ mSetObj$imgSet$current.img <- imgName;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+
+ PlotMSEA.Overview(folds, pvals);
+ dev.off();
+ if(.on.public.web){
+ mSetObj$analSet$enrich.net <- PlotEnrichNet.Overview(folds, pvals);
+ }
+
+ return(.set.mSet(mSetObj));
+}
+
+#'Plot QEA overview
+#'@description Plot QEA overview
+#'@usage PlotQEA.Overview(mSetObj=NA, imgName, imgOpt, format="png", dpi=72, width=NA)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param imgName Input a name for the plot
+#'@param imgOpt "net"
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotQEA.Overview1 <-function(mSetObj=NA, imgName, imgOpt, format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ #calculate the enrichment fold change
+ folds <- mSetObj$analSet$qea.mat[,3]/mSetObj$analSet$qea.mat[,4];
+ names(folds) <- GetShortNames(rownames(mSetObj$analSet$qea.mat));
+ pvals <- mSetObj$analSet$qea.mat[, "Raw p"];
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+
+ if(is.na(width)){
+ w <- 9;
+ }else if(width == 0){
+ w <- 7;
+ }else{
+ w <- width;
+ }
+ h <- w;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ PlotMSEA.Overview(folds, pvals);
+ dev.off();
+
+ if(.on.public.web){
+ mSetObj$analSet$enrich.net <- PlotEnrichNet.Overview(folds, pvals);
+ }
+
+ mSetObj$imgSet$qea <-imgName;
+ mSetObj$imgSet$current.img <- imgName;
+ return(.set.mSet(mSetObj));
+}
+
+#'Plot MSEA overview
+#'@description Barplot height is enrichment fold change
+#'color is based on p values, used in higher functions
+#'@usage PlotMSEA.Overview(folds, pvals)
+#'@param folds Input the fold-change values
+#'@param pvals Input the p-values
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotMSEA.Overview <- function(folds, pvals){
+
+ # due to space limitation, plot top 50 if more than 50 were given
+ title <- "Metabolite Sets Enrichment Overview";
+ ht.col <- GetMyHeatCols(length(folds));
+ if(length(folds) > 25){
+ folds <- folds[1:25];
+ pvals <- pvals[1:25];
+ ht.col <- ht.col[1:25];
+ title <- "Enrichment Overview (top 25)";
+ }
+
+ op <- par(mar=c(5,20,4,6), oma=c(0,0,0,4));
+
+ barplot(rev(folds), horiz=T, col=rev(ht.col),
+ xlab="Enrichment Ratio", las=1, cex.name=0.75, space=c(0.5, 0.5),
+ main= title);
+ minP <- min(pvals);
+ maxP <- max(pvals);
+ medP <- (minP+maxP)/2;
+
+ axs.args <- list(at=c(minP, medP, maxP), labels=format(c(maxP, medP, minP), scientific=T, digit=1), tick = F);
+ image.plot(legend.only=TRUE, zlim=c(minP, maxP), col=rev(ht.col),
+ axis.args=axs.args, legend.shrink = 0.4, legend.lab="P value");
+ par(op);
+}
+
+#'Plot MSEA Dot Plot
+#'@description Dot plot of enrichment analysis results.
+#'@usage PlotEnrichDotPlot(mSet)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param enrichType Input whether the enrichment analysis was over-respresentation
+#'analysis (ora) or quantitative enrichment analysis (qea).
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+PlotEnrichDotPlot1 <- function(mSetObj=NA, enrichType = "ora", imgName, format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(.on.public.web){
+ load_ggplot()
+ }
+
+ if(enrichType == "ora"){
+ results <- mSetObj$analSet$ora.mat
+ my.cols <- GetMyHeatCols(nrow(results));
+ if(nrow(results) > 25){
+ results <- results[1:25,]
+ my.cols <- my.cols[1:25];
+ }
+
+ df <- data.frame(Name = factor(row.names(results), levels = rev(row.names(results))),
+ rawp = results[,4],
+ logp = -log10(results[,4]),
+ folds = results[,3]/results[,2])
+
+ }else if(enrichType == "qea"){
+ results <- mSetObj$analSet$qea.mat
+ my.cols <- GetMyHeatCols(nrow(results));
+ if(nrow(results) > 25){
+ results <- results[1:25,]
+ my.cols <- my.cols[1:25];
+ }
+ df <- data.frame(Name = factor(row.names(results), levels = rev(row.names(results))),
+ rawp = results[,5],
+ logp = -log10(results[,5]),
+ folds = results[,3]/results[,4]
+ )
+
+ }
+
+ maxp <- max(df$rawp);
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+
+ if(is.na(width)){
+ w <- 12;
+ h <- 9;
+ }else if(width == 0){
+ h <- w <- 7;
+ }else{
+ h <- w <- width;
+ }
+
+ p <- ggplot(df,
+ aes(x = logp, y = Name)) +
+ geom_point(aes(size = folds, color = rawp)) + scale_size_continuous(range = c(2, 8)) +
+ theme_bw(base_size = 14.5) +
+ scale_colour_gradient(limits=c(0, maxp), low=my.cols[1], high = my.cols[length(my.cols)]) +
+ ylab(NULL) + xlab("-log10 (p-value)") +
+ ggtitle("Overview of Enriched Metabolite Sets (Top 25)") +
+ theme(legend.text=element_text(size=14),
+ legend.title=element_text(size=15))
+
+ p$labels$colour <- "P-value"
+ p$labels$size <- "Enrichment Ratio"
+
+ ggsave(p, filename = imgName, dpi=dpi, width=w, height=h)
+
+ if(enrichType == "ora"){
+ mSetObj$imgSet$ora <- imgName
+ }else if(enrichType == "qea"){
+ mSetObj$imgSet$qea <-imgName;
+ }
+
+ mSetObj$imgSet$current.img <- imgName;
+ return(.set.mSet(mSetObj));
+}
+
+# Utility function
+concplot <- function(mn, lower, upper, labels=NULL,
+ xlab = "Odds ratio", ylab = "Study Reference",
+ xlim = NULL, line.col = "blue", text.col="forestgreen",
+ xaxt="s", ... ) {
+
+ n <- length( mn );
+ nxlim <- xlim;
+ nxlim[1] <- nxlim[1] - 0.25 * (nxlim[2] - nxlim[1] );
+ par(xaxt = "n",yaxt = "n")
+ plot(nxlim,c(1,-n-2),
+ type = "n", bty = "n", xaxt = "n", yaxt = "n",
+ xlab=xlab, ylab=ylab,... );
+
+ text(rep(nxlim[1], n ), -( 1:n ), labels,..., col=rep(text.col,length.out=n),adj=0);
+ par( xaxt = "s")
+ ats<-pretty(xlim, 6);
+ axis(1, at=ats)
+
+ for ( i in 1:n ){
+ if ( is.na( lower[i]+upper[i] ) )
+ next
+ arrows(lower[i], -i, upper[i], -i, lwd = 1, code=3, col=line.col, angle=90, length=0.04);
+ points(mn[i], -i, pch=15, col='magenta');
+ }
+}
+
+# Plot a strip of color key beside a figure
+# Adapted from the image.plot in fields package to correct label
+# so that the small p value is bigger, located on top of the color key
+# Jeff Xia, jeff.xia@mcgill.ca
+# McGill University, Canada
+# License: GNU GPL (>= 2)
+
+image.plot <- function(..., add = FALSE, nlevel = 64,
+ horizontal = FALSE, legend.shrink = 0.9, legend.width = 1.2,
+ legend.mar = ifelse(horizontal, 3.1, 5.1), legend.lab = NULL,
+ graphics.reset = FALSE, bigplot = NULL, smallplot = NULL,
+ legend.only = FALSE, col = tim.colors(nlevel), lab.breaks = NULL,
+ axis.args = NULL, legend.args = NULL, midpoint = FALSE) {
+
+ old.par <- par(no.readonly = TRUE)
+ # figure out zlim from passed arguments
+ info <- image.plot.info(...)
+ if (add) {
+ big.plot <- old.par$plt
+ }
+ if (legend.only) {
+ graphics.reset <- TRUE
+ }
+ if (is.null(legend.mar)) {
+ legend.mar <- ifelse(horizontal, 3.1, 5.1)
+ }
+ #
+ # figure out how to divide up the plotting real estate.
+ #
+ temp <- image.plot.plt(add = add, legend.shrink = legend.shrink,
+ legend.width = legend.width, legend.mar = legend.mar,
+ horizontal = horizontal, bigplot = bigplot, smallplot = smallplot)
+ #
+ # bigplot are plotting region coordinates for image
+ # smallplot are plotting coordinates for legend
+ smallplot <- temp$smallplot
+ bigplot <- temp$bigplot
+ #
+ # draw the image in bigplot, just call the R base function
+ # or poly.image for polygonal cells note logical switch
+ # for poly.grid parsed out of call from image.plot.info
+ if (!legend.only) {
+ if (!add) {
+ par(plt = bigplot)
+ }
+ if (!info$poly.grid) {
+ image(..., add = add, col = col)
+ }
+ else {
+ poly.image(..., add = add, col = col, midpoint = midpoint)
+ }
+ big.par <- par(no.readonly = TRUE)
+ }
+ ##
+ ## check dimensions of smallplot
+ if ((smallplot[2] < smallplot[1]) | (smallplot[4] < smallplot[3])) {
+ par(old.par)
+ stop("plot region too small to add legend\n")
+ }
+ # Following code draws the legend using the image function
+ # and a one column image.
+ # calculate locations for colors on legend strip
+ ix <- 1
+ minz <- info$zlim[1]
+ maxz <- info$zlim[2]
+ binwidth <- (maxz - minz)/nlevel
+ midpoints <- seq(minz + binwidth/2, maxz - binwidth/2, by = binwidth)
+ iy <- midpoints
+ iz <- matrix(iy, nrow = 1, ncol = length(iy))
+ # extract the breaks from the ... arguments
+ # note the breaks delineate intervals of common color
+ breaks <- list(...)$breaks
+ # draw either horizontal or vertical legends.
+ # using either suggested breaks or not -- a total of four cases.
+ #
+ # next par call sets up a new plotting region just for the legend strip
+ # at the smallplot coordinates
+ par(new = TRUE, pty = "m", plt = smallplot, err = -1)
+ # create the argument list to draw the axis
+ # this avoids 4 separate calls to axis and allows passing extra
+ # arguments.
+ # then add axis with specified lab.breaks at specified breaks
+ if (!is.null(breaks) & !is.null(lab.breaks)) {
+ # axis with labels at break points
+ axis.args <- c(list(side = ifelse(horizontal, 1, 4),
+ mgp = c(3, 1, 0), las = ifelse(horizontal, 0, 2),
+ at = breaks, labels = lab.breaks), axis.args)
+ }
+ else {
+ # If lab.breaks is not specified, with or without breaks, pretty
+ # tick mark locations and labels are computed internally,
+ # or as specified in axis.args at the function call
+ axis.args <- c(list(side = ifelse(horizontal, 1, 4),
+ mgp = c(3, 1, 0), las = ifelse(horizontal, 0, 2)),
+ axis.args)
+ }
+ #
+ # draw color scales the four cases are horizontal/vertical breaks/no breaks
+ # add a label if this is passed.
+ if (!horizontal) {
+ if (is.null(breaks)) {
+ image(ix, iy, iz, xaxt = "n", yaxt = "n", xlab = "",
+ ylab = "", col = col)
+ }
+ else {
+ image(ix, iy, iz, xaxt = "n", yaxt = "n", xlab = "",
+ ylab = "", col = col, breaks = breaks)
+ }
+ }
+ else {
+ if (is.null(breaks)) {
+ image(iy, ix, t(iz), xaxt = "n", yaxt = "n", xlab = "",
+ ylab = "", col = col)
+ }
+ else {
+ image(iy, ix, t(iz), xaxt = "n", yaxt = "n", xlab = "",
+ ylab = "", col = col, breaks = breaks)
+ }
+ }
+
+ #
+ # now add the axis to the legend strip.
+ # notice how all the information is in the list axis.args
+ #
+ do.call("axis", axis.args)
+
+ # add a box around legend strip
+ box()
+
+ #
+ # add a label to the axis if information has been supplied
+ # using the mtext function. The arguments to mtext are
+ # passed as a list like the drill for axis (see above)
+ #
+ if (!is.null(legend.lab)) {
+ legend.args <- list(text = legend.lab, side = ifelse(horizontal,
+ 1, 3), line = 1)
+ }
+ #
+ # add the label using mtext function
+ if (!is.null(legend.args)) {
+ do.call(mtext, legend.args)
+ }
+ #
+ #
+ # clean up graphics device settings
+ # reset to larger plot region with right user coordinates.
+ mfg.save <- par()$mfg
+ if (graphics.reset | add) {
+ par(old.par)
+ par(mfg = mfg.save, new = FALSE)
+ invisible()
+ }
+ else {
+ par(big.par)
+ par(plt = big.par$plt, xpd = FALSE)
+ par(mfg = mfg.save, new = FALSE)
+ invisible()
+ }
+}
+
+
+"image.plot.info" <- function(...) {
+ temp <- list(...)
+ #
+ xlim <- NA
+ ylim <- NA
+ zlim <- NA
+ poly.grid <- FALSE
+ #
+ # go through various cases of what these can be
+ #
+ ##### x,y,z list is first argument
+ if (is.list(temp[[1]])) {
+ xlim <- range(temp[[1]]$x, na.rm = TRUE)
+ ylim <- range(temp[[1]]$y, na.rm = TRUE)
+ zlim <- range(temp[[1]]$z, na.rm = TRUE)
+ if (is.matrix(temp[[1]]$x) & is.matrix(temp[[1]]$y) &
+ is.matrix(temp[[1]]$z)) {
+ poly.grid <- TRUE
+ }
+ }
+ ##### check for polygrid first three arguments should be matrices
+ #####
+ if (length(temp) >= 3) {
+ if (is.matrix(temp[[1]]) & is.matrix(temp[[2]]) & is.matrix(temp[[3]])) {
+ poly.grid <- TRUE
+ }
+ }
+ ##### z is passed without an x and y (and not a poly.grid!)
+ #####
+ if (is.matrix(temp[[1]]) & !poly.grid) {
+ xlim <- c(0, 1)
+ ylim <- c(0, 1)
+ zlim <- range(temp[[1]], na.rm = TRUE)
+ }
+ ##### if x,y,z have all been passed find their ranges.
+ ##### holds if poly.grid or not
+ #####
+ if (length(temp) >= 3) {
+ if (is.matrix(temp[[3]])) {
+ xlim <- range(temp[[1]], na.rm = TRUE)
+ ylim <- range(temp[[2]], na.rm = TRUE)
+ zlim <- range(temp[[3]], na.rm = TRUE)
+ }
+ }
+ #### parse x,y,z if they are named arguments
+ # determine if this is polygon grid (x and y are matrices)
+ if (is.matrix(temp$x) & is.matrix(temp$y) & is.matrix(temp$z)) {
+ poly.grid <- TRUE
+ }
+ xthere <- match("x", names(temp))
+ ythere <- match("y", names(temp))
+ zthere <- match("z", names(temp))
+ if (!is.na(zthere))
+ zlim <- range(temp$z, na.rm = TRUE)
+ if (!is.na(xthere))
+ xlim <- range(temp$x, na.rm = TRUE)
+ if (!is.na(ythere))
+ ylim <- range(temp$y, na.rm = TRUE)
+ # overwrite zlims with passed values
+ if (!is.null(temp$zlim))
+ zlim <- temp$zlim
+ if (!is.null(temp$xlim))
+ xlim <- temp$xlim
+ if (!is.null(temp$ylim))
+ ylim <- temp$ylim
+ list(xlim = xlim, ylim = ylim, zlim = zlim, poly.grid = poly.grid)
+}
+
+# fields, Tools for spatial data
+# Copyright 2004-2007, Institute for Mathematics Applied Geosciences
+# University Corporation for Atmospheric Research
+# Licensed under the GPL -- www.gpl.org/licenses/gpl.html
+
+image.plot.plt <- function(x, add = FALSE, legend.shrink = 0.9,
+ legend.width = 1, horizontal = FALSE, legend.mar = NULL,
+ bigplot = NULL, smallplot = NULL, ...) {
+ old.par <- par(no.readonly = TRUE)
+ if (is.null(smallplot))
+ stick <- TRUE
+ else stick <- FALSE
+ if (is.null(legend.mar)) {
+ legend.mar <- ifelse(horizontal, 3.1, 5.1)
+ }
+ # compute how big a text character is
+ char.size <- ifelse(horizontal, par()$cin[2]/par()$din[2],
+ par()$cin[1]/par()$din[1])
+ # This is how much space to work with based on setting the margins in the
+ # high level par command to leave between strip and big plot
+ offset <- char.size * ifelse(horizontal, par()$mar[1], par()$mar[4])
+ # this is the width of the legned strip itself.
+ legend.width <- char.size * legend.width
+ # this is room for legend axis labels
+ legend.mar <- legend.mar * char.size
+ # smallplot is the plotting region for the legend.
+ if (is.null(smallplot)) {
+ smallplot <- old.par$plt
+ if (horizontal) {
+ smallplot[3] <- legend.mar
+ smallplot[4] <- legend.width + smallplot[3]
+ pr <- (smallplot[2] - smallplot[1]) * ((1 - legend.shrink)/2)
+ smallplot[1] <- smallplot[1] + pr
+ smallplot[2] <- smallplot[2] - pr
+ }
+ else {
+ smallplot[2] <- 1 - legend.mar
+ smallplot[1] <- smallplot[2] - legend.width
+ pr <- (smallplot[4] - smallplot[3]) * ((1 - legend.shrink)/2)
+ smallplot[4] <- smallplot[4] - pr
+ smallplot[3] <- smallplot[3] + pr
+ }
+ }
+ if (is.null(bigplot)) {
+ bigplot <- old.par$plt
+ if (!horizontal) {
+ bigplot[2] <- min(bigplot[2], smallplot[1] - offset)
+ }
+ else {
+ bottom.space <- old.par$mar[1] * char.size
+ bigplot[3] <- smallplot[4] + offset
+ }
+ }
+ if (stick & (!horizontal)) {
+ dp <- smallplot[2] - smallplot[1]
+ smallplot[1] <- min(bigplot[2] + offset, smallplot[1])
+ smallplot[2] <- smallplot[1] + dp
+ }
+ return(list(smallplot = smallplot, bigplot = bigplot))
+}
+
+#'Barplot height is enrichment fold change
+#'@description Used in higher functions, the color is based on p values
+#'@param folds Input fold-change for bar plot
+#'@param pvals Input p-values for bar plot
+#'@param layoutOpt Input the layout option, default is set to layout.fruchterman.reingold
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'@import igraph
+#'@import reshape
+
+PlotEnrichNet.Overview <- function(folds, pvals, layoutOpt=layout.fruchterman.reingold){
+
+ # due to space limitation, plot top 50 if more than 50 were given
+ title <- "Enrichment Network Overview";
+ if(length(folds) > 50){
+ folds <- folds[1:50];
+ pvals <- pvals[1:50];
+ title <- "Enrichment Overview (top 50)";
+ }
+
+ if(.on.public.web){
+ load_igraph()
+ load_reshape()
+ }
+
+ pvalue <- pvals;
+ id <- names(pvalue);
+ geneSets <- current.msetlib$member;
+ n <- length(pvalue);
+ w <- matrix(NA, nrow=n, ncol=n);
+ colnames(w) <- rownames(w) <- id;
+
+ for (i in 1:n) {
+ for (j in i:n) {
+ w[i,j] = overlap_ratio(geneSets[id[i]], geneSets[id[j]])
+ }
+ }
+
+ wd <- melt(w);
+ wd <- wd[wd[,1] != wd[,2],];
+ wd <- wd[!is.na(wd[,3]),];
+ g <- graph.data.frame(wd[,-3], directed=F);
+ E(g)$width <- sqrt(wd[,3]*20);
+ g <- delete.edges(g, E(g)[wd[,3] < 0.25]);
+ #idx <- unlist(sapply(V(g)$name, function(x) which(x == id)));
+ #cols <- color_scale("red", "#E5C494");
+ #V(g)$color <- cols[sapply(pvalue, getIdx, min(pvalue), max(pvalue))];
+ V(g)$color <- heat.colors(length(pvalue));
+
+ cnt <- folds;
+ names(cnt) <- id;
+ #cnt2 <- (cnt[V(g)$name])^2; #make sure this is positve
+ #V(g)$size <- cnt2/sum(cnt2) * 100 #log(cnt2, base=10) * 10;
+ #V(g)$size <- log(cnt2, base=10) * 10 + 1;
+ V(g)$size <- cnt + 3;
+
+ pos.xy <- layout.fruchterman.reingold(g,niter=500);
+
+ # now create the json object
+ nodes <- vector(mode="list");
+ node.nms <- V(g)$name;
+ node.sizes <- V(g)$size;
+ node.cols <- V(g)$color;
+ for(i in 1:length(node.sizes)){
+ nodes[[i]] <- list(
+ id = node.nms[i],
+ label=node.nms[i],
+ size=node.sizes[i],
+ color=node.cols[i],
+ x = pos.xy[i,1],
+ y = pos.xy[i,2]
+ );
+ }
+
+ edge.mat <- get.edgelist(g);
+ edge.mat <- cbind(id=1:nrow(edge.mat), source=edge.mat[,1], target=edge.mat[,2]);
+ # covert to json
+ netData <- list(nodes=nodes, edges=edge.mat);
+ sink("msea_network.json");
+ cat(RJSONIO::toJSON(netData));
+ sink();
+
+ return(g);
+}
+
+PrepareSifDownloads <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ saveNetworkInSIF(mSetObj$analSet$enrich.net, "metaboanalyst_enrich");
+}
+
+overlap_ratio <- function(x, y) {
+ x <- unlist(x)
+ y <- unlist(y)
+ length(intersect(x, y))/length(unique(c(x,y)))
+}
+
+##' @importFrom grDevices colorRampPalette
+color_scale <- function(c1="grey", c2="red") {
+ pal <- colorRampPalette(c(c1, c2))
+ colors <- pal(100)
+ return(colors)
+}
+
+##############################################
+##############################################
+########## Utilities for web-server ##########
+##############################################
+##############################################
+
+
+GetCurrentImg<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return (mSetObj$imgSet$current.img);
+}
+
+getIdx <- function(v, MIN, MAX) {
+ if ( MIN == MAX ) {
+ return(100)
+ }
+ intervals <- seq(MIN, MAX, length.out=100)
+ max(which(intervals <= v))
+}
+
+######### Utility Functions #############
+GetShortNames<-function(nm.vec, max.len= 45){
+ new.nms <- vector(mode="character", length=length(nm.vec));
+ for(i in 1:length(nm.vec)){
+ nm <- nm.vec[i];
+ if(nchar(nm) <= max.len){
+ new.nms[i] <- nm;
+ }else{
+ wrds <- strsplit(nm, "[[:space:]]+")[[1]];
+ new.nm <- "";
+ if(length(wrds)>1){
+ for(m in 1:length(wrds)){
+ wrd <- wrds[m];
+ if(nchar(new.nm)+4+nchar(wrd) <= max.len){
+ new.nm <- paste(new.nm, wrd);
+ }else{
+ new.nms[i] <- paste (new.nm, "...", sep="");
+ break;
+ }
+ }
+ }else{
+ new.nms[i] <- paste (substr(nm, 0, 21), "...", sep="");
+ }
+ }
+ }
+ return(new.nms);
+}
+
+# return heat colors of given length
+GetMyHeatCols <- function(len){
+ if(len > 50){
+ ht.col <- c(substr(heat.colors(50), 0, 7), rep("#FFFFFF", len-50));
+ }else{
+ # reduce to hex by remove the last character so HTML understand
+ ht.col <- substr(heat.colors(len), 0, 7);
+ }
+}
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/enrich_integ.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/enrich_integ.R
new file mode 100755
index 0000000000000000000000000000000000000000..f332bae9151f93fb74233e64015e5999afb7d38f
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/enrich_integ.R
@@ -0,0 +1,1119 @@
+#'Perform compound mapping for integrative analysis methods
+#'@description Perform compound mapping
+#'@param mSetObj Input name of the created mSet Object
+#'@param cmpdIDs Input the list of compound IDs
+#'@param org Input the organism code
+#'@param idType Input the ID type
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PerformIntegCmpdMapping1 <- function(mSetObj=NA, cmpdIDs, org, idType){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ mSetObj$dataSet$cmpd.orig <- cmpdIDs;
+ mSetObj$dataSet$cmpd.org <- org;
+##############Changed by ZZY on 7/26/21 - Begin##############
+# if(idType == "name"){
+# cmpd.mat <- getDataFromTextArea(cmpdIDs, "tab");
+# }else{ # all other id should not contains space
+# cmpd.mat <- getDataFromTextArea(cmpdIDs, "space");
+# }
+ cmpd.mat <- cmpdIDs
+##############Changed by ZZY on 7/26/21 - End##############
+ mSetObj$dataSet$cmpd <- rownames(cmpd.mat); # this is for compatibility with name_match function
+ mSetObj$dataSet$cmpd.mat <- cmpd.mat;
+
+ if(.on.public.web){
+ .set.mSet(mSetObj);
+ return(CrossReferencing(mSetObj, idType, hmdb=T, pubchem=T, chebi=F, kegg=T, metlin=F));
+ }
+
+ mSetObjCR <- CrossReferencing1(mSetObj, idType, hmdb=T, pubchem=T, chebi=F, kegg=T, metlin=F)
+
+ return(.set.mSet(mSetObjCR));
+}
+
+#'Perform integrated gene mapping
+#'@description Used for the pathinteg module
+#'@param mSetObj Input name of the created mSet Object
+#'@param geneIDs Input the list of gene IDs
+#'@param org Input the organism code
+#'@param idType Input the ID type
+#'@export
+#'
+PerformIntegGeneMapping1 <- function(mSetObj=NA, geneIDs, org, idType){
+
+ mSetObj <- .get.mSet(mSetObj);
+##############Changed by ZZY on 7/26/21 - Begin##############
+# gene.mat <- getDataFromTextArea(geneIDs);
+ gene.mat <- geneIDs
+##############Changed by ZZY on 7/26/21 - End##############
+ gene.vec <- rownames(gene.mat);
+
+ #record the info
+ mSetObj$dataSet$q.type.gene <- idType;
+ mSetObj$dataSet$gene.orig <- geneIDs;
+ mSetObj$dataSet$gene.org <- org;
+ mSetObj$dataSet$gene.mat <- gene.mat;
+ mSetObj$dataSet$gene <- gene.vec;
+
+ enIDs <- doGeneIDMapping1(gene.vec, org, idType);
+
+ if(idType == "kos"){
+ kos <- gene.vec;
+ mSetObj$dataSet$kos.name.map <- kos
+ }
+
+ # Handle case when only KOs are mapped with no corresponding entrez id
+ na.inx <- is.na(enIDs);
+ if(sum(!na.inx) == 0 && idType == "kos"){
+ na.inx <- is.na(kos);
+ }
+
+ mSetObj$dataSet$gene.name.map <- list(
+ hit.values=enIDs,
+ match.state = ifelse(is.na(enIDs), 0, 1)
+ );
+
+ AddMsg(paste("A total of ", length(unique(enIDs)), "unique genes were uploaded."));
+ if(sum(!na.inx) > 0){
+ return(.set.mSet(mSetObj));
+ }else{
+ AddErrMsg("Error: no hits found!");
+ if(.on.public.web){
+ return(0);
+ }
+ return(.set.mSet(mSetObj));
+ }
+}
+
+#'Remove selected compounds
+#'@description Remove compounds
+#'@param mSetObj Input name of the created mSet Object
+#'@param inx Input the index of compound to remove
+#'@export
+#'
+RemoveCmpd <- function(mSetObj=NA, inx){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ mSetObj$dataSet$cmpd <- mSetObj$dataSet$cmpd[-inx];
+
+ mSetObj$name.map$hit.inx <- mSetObj$name.map$hit.inx[-inx];
+ mSetObj$name.map$hit.values <- mSetObj$name.map$hit.values[-inx];
+ mSetObj$name.map$match.state <- mSetObj$name.map$match.state[-inx];
+
+ if(.on.public.web){
+ .set.mSet(mSetObj);
+ mSetObj$name.map
+ }
+ return(.set.mSet(mSetObj));
+}
+
+#'Remove selected genes
+#'@description Remove selected genes based on an index
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param inx Input compound index
+#'@export
+#'
+RemoveGene <- function(mSetObj=NA, inx){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ mSetObj$dataSet$gene <- mSetObj$dataSet$gene[-inx];
+ mSetObj$dataSet$gene.mat <- mSetObj$dataSet$gene.mat[-inx, ,drop=F];
+
+ mSetObj$dataSet$gene.name.map$hit.inx <- mSetObj$dataSet$gene.name.map$hit.inx[-inx];
+ mSetObj$dataSet$gene.name.map$hit.values <- mSetObj$dataSet$gene.name.map$hit.values[-inx];
+ mSetObj$dataSet$gene.name.map$match.state <- mSetObj$dataSet$gene.name.map$match.state[-inx];
+
+ if(.on.public.web){
+ .set.mSet(mSetObj);
+ mSetObj$dataSet$gene.name.map
+ }
+ return(.set.mSet(mSetObj));
+}
+
+#'Prepare integrated data
+#'@description Used for the pathinteg module.
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@export
+#'
+PrepareIntegData <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ done <- 0;
+ # prepare gene list
+ if(!is.null(mSetObj$dataSet$gene.mat)){
+ gene.mat <- mSetObj$dataSet$gene.mat;
+ enIDs <- mSetObj$dataSet$gene.name.map$hit.values;
+###########Changed by ZZY on 7/26/21 - Begin#############
+# rownames(gene.mat) <- enIDs;
+# na.inx <- is.na(enIDs);
+# gene.mat <- gene.mat[!na.inx, ,drop=F];
+ na.inx <- is.na(enIDs);
+ gene.mat <- gene.mat[!na.inx, ,drop=F];
+ enIDs <- enIDs[!na.inx]
+ rownames(gene.mat) <- enIDs;
+###########Changed by ZZY on 7/26/21 - End#############
+ gene.mat <- RemoveDuplicates(gene.mat);
+ AddMsg(paste("A total of ", nrow(gene.mat), "unique genes were uploaded."));
+
+ if(!exists("pathinteg.imps", where = mSetObj$dataSet)){
+ mSetObj$dataSet$pathinteg.imps <- list();
+ }
+ mSetObj$dataSet$pathinteg.imps$gene.mat <- gene.mat;
+ done <- 1;
+ }
+
+ # prepare compound list
+ if(!is.null(mSetObj$dataSet$cmpd.mat)){
+ nm.map <- GetFinalNameMap(mSetObj);
+ valid.inx <- !(is.na(nm.map$kegg)| duplicated(nm.map$kegg));
+ cmpd.vec <- nm.map$query[valid.inx];
+ kegg.id <- nm.map$kegg[valid.inx];
+
+ cmpd.mat <- mSetObj$dataSet$cmpd.mat;
+ hit.inx <- match(cmpd.vec, rownames(cmpd.mat));
+
+ cmpd.mat <- cmpd.mat[hit.inx, ,drop=F];
+ rownames(cmpd.mat) <- kegg.id;
+ cmpd.mat <- RemoveDuplicates(cmpd.mat);
+ AddMsg(paste("A total of ", nrow(cmpd.mat), "unique compounds were found."));
+ mSetObj$dataSet$pathinteg.imps$cmpd.mat <- cmpd.mat;
+ done <- 1;
+ }
+
+ if(.on.public.web){
+ .set.mSet(mSetObj);
+ return(done);
+ }
+ return(.set.mSet(mSetObj));
+}
+
+#'Perform integrative pathway analysis
+#'@description used for integrative analysis
+#'as well as general pathways analysis for meta-analysis results
+#'@usage PerformIntegPathwayAnalysis(mSetObj, topo="dc", enrich="hyper", libOpt="integ")
+#'@param mSetObj Input name of the created mSet Object
+#'@param topo Select the mode for topology analysis: Degree Centrality ("dc") measures the number of links that connect to a node
+#'(representing either a gene or metabolite) within a pathway; Closeness Centrality ("cc") measures the overall distance from a given node
+#'to all other nodes in a pathway; Betweenness Centrality ("bc")measures the number of shortest paths from all nodes to all the others that pass through a given node within a pathway.
+#'@param enrich Method to perform over-representation analysis (ORA) based on either hypergenometrics analysis ("hyper")
+#' or Fisher's exact method ("fisher").
+#'@param libOpt Select the different modes of pathways, either the gene-metabolite mode ("integ") which allows for joint-analysis
+#' and visualization of both significant genes and metabolites or the gene-centric ("genetic") and metabolite-centric mode ("metab") which allows users
+#' to identify enriched pathways driven by significant genes or metabolites, respectively.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PerformIntegPathwayAnalysis1 <- function(mSetObj=NA, topo="dc", enrich="hyper", libVersion="current", libOpt="integ", integOpt="query"){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(libVersion == "old"){
+ if(!(mSetObj$org %in% c("hsa", "mmu", "rno"))){
+ AddErrMsg("Support for this organism is only available in the current version!");
+ return(0);
+ }
+ if(libOpt == "all"){
+ AddErrMsg("Support for all pathways is only available in the current version!");
+ return(0);
+ }
+ if(integOpt == "pval"){
+ AddErrMsg("Support for combining p value is only available in the current version!");
+ return(0);
+ }
+ }
+
+ # shift actual enrichment to api.metaboanalyst.ca
+ if(!.on.public.web){
+ sub.dir <- paste0("kegg/jointpa/",libOpt);
+ destfile <- paste0(mSetObj$org, ".qs");
+ current.kegglib <<- .get.my.lib(destfile, sub.dir);
+ load_igraph();
+ }
+
+ mSetObj$dataSet$pathinteg.method <- libOpt;
+ mSetObj$dataSet$path.mat <- NULL;
+
+ if(libOpt == "genetic" && !is.null(mSetObj$dataSet$pathinteg.imps$gene.mat)){
+
+ gene.mat <- mSetObj$dataSet$pathinteg.imps$gene.mat;
+ gene.vec <- paste(mSetObj$org, ":", rownames(gene.mat), sep="");
+ rownames(gene.mat) <- gene.vec;
+ impMat <- gene.mat;
+
+ # saving only
+ gene.sbls <- doGeneIDMapping1(rownames(mSetObj$dataSet$pathinteg.imps$gene.mat), mSetObj$org, "entrez");
+ gene.mat <- cbind(Name=gene.sbls, mSetObj$dataSet$pathinteg.imps$gene.mat);
+ fast.write.csv(gene.mat, file="result_genes.csv");
+
+ if(!.on.public.web){ #Changed to ! by ZZY on 7/26/21.
+ uniq.count <- current.kegglib$uniq.gene.count;
+ uniq.len <- current.kegglib$gene.counts;
+ }
+
+ }else if(libOpt == "metab" && !is.null(mSetObj$dataSet$pathinteg.imps$cmpd.mat)){
+
+ cmpd.mat <- mSetObj$dataSet$pathinteg.imps$cmpd.mat;
+ cmpd.vec <- paste("cpd:", rownames(cmpd.mat), sep=""); # no need for this as the metpa compound ID does not contain "cpd:" prefix
+ #cmpd.vec <- rownames(cmpd.mat);
+ rownames(cmpd.mat) <- cmpd.vec;
+ impMat <- cmpd.mat;
+
+ # saving only
+ cmpd.nms <- doKEGG2NameMapping(rownames(mSetObj$dataSet$pathinteg.imps$cmpd.mat));
+ cmpd.mat <- cbind(Name=cmpd.nms, mSetObj$dataSet$pathinteg.imps$cmpd.mat);
+ fast.write.csv(mSetObj$dataSet$pathinteg.imps$cmpd.mat, file="result_cmpds.csv");
+
+ if(!.on.public.web){ #Changed to ! by ZZY on 7/26/21.
+ uniq.count <- current.kegglib$uniq.cmpd.count
+ uniq.len <- current.kegglib$cmpd.counts;
+ }
+
+ }else{ # integ
+
+ if(is.null(mSetObj$dataSet$pathinteg.imps$cmpd.mat) | is.null(mSetObj$dataSet$pathinteg.imps$gene.mat)){
+ AddErrMsg("The integrative analysis require both gene and metabolite lists");
+ return(0);
+ }
+
+ impMat <- NULL;
+ uniq.count <- uniq.len <- 0;
+
+ cmpd.mat <- mSetObj$dataSet$pathinteg.imps$cmpd.mat;
+ cmpd.vec <- paste("cpd:", rownames(cmpd.mat), sep="");
+ rownames(cmpd.mat) <- cmpd.vec;
+ # saving
+ cmpd.nms <- doKEGG2NameMapping(rownames(mSetObj$dataSet$pathinteg.imps$cmpd.mat));
+ fast.write.csv(cbind(Name=cmpd.nms, mSetObj$dataSet$pathinteg.imps$cmpd.mat), file="result_cmpds.csv");
+
+ gene.mat <- mSetObj$dataSet$pathinteg.imps$gene.mat;
+ gene.vec <- paste(mSetObj$org, ":", rownames(gene.mat), sep="");
+ rownames(gene.mat) <- gene.vec;
+ # saving
+ gene.sbls <- doGeneIDMapping1(rownames(mSetObj$dataSet$pathinteg.imps$gene.mat), mSetObj$org, "entrez");
+ fast.write.csv(cbind(Name=gene.sbls, mSetObj$dataSet$pathinteg.imps$gene.mat), file="result_genes.csv");
+
+ # used by both integ
+ impMat <- rbind(cmpd.mat, gene.mat);
+
+ # used by merge p values
+ impMatList <- list(cmpd=cmpd.mat,gene=gene.mat);
+
+ if(!.on.public.web){ #Changed to ! by ZZY on 7/26/21.
+ uniq.count <- current.kegglib$uniq.cmpd.count + current.kegglib$uniq.gene.count;
+ uniq.len <- current.kegglib$cmpd.counts + current.kegglib$gene.counts;
+ }
+ }
+
+ ora.vec <- rownames(impMat);
+ impMat <- data.frame(Name=ora.vec, logFC=as.numeric(impMat[,1]));
+ rownames(impMat) <- ora.vec;
+ if(.on.public.web){ #Removed "!" by ZZY on 7/26/21.
+
+ if(libOpt == "integ"){
+ toSend = list(oraVec = ora.vec, libVersion = libVersion, libOpt = libOpt, integOpt = integOpt, topoMethod = topo, enrichAnal = enrich,
+ org = mSetObj$org, integCmpds = rownames(impMatList$cmpd), integGenes = rownames(impMatList$gene))
+ }else{
+ toSend = list(oraVec = ora.vec, libVersion = libVersion, libOpt = libOpt, integOpt = integOpt, topoMethod = topo, enrichAnal = enrich,
+ org = mSetObj$org)
+ }
+
+ #json to be sent to server
+ #oraData <- RJSONIO::toJSON(toSend, .na='null')
+ #write(oraData, file="ora_test.JSON")
+ # code to send to server
+ # change path when on server, use local for now
+
+ load_httr()
+ base <- api.base
+ endpoint <- "/jointpath"
+ call <- paste(base, endpoint, sep="")
+ query_results <- httr::POST(call, body = toSend, encode= "json")
+ query_results_text <- content(query_results, "text")
+ query_results_json <- RJSONIO::fromJSON(query_results_text, flatten = TRUE)
+ if(is.null(query_results_json$enrichRes)){
+ AddErrMsg("Error! Joint Pathway Analysis via api.metaboanalyst.ca unsuccessful!")
+ return(0)
+ }
+
+ # parse json response from server to results
+ qeaDataRes <- do.call(rbind.data.frame, query_results_json$enrichRes)
+ colnames(qeaDataRes) <- query_results_json$enrichResColNms
+ rownames(qeaDataRes) <- query_results_json$enrichResRowNms
+ fast.write.csv(qeaDataRes, file="MetaboAnalyst_result_pathway.csv", row.names=TRUE);
+
+ rownames(qeaDataRes) <- query_results_json$enrichPathIds
+
+ jointpa_matches <- as.matrix(query_results_json$jointPAMatches)
+ colnames(jointpa_matches) <- "Hits"
+ rownames(jointpa_matches) <- query_results_json$enrichResRowNms
+
+ mSetObj$api$guestName <- query_results_json$guestName;
+ mSetObj$dataSet$path.mat <- qeaDataRes;
+ mSetObj$dataSet$pathinteg.impMat <- impMat;
+ mSetObj$analSet$jointPAMatches <- jointpa_matches;
+
+ return(.set.mSet(mSetObj));
+ }
+
+ my.res <- .performPathEnrich(ora.vec, uniq.count, uniq.len, enrich, topo);
+
+ # combine pvals require performing analysis on compounds and genes seperately. Note, we need to use the topo from merge queries
+ if(libOpt == "integ" && integOpt != "query"){
+ # perform metabolite enrichment
+ res.cmpd <- .performPathEnrich(rownames(impMatList$cmpd), current.kegglib$uniq.cmpd.count, current.kegglib$cmpd.counts, enrich, topo);
+ if(is.null(res.cmpd)){
+ AddErrMsg("Failed to perform integration - not hits found for compound input.");
+ return(0);
+ }
+ fast.write.csv(res.cmpd$res.table, file="result_pathway_cmpd.csv", row.names=TRUE);
+
+ # perform gene enrichment
+ res.gene <- .performPathEnrich(rownames(impMatList$gene), current.kegglib$uniq.gene.count, current.kegglib$gene.counts, enrich, topo);
+ if(is.null(res.gene)){
+ AddErrMsg("Failed to perform integration - not hits found for gene input.");
+ return(0);
+ }
+ fast.write.csv(res.gene$res.table, file="result_pathway_gene.csv", row.names=TRUE);
+
+ # now merge p val
+ resI <- .performIntegPathMergeP(res.cmpd$res.table, res.gene$res.table, my.res$res.table, integOpt);
+ my.res$res.table <- resI;
+ }
+
+ resTable <- my.res$res.table;
+ hits.path <- my.res$hits.path;
+
+ # do some sorting
+ ord.inx<-order(resTable[,"Raw p"], resTable[,"Impact"]);
+ resTable <- resTable[ord.inx, , drop=FALSE];
+
+ resTable <- cbind(Name=rownames(resTable), resTable) #Added by ZZY on 8/5/21.
+ # for internal use, switch to pathway IDs (name containing special characters)
+ rownames(resTable) <- current.kegglib$path.ids[rownames(resTable)];
+
+ # store results from individual analysis
+ mSetObj$dataSet$path.mat <- resTable;
+ mSetObj$dataSet$path.hits <- hits.path;
+ mSetObj$dataSet$pathinteg.impMat <- impMat;
+ resTable <- cbind(resTable,CreateIntegMatchingTable1(mSetObj)) #Added by ZZY on 8/5/21.
+ rownames(resTable) <- resTable[, 'Name'] #Added by ZZY on 8/5/21.
+ resTable[, 'Name'] <- NULL #Added by ZZY on 8/5/21.
+ # now save to csv
+ fast.write.csv(resTable, file="pathway_results.csv", row.names=TRUE); #Moved by ZZY on 8/5/21.
+
+ return(.set.mSet(mSetObj));
+}
+
+# merge p values for two matrices from regular enrichment analysis
+# resM, resG, and resI are results from enrichment analysis from metabolites, genes and mergeQuery
+.performIntegPathMergeP <- function(resM, resG, resI, opt){
+
+ # get the ones with hits from both omics
+ hitsM <- rownames(resM) %in% rownames(resG);
+ inx <- which(hitsM);
+
+ if(length(inx) > 0){
+ cm.nms <- rownames(resM)[inx];
+
+ # for overall weight
+ total.count <- current.kegglib$uniq.cmpd.count + current.kegglib$uniq.gene.count;
+ ow.m <- current.kegglib$uniq.cmpd.count/total.count;
+ ow.g <- current.kegglib$uniq.gene.count/total.count;
+
+ # for pathway weights
+ path.uniq.lens <- current.kegglib$cmpd.counts + current.kegglib$gene.counts;
+ pw.m <- current.kegglib$cmpd.counts/path.uniq.lens;
+ pw.g <- current.kegglib$gene.counts/path.uniq.lens;
+ names(pw.m) <- names(pw.g) <- names(current.kegglib$path.ids);
+
+ for(nm in cm.nms){
+ p.vec <- c(resM[nm, "Raw p"], resG[nm, "Raw p"]);
+ if(opt == "pvalu"){ # unweighted
+ w.vec <- c(0.5,0.5);
+ }else if(opt == "pvalo"){ # overall
+ w.vec <- c(ow.m,ow.g);
+ }else{ # pathway level
+ w.vec <- c(pw.m[nm],pw.g[nm]);
+ }
+ resI[nm, "Raw p"] = .performWeightedZtest(p.vec, w.vec)$p;
+ }
+ }
+ # now replace resI two columns ("Expected" and "Hits") to individual hits
+ colnames(resI)<-c("Total", "Hits.cmpd", "Hits.gene", "Raw p", "-log10(p)", "Holm adjust", "FDR", "Impact");
+ resI[, "Hits.cmpd"] <- resI[,"Hits.gene"] <- rep(0, nrow(resI));
+ cmpd.nms <- rownames(resM);
+ resI[cmpd.nms, "Hits.cmpd"] <- resM[,"Hits"];
+ gene.nms <- rownames(resG);
+ resI[gene.nms, "Hits.gene"] <- resG[,"Hits"];
+
+ # update raw p for those with hits from one type
+ inxM.uniq <- which(!hitsM);
+ cm.uniq <- rownames(resM)[inxM.uniq];
+ resI[cm.uniq, "Raw p"] <- resM[cm.uniq,"Raw p"];
+
+ hitsG <- rownames(resG) %in% rownames(resM);
+ inxG.uniq <- which(!hitsG);
+ gn.uniq <- rownames(resG)[inxG.uniq];
+ resI[gn.uniq, "Raw p"] <- resG[gn.uniq,"Raw p"];
+
+ # now update the res.integ with merge p
+ resI[,5] <- -log10(resI[,"Raw p"]);
+ resI[,6] <- p.adjust(resI[,"Raw p"], "holm");
+ resI[,7] <- p.adjust(resI[,"Raw p"], "fdr");
+ resI <- signif(resI, 5);
+ return(resI);
+}
+
+# internal function called by PerformIntegPathwayAnalysis
+.performPathEnrich <- function(ora.vec, uniq.count, uniq.len, enrich, topo){
+
+ # set up the mset
+ ms.list <- lapply(current.kegglib$mset.list, function(x){strsplit(x, " ", fixed=TRUE)});
+ current.universe <- unique(unlist(ms.list));
+ set.size <- length(current.kegglib$mset.list);
+
+ # need to cut to the universe covered by the pathways, not all genes
+ ora.vec <- ora.vec[ora.vec %in% current.universe]
+ q.size <- length(ora.vec);
+
+ # note, we need to do twice one for nodes (for plotting)
+ # one for query for calculating, as one node can be associated with multiple matches
+ # get the matched nodes on each pathway
+ hits.path <- lapply(ms.list, function(x) {unlist(lapply(x, function(var){any(var%in%ora.vec);}),use.names=FALSE)});
+ names(hits.path) <- current.kegglib$path.ids;
+
+ # get the matched query for each pathway
+ hits.query <- lapply(ms.list, function(x) {ora.vec%in%unlist(x);});
+ hit.num <- unlist(lapply(hits.query, function(x){sum(x)}), use.names=FALSE);
+
+ if(sum(hit.num) == 0){
+ AddErrMsg("No hits found for your input!");
+ return(NULL);
+ }
+
+ # prepare for the result table
+ res.mat<-matrix(0, nrow=set.size, ncol=8);
+ rownames(res.mat)<-names(current.kegglib$path.ids);
+ colnames(res.mat)<-c("Total", "Expected", "Hits", "Raw p", "-log10(p)", "Holm adjust", "FDR", "Impact");
+
+ set.num <- uniq.len;
+ res.mat[,1]<-set.num;
+ res.mat[,2]<-q.size*(set.num/uniq.count);
+ res.mat[,3]<-hit.num;
+
+ # use lower.tail = F for P(X>x)
+ if(enrich=="hyper"){
+ res.mat[,4] <- phyper(hit.num-1, set.num, uniq.count-set.num, q.size, lower.tail=F);
+ }else if(enrich == "fisher"){
+ res.mat[,4] <- GetFisherPvalue(hit.num, q.size, set.num, uniq.count);
+ }else{
+ print("Not defined enrichment method!");
+ print(enrich);
+ }
+
+ res.mat[,5] <- -log10(res.mat[,4]);
+ res.mat[,6] <- p.adjust(res.mat[,4], "holm");
+ res.mat[,7] <- p.adjust(res.mat[,4], "fdr");
+
+ # toplogy test
+ if(topo == "bc"){
+ imp.list <- current.kegglib$bc;
+ }else if(topo == "dc"){
+ imp.list <- current.kegglib$dc;
+ }else if(topo == "cc"){
+ imp.list <- current.kegglib$cc;
+ }else{
+ print("Not a defined topological measure!");
+ # print(topo);
+ }
+ qs::qsave(imp.list, file="pathinteg.impTopo.qs");
+
+ # now, perform topological analysis
+ # calculate the sum of importance
+ res.mat[,8] <- mapply(function(x, y){sum(x[y])}, imp.list, hits.path);
+ res.mat <- res.mat[hit.num>0, , drop=FALSE];
+ res.mat <- res.mat[!is.na(res.mat[,8]), , drop=FALSE];
+ resTable <- signif(res.mat,5);
+ return(list(hits.path=hits.path, res.table=resTable));
+}
+
+##############################################
+##############################################
+########## Utilities for web-server ##########
+##############################################
+##############################################
+
+GetIntegResultPathIDs<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(rownames(mSetObj$dataSet$path.mat));
+}
+
+GetIntegResultPathNames<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(names(current.kegglib$path.ids)[match(rownames(mSetObj$dataSet$path.mat),current.kegglib$path.ids)]);
+}
+
+GetIntegResultColNames<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(colnames(mSetObj$dataSet$path.mat));
+}
+
+GetIntegResultMatrix<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(as.matrix(mSetObj$dataSet$path.mat));
+}
+
+GetGeneHitsRowNumber<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(length(mSetObj$dataSet$gene.name.map$match.state));
+}
+
+GetGeneMappingResultTable<-function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ qvec <- mSetObj$dataSet$gene;
+ enIDs <- mSetObj$dataSet$gene.name.map$hit.values;
+
+ # style for highlighted background for unmatched names
+ pre.style<-NULL;
+ post.style<-NULL;
+
+ # style for no matches
+ if(mSetObj$dataSet$q.type.gene == "name"){
+ no.prestyle<-"<strong style=\"background-color:yellow; font-size=125%; color=\"black\">";
+ no.poststyle<-"</strong>";
+ }else{
+ no.prestyle<-"<strong style=\"background-color:red; font-size=125%; color=\"black\">";
+ no.poststyle<-"</strong>";
+ }
+
+ # contruct the result table with cells wrapped in html tags
+ # the unmatched will be highlighted in different background
+ html.res<-matrix("", nrow=length(qvec), ncol=5);
+ csv.res<-matrix("", nrow=length(qvec), ncol=5);
+ colnames(csv.res)<-c("Query", "Entrez", "Symbol", "Name", "Comment");
+
+ sqlite.path <- paste0(url.pre, mSetObj$org, "_genes.sqlite");
+ conv.db <- .get.sqlite.con(sqlite.path);
+ gene.db <- dbReadTable(conv.db, "entrez")
+
+ org <- mSetObj$org
+
+ if(org %in% c("bta", "dre", "gga", "hsa", "mmu", "osa", "rno")){
+ hit.inx <- match(enIDs, gene.db[, "gene_id"]);
+ }else{
+ hit.inx <- match(enIDs, gene.db[, "symbol"]);
+ }
+
+ hit.values<-mSetObj$dataSet$gene.name.map$hit.values;
+ match.state<-mSetObj$dataSet$gene.name.map$match.state;
+ mSetObj$dataSet$gene.name.map$hit.inx <- hit.inx;
+
+ for (i in 1:length(qvec)){
+ if(match.state[i]==1){
+ pre.style<-"";
+ post.style="";
+ }else{ # no matches
+ pre.style<-no.prestyle;
+ post.style<-no.poststyle;
+ }
+ hit <-gene.db[hit.inx[i], ,drop=F];
+
+ html.res[i, ]<-c(paste(pre.style, qvec[i], post.style, sep=""),
+ paste(ifelse(match.state[i]==0 || is.na(hit$gene_id),"-", paste("<a href=http://www.ncbi.nlm.nih.gov/gene/", hit$gene_id, " target='_blank'>",hit$gene_id,"</a>", sep="")), sep=""),
+ paste(ifelse(match.state[i]==0 || is.na(hit$symbol), "-", paste("<a href=http://www.ncbi.nlm.nih.gov/gene/", hit$gene_id, " target='_blank'>", hit$symbol,"</a>", sep="")), sep=""),
+ paste(ifelse(match.state[i]==0 || is.na(hit$name),"-", paste("<a href=http://www.ncbi.nlm.nih.gov/gene/", hit$gene_id, " target='_blank'>",hit$name,"</a>", sep="")), sep=""),
+ ifelse(match.state[i]!=1,"View",""));
+ csv.res[i, ]<-c(qvec[i],
+ ifelse(match.state[i]==0, "NA", hit$gene_id),
+ ifelse(match.state[i]==0, "NA", hit$symbol),
+ ifelse(match.state[i]==0, "NA", hit$name),
+ match.state[i]);
+ }
+
+ # store the value for report
+ mSetObj$dataSet$gene.map.table <- csv.res;
+
+ fast.write.csv(csv.res, file="gene_name_map.csv", row.names=F);
+
+ if(.on.public.web){
+ .set.mSet(mSetObj)
+ return(as.vector(html.res));
+ }else{
+ return(.set.mSet(mSetObj));
+ }
+}
+
+#'Transform two column text to data matrix
+#'@description Transform two column input text to data matrix (single column data frame)
+#'@param txtInput Input text
+#'@param sep.type Indicate the seperator type for input text. Default set to "space"
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+getDataFromTextArea <- function(txtInput, sep.type="space"){
+
+ lines <- unlist(strsplit(txtInput, "\r|\n|\r\n")[1]);
+ if(substring(lines[1],1,1)=="#"){
+ lines <- lines[-1];
+ }
+
+ # separated by tab
+ if(sep.type=="tab"){
+ my.lists <- strsplit(lines, "\\t");
+ }else{ # from any space
+ my.lists <- strsplit(lines, "\\s+");
+ }
+ my.mat <- do.call(rbind, my.lists);
+
+ if(dim(my.mat)[2] == 1){ # add 0
+ my.mat <- cbind(my.mat, rep(0, nrow(my.mat)));
+ }else if(dim(my.mat)[2] > 2){
+ my.mat <- my.mat[,1:2];
+ msg <- "More than two columns found in the list. Only first two columns will be used."
+ AddErrMsg(msg);
+ }
+ rownames(my.mat) <- data.matrix(my.mat[,1]);
+ my.mat <- my.mat[,-1, drop=F];
+ return(my.mat);
+}
+
+
+#'Plot integrated methods pathway analysis
+#'@description Only update the background info for matched node
+#'@usage PlotInmexPath(mSetObj=NA, path.id, width, height)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param path.id Input the ID of the pathway to plot.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@param height Input the height of the image to create.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'@import igraph
+#'@import qs
+PlotInmexPath <- function(mSetObj=NA, pathName, width=NA, height=NA, format="png", dpi=NULL){
+
+ mSetObj <- .get.mSet(mSetObj);
+ path.id <- current.kegglib$path.ids[pathName];
+ g <- current.kegglib$graph.list[[path.id]];
+ if(is_igraph(g)){
+ g <- upgrade_graph(g); # to fix warning, can be removed for new version
+ }
+ phits <- mSetObj$dataSet$path.hits[[path.id]];
+ pathinteg.impTopo <- qs::qread("pathinteg.impTopo.qs");
+ topo <- pathinteg.impTopo[[path.id]];
+
+ # obtain up/down/stat information
+ res <- mSetObj$dataSet$pathinteg.impMat;
+
+ bg.cols <- rep("#E3E4FA", length(V(g)));
+ line.cols <- rep("dimgray", length(V(g)));
+
+ # now, do color schema - up red, down green
+ nd.inx <- which(phits);
+
+ # fill with 'NA'
+ stats <- vector(mode='list', length=length(V(g)));
+
+ rnms <- rownames(res);
+ for(inx in nd.inx){
+ nm <- unlist(strsplit(V(g)$names[inx], " ", fixed=TRUE));
+ #hit.inx <- which(rnms %in% nm)[1];
+ hit.inx <- which(rnms %in% nm);
+ if(length(hit.inx) > 0){
+ hit.inx <- hit.inx[1];
+ # use logFCs to decide up/down regulated
+ if(res$logFC[hit.inx] > 0){
+ bg.cols[inx]<- "#F75D59";
+ line.cols[inx] <- "#C11B17";
+ }else if(res$logFC[hit.inx] == 0){
+ bg.cols[inx]<- "#FFFF77";
+ line.cols[inx] <- "#F7E259";
+ }else{
+ bg.cols[inx]<- "#6AFB92";
+ line.cols[inx] <- "#347235";
+ }
+
+ # 1) update the node info (tooltip/popup)
+ V(g)$db.lnks[inx] <- paste("<a href='http://www.genome.jp/dbget-bin/www_bget?", rownames(res)[hit.inx],
+ "' target='_blank'>", res$Name[hit.inx], "</a>", sep="", collapse=" ");
+ # 2) save the stats for each node
+ stats[[inx]] <- signif(res[hit.inx, "logFC", drop=F],5);
+ }
+ }
+ V(g)$stats <- stats;
+ V(g)$topo <- topo;
+
+ if(.on.public.web){
+ return(PlotInmexGraph(mSetObj, pathName, g, width, height, bg.cols, line.cols, format, dpi));
+ }else{
+ mSetObj <- PlotInmexGraph(mSetObj, pathName, g, width, height, bg.cols, line.cols, format, dpi);
+# print("pathinteg graph has been created, please find it in mSet$imgSet$pathinteg.path")
+ return(.set.mSet(mSetObj));
+ }
+}
+
+#'Plot an igraph object and return the node information (position and labels)
+#'@description Plot an igraph object and return the node information (position and labels)
+#'Used in a higher function
+#'@param mSetObj Input name of the created mSet Object
+#'@param path.id Input the pathway id
+#'@param g Input the graph
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@param height Input the height of the graph to create
+#'@param bg.color Set the background color, default is set to NULL
+#'@param line.color Set the line color, default is set to NULL
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotInmexGraph <- function(mSetObj, pathName, g, width=NA, height=NA, bg.color=NULL, line.color=NULL, format="png", dpi=NULL){
+
+ if(is.null(line.color)){
+ line.color <- "dimgray";
+ }
+
+ if(!is.null(dpi)){
+ pathName <- gsub("\\s","_", pathName);
+ pathName <- gsub(",","", pathName);
+
+ imgName = paste(pathName, "_dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ width <- 8;
+ }
+ w <- h <- width;
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ par(mai=rep(0,4));
+ plotGraph(g, vertex.label=V(g)$plot_name, vertex.color=bg.color, vertex.frame.color=line.color);
+ dev.off();
+ return(imgName);
+ }else{
+ imgName <- paste(pathName, ".png", sep="");
+ mSetObj$imgSet$pathinteg.path <- imgName
+ Cairo::Cairo(file=imgName, width=width, height=height, type="png", bg="white");
+ par(mai=rep(0,4));
+ plotGraph(g, vertex.label=V(g)$plot_name, vertex.color=bg.color, vertex.frame.color=line.color);
+ nodeInfo <- GetKEGGNodeInfo(pathName, g, width, height);
+ dev.off();
+
+ mSetObj$dataSet$current.kegg <- list(graph=g, bg.color=bg.color, line.color=line.color);
+
+ # remember the current graph
+ if(.on.public.web){
+ .set.mSet(mSetObj);
+ return(nodeInfo);
+ }else{
+ return(.set.mSet(mSetObj));
+ }
+ }
+}
+
+#'Retrieves KEGG node information
+#'@param path.id Input the path ID
+#'@param g Input data
+#'@param width Input the width
+#'@param height Input the height
+#'@param usr Input the user
+#'@export
+GetKEGGNodeInfo <- function(pathName, g, width, height, usr = par("usr")){
+
+ x.u2p = function(x) { rx=(x-usr[1])/diff(usr[1:2]); return(rx*width) }
+ y.u2p = function(y) { ry=(usr[4]-y)/diff(usr[3:4]); return(ry*height) }
+
+ wds <- V(g)$graphics_width;
+ #wds[wds == 'unknow']<- 46;
+ wds[is.na(wds)]<- 46;
+ hts <- V(g)$graphics_height;
+ hts[is.na(hts)]<- 17;
+
+ nw <- 1/200*as.numeric(wds);
+ nh <- 1/200*as.numeric(hts);
+ nxy <- igraph::layout.norm(getLayout(g), -1, 1, -1, 1);
+
+ # note: nxy is the center of the node, need to deal differently for cirlce or rectangle
+ # for circle the width/height are radius, stay the same, only adjust the rectangle
+ rec.inx <- V(g)$graphics_type == "rectangle";
+
+ nw[rec.inx] <- nw[rec.inx]/4;
+ nh[rec.inx] <- nh[rec.inx]/2;
+
+ xl = floor(100*x.u2p(nxy[,1] - nw)/width);
+ xr = ceiling(100*x.u2p(nxy[,1] + nw)/width);
+ yu = floor(100*y.u2p(nxy[,2] - nh)/height);
+ yl = ceiling(100*y.u2p(nxy[,2] + nh)/height);
+
+ tags <- V(g)$graphics_name;
+ nm.lnks <- V(g)$db.lnks;
+
+ # create the javascript code
+ path.id <- current.kegglib$path.ids[pathName];
+ jscode <- paste("keggPathLnk=\'<a href=\"javascript:void(0);\" onclick=\"window.open(\\'http://www.genome.jp/kegg-bin/show_pathway?", path.id, "\\',\\'KEGG\\');\">", pathName, "</a>\'", sep="");
+ jscode <- paste(jscode, paste("keggPathName=\"", pathName,"\"", sep=""), sep="\n");
+
+ #add code for mouseover locations, basically the annotation info. In this case, the name of the node
+ if(is.null(V(g)$stats)){
+ for(i in 1:length(tags)) {
+ jscode <- paste(jscode, paste("rectArray.push({x1:", xl[i], ", y1:", yl[i], ", x2:",
+ xr[i], ", y2:", yu[i],
+ ", lb: \"", tags[i],
+ "\", lnk: \"", nm.lnks[i],
+ "\"})", sep=""), sep="\n");
+ }
+ }else{
+ stats <- V(g)$stats;
+ topos <- signif(V(g)$topo,5);
+ for(i in 1:length(tags)) {
+ jscode <- paste(jscode, paste("rectArray.push({x1:", xl[i], ", y1:", yl[i], ", x2:",
+ xr[i], ", y2:", yu[i],
+ ", lb: \"", tags[i],
+ "\", lnk: \"", nm.lnks[i],
+ "\", topo: ", topos[i],
+ ifelse(is.null(stats[[i]]), "", paste(", logFC:", stats[[i]][1], sep="")),
+ "})", sep=""), sep="\n");
+ }
+ }
+ return(jscode);
+}
+
+# Used in higher function
+plotGraph <- function(graph,margin=0,vertex.label.cex=0.6,vertex.label.font=1,vertex.size=8,
+ vertex.size2=6,edge.arrow.size=0.2,edge.arrow.width=3,vertex.label=V(graph)$graphics_name,
+ vertex.shape=V(graph)$graphics_type,layout=getLayout(graph),vertex.label.color="black",
+ vertex.color=V(graph)$graphics_bgcolor,vertex.frame.color="dimgray",edge.color="dimgray",
+ edge.label=getEdgeLabel(graph),edge.label.cex=0.6,edge.label.color="dimgray",edge.lty=getEdgeLty(graph),
+ axes=FALSE,xlab="",ylab="",sub=NULL,main=NULL,...){
+ if(class(graph)!="igraph") stop("the graph should be a igraph graph.")
+ if(vcount(graph)==0){
+ print("the graph is an empty graph.")
+ }else{
+ vertex.shape <- replace(vertex.shape,which(vertex.shape %in% c("roundrectangle","line")),"crectangle")
+ vertex.color <- replace(vertex.color,which(vertex.color %in% c("unknow","none")),"white")
+ if(length(vertex.shape)==0) vertex.shape<-NULL
+ if(length(vertex.color)==0) vertex.color<-NULL
+ if(length(vertex.label)==0) vertex.label<-NULL
+ if(length(layout)==0 | sum(is.na(layout))>0){
+ print("Layout contain NAs");
+ layout<-NULL;
+ }
+ if(length(edge.label)==0) edge.label<-NULL
+ if((axes==FALSE)&&xlab==""&&ylab==""&&is.null(sub)&&is.null(main)){
+ old.mai <- par(mai=c(0.01,0.25,0.01,0.3))
+ #old.mai<-par(mai=0.01+c(0,0,0,0))
+ on.exit(par(mai=old.mai), add=TRUE)
+ }
+ plot(graph,margin=margin,vertex.label.cex=vertex.label.cex,vertex.label.font=vertex.label.font,
+ vertex.size=vertex.size,vertex.size2=vertex.size2,
+ edge.arrow.size=edge.arrow.size,edge.arrow.width=edge.arrow.width,vertex.label=vertex.label,
+ vertex.shape=vertex.shape,layout=layout,vertex.label.color=vertex.label.color,
+ vertex.color=vertex.color,vertex.frame.color=vertex.frame.color,edge.color=edge.color,
+ edge.label=edge.label,edge.label.cex=edge.label.cex,edge.label.color=edge.label.color,
+ edge.lty=edge.lty,axes=axes,xlab=xlab,ylab=ylab,sub=sub,main=main,...)
+ }
+}
+
+getLayout<-function(graph){
+ if(length(V(graph)$graphics_x)==0||length(V(graph)$graphics_y)==0) return (NULL)
+ x_y<-c()
+
+ graphics_x <- igraph::get.vertex.attribute(graph,"graphics_x")
+ index <- which(is.na(graphics_x))
+ if(length(index)>1){
+ #temp<-as.numeric(graphics_x[which(graphics_x!="unknow")]) # this is old version
+ temp<-as.numeric(graphics_x[which(!is.na(graphics_x))])
+ if(length(temp)<2){temp<-as.numeric(c(100,600))}
+ replace_value<-seq(min(temp),max(temp),by = (max(temp)-min(temp))/(length(index)-1))
+ graphics_x<-replace(graphics_x,which(is.na(graphics_x)),replace_value)
+ }else if(length(index)==1){
+ temp<-as.numeric(graphics_x[which(!is.na(graphics_x))])
+ graphics_x<-replace(graphics_x,which(is.na(graphics_x)),min(temp))
+ }
+ graphics_x <- as.numeric(graphics_x);
+
+ graphics_y <- igraph::get.vertex.attribute(graph,"graphics_y")
+ index <- which(is.na(graphics_y))
+ if(length(index)>0){
+ temp <- as.numeric(graphics_y[which(!is.na(graphics_y))])
+ if(length(temp)<2){temp<-as.numeric(c(100,600))}
+ graphics_y <- replace(graphics_y,which(is.na(graphics_y)),max(temp)+100)
+ }
+ graphics_y <- as.numeric(graphics_y)
+
+ x_y <- as.matrix(data.frame(graphics_x=graphics_x, graphics_y=graphics_y))
+ x_y[,2] <- -x_y[,2]
+ dimnames(x_y) <- NULL
+ return(x_y)
+}
+
+getEdgeLabel<-function(graph){
+ edge.name <- igraph::E(graph)$subtype_name
+ edge.value <- igraph::E(graph)$subtype_value
+ #edge.label<-E(graph)$subtype_value
+ edge.label <- rep("",len=length(edge.name))
+ for(i in seq(edge.name)){
+ edge_i<-unlist(strsplit(edge.name[i], ";", fixed=TRUE))
+ if("phosphorylation" %in% edge_i){
+ edge.label[i]<-paste("+p",edge.label[i],sep=" ")
+ }
+ if("dephosphorylation" %in% edge_i){
+ edge.label[i]<-paste("-p",edge.label[i],sep=" ")
+ }
+ if("glycosylation" %in% edge_i){
+ edge.label[i]<-paste("+g",edge.label[i],sep=" ")
+ }
+ if("ubiquitination" %in% edge_i){
+ edge.label[i]<-paste("+u",edge.label[i],sep=" ")
+ }
+ if("methylation" %in% edge_i){
+ edge.label[i]<-paste("+m",edge.label[i],sep=" ")
+ }
+ if("missing interaction" %in% edge_i){
+ edge.label[i]<-paste("/",edge.label[i],sep=" ")
+ }
+ if("dissociation" %in% edge_i){
+ edge.label[i]<-paste("|",edge.label[i],sep=" ")
+ }
+ if("binding/association" %in% edge_i){
+ edge.label[i]<-paste("---",edge.label[i],sep=" ")
+ }
+ if("repression" %in% edge_i){
+ edge.label[i]<-paste("-e-|",edge.label[i],sep=" ")
+ }
+ if("expression" %in% edge_i){
+ edge.label[i]<-paste("-e->",edge.label[i],sep=" ")
+ }
+ if("inhibition" %in% edge_i){
+ edge.label[i]<-paste("--|",edge.label[i],sep=" ")
+ }
+ if("activation" %in% edge_i){
+ edge.label[i]<-paste("-->",edge.label[i],sep=" ")
+ }
+ if("indirect effect" %in% edge_i){
+ edge.label[i]<-paste("..>",edge.label[i],sep=" ")
+ }
+ if("state change" %in% edge_i){
+ edge.label[i]<-paste("...",edge.label[i],sep=" ")
+ }
+ if("compound" %in% edge_i){
+ compound<-V(graph)[V(graph)$id==edge.value[i]]$graphics_name
+ if(length(compound)==1){
+ edge.label[i]<-paste(compound,edge.label[i],sep=" ")
+ }
+ }
+ }
+ return(edge.label)
+}
+
+#04350 indirect effect,04620
+getEdgeLty<-function(graph){
+ edge.name <- igraph::E(graph)$subtype_name
+ edge.lty=rep("solid",len=length(edge.name))
+ for(i in seq(edge.name)){
+ if(edge.name[i]=="indirect effect"){
+ edge.lty[i]<-"longdash"
+ }else if(edge.name[i]=="state change"){
+ edge.lty[i]<-"longdash"
+ }
+ }
+ #new!
+ if(length(edge.lty)==0){
+ edge.lty="solid"
+ }
+ return(edge.lty)
+}
+
+##############################################
+##############################################
+########## Utilities for web-server ##########
+##############################################
+##############################################
+
+# return gene and compounds highlighted in the pathway
+GetIntegHTMLPathSet<-function(mSetObj=NA, pathName){
+
+ mSetObj <- .get.mSet(mSetObj);
+ path.id <- current.kegglib$path.ids[[pathName]];
+
+ phits <- mSetObj$dataSet$path.hits[[path.id]];
+ nd.inx <- which(phits);
+
+ # pathway nodes
+ all.ids <- current.kegglib$mset.list[[path.id]];
+ g <- current.kegglib$graph.list[[path.id]];
+
+ if(is_igraph(g)){
+ g <- upgrade_graph(g);
+ }
+ all.nms <- V(g)$graphics_name;
+ all.nms[nd.inx] <- paste("<font color=\"red\">", "<b>", all.nms[nd.inx], "</b>", "</font>",sep="");
+
+ return(cbind(pathName, paste(unique(all.nms), collapse="; ")));
+}
+
+CreateIntegMatchingTable1 <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(.on.public.web){ #Removed "!" by ZZY on 7/26/21.
+
+ if(is.null(mSetObj$analSet$jointPAMatches)){ #Changed mSet to mSetObj by ZZY on 7/26/21.
+ AddErrMsg("Perform integrative pathway analysis first!")
+ return(0)
+ }
+
+ res <- mSetObj$analSet$jointPAMatches
+ fast.write.csv(res, "jointpa_matched_features.csv", row.names = T)
+ return(.set.mSet(mSetObj));
+ }
+
+ results <- mSetObj$dataSet$path.mat
+ match_paths <- rownames(results)
+
+ ms.list <- lapply(current.kegglib$mset.list, function(x){strsplit(x, " ", fixed=TRUE)})
+
+ ms.list <- ms.list[match(match_paths, names(ms.list))]
+ ms.list.list <- lapply(ms.list, function(x) unique(unlist(x)))
+
+ ora.vec <- rownames(mSetObj$dataSet$pathinteg.impMat)
+
+# overlap.results <- lapply(ms.list.list, function(overlap) paste0(intersect(overlap, ora.vec), collapse="; ") ) #Replaced by ZZY on 8/2/21. See below.
+##############Begin Replacement#############
+ ora.vec.names <- id2NameMapping(ora.vec, mSetObj$org)
+ overlap.results <- lapply(ms.list.list, function(overlap) {vec <- intersect(overlap, ora.vec); return(paste0(ora.vec.names[vec], collapse="; "))})
+##############End Replacement#############
+
+ res <- data.frame(matrix(unlist(overlap.results), nrow=length(overlap.results), byrow=T), stringsAsFactors=FALSE)
+ rownames(res) <- names(current.kegglib$path.ids)[match(match_paths, current.kegglib$path.ids)]
+ colnames(res) <- "matched_features"
+# fast.write.csv(res, "matched_features.csv", row.names = T)
+
+ if(.on.public.web){ #Removed "!" by ZZY on 7/26/21.
+ return(1)
+ }else{
+# return(.set.mSet(mSetObj)); #Changed by ZZY on 8/4/21. See below.
+ return(res)
+ }
+}
+
+# perform p value combination, p.vec contain p values, w.vec contains weights
+.performWeightedZtest <- function(p, weights=c(1,1)){
+ zp <- (qnorm(p, lower.tail = FALSE) %*% weights)/sqrt(sum(weights^2));
+ res <- list(z = zp, p = pnorm(zp, lower.tail = FALSE));
+ res;
+}
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/enrich_mset.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/enrich_mset.R
new file mode 100755
index 0000000000000000000000000000000000000000..99e966830292cd9936faadbeab35675b8e5e286c
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/enrich_mset.R
@@ -0,0 +1,614 @@
+###############################
+## Metabolite set library
+###############################
+
+#'Set the cachexia set used
+#'@description Set cachexia set used
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param used Set data to be used
+#'@export
+#'
+SetCachexiaSetUsed <- function(mSetObj=NA, used){
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$dataSet$cachexia.set.used <- used;
+ return(.set.mSet(mSetObj));
+}
+
+#'Set current user selected metset library for search
+#'@description if enrichment analysis, also prepare lib by
+#'creating a list of metabolite sets
+#'@usage SetCurrentMsetLib(mSetObj=NA, lib.type, excludeNum)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param lib.type Input user selected name of library, "self", "kegg_pathway",
+#'"smpdb_pathway", "blood", "urine", "csf", "snp", "predicted", "location", and "drug".
+#'@param excludeNum Users input the mimimum number compounds within selected metabolite sets (metabolitesets < excludeNum)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@import qs
+#'@export
+
+SetCurrentMsetLib1 <- function(mSetObj=NA, libname, excludeNum=0){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(libname=="self"){
+ ms.list <- mSetObj$dataSet$user.mset;
+ ms.list <- lapply(ms.list, function(x) unlist(strsplit(x, "; ", fixed=TRUE)))
+ current.msetlib <- vector("list", 3)
+ names(current.msetlib) <- c("name", "member", "reference")
+ mSetObj$analSet$msetlibname <- libname; #Added by ZZY on 8/5/21.
+ }else{
+
+ if(!.on.public.web & grepl("kegg", libname)){ # api only for KEGG msets
+ mSetObj$api$libname <- libname
+ mSetObj$api$excludeNum = excludeNum
+ mSetObj$analSet$msetlibname <- libname
+# return(.set.mSet(mSetObj)); #Commented by ZZY on 3/12/2021.
+ }
+
+# if(!exists("current.msetlib") || mSetObj$analSet$msetlibname != libname) {
+# The above line was changed to the following by zzy on 3/12/2021.
+ if (1) {
+ destfile <- paste(libname, ".qs", sep = "");
+ if(.on.public.web){
+ my.qs <- paste("../../libs/msets/", destfile, sep="");
+ current.msetlib <- qs::qread(my.qs);
+ }else{
+ my.qs <- paste("https://www.metaboanalyst.ca/resources/libs/msets/", destfile, sep="");
+ if(!file.exists(destfile)){
+ download.file(my.qs, destfile);
+ }
+ current.msetlib <- qs::qread(destfile);
+ }
+ mSetObj$analSet$msetlibname <- libname;
+ }
+ # create a named list, use the ids for list names
+ ms.list <- strsplit(current.msetlib[,3],"; ", fixed=TRUE);
+ names(ms.list) <- current.msetlib[,2];
+ }
+ if(excludeNum > 0){
+ cmpd.count <- lapply(ms.list, length);
+ sel.inx <- cmpd.count >= excludeNum;
+ ms.list <- ms.list[sel.inx];
+ if(libname!="self"){
+ current.msetlib <- current.msetlib[sel.inx,];
+ }
+ }
+
+ # total uniq cmpds in the mset lib
+ mSetObj$dataSet$uniq.count <- length(unique(unlist(ms.list, use.names = FALSE)));
+
+ # update current.mset and push to global env
+ current.msetlib$member <- ms.list;
+
+ if(libname=="self"){
+ current.msetlib$name <- names(ms.list)
+ current.msetlib$reference <- rep("User-uploaded", length(ms.list))
+ }
+
+ current.msetlib <<- current.msetlib;
+ return(.set.mSet(mSetObj));
+}
+
+
+#'Read user upload metabolite set library file
+#'@description Return two col csv file, first name, second cmpd list
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param filePath Input the path to the user's uploaded metabolite set library
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+#Setup.UserMsetLibData1<-function(mSetObj=NA, filePath){ #Replaced by ZZY on 8/5/21. See below.
+Setup.UserMsetLibData1<-function(mSetObj=NA, filePath, idType="name"){ #idType can be name, hmdb, or kegg.
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ dat <- .readDataTable(filePath);
+ libCheck.msg <- NULL;
+ if(class(dat) == "try-error") {
+ libCheck.msg <-c(libCheck.msg, "Data format error - fail to read in the data!");
+ AddErrMsg(libCheck.msg);
+ return(0);
+ }
+
+ if(is.null(dim(dat)) || dim(dat)[2]!=2){
+ libCheck.msg <-c(libCheck.msg, "Data format error - must have two columns!");
+ AddErrMsg(libCheck.msg);
+ return(0);
+ }
+
+ # create a named list, use the ids for list names
+ mset.list<-strsplit(dat[,2],"; ", fixed=TRUE);
+############Begin: Added by ZZY on 8/5/21.############
+ if (idType=="kegg") {
+ mset.list<-lapply(mset.list,function (x) {names <- doKEGG2NameMapping(x); names[is.na(names)] <- x[is.na(names)]; return(names)})
+ } else if (idType=="hmdb") {
+ mset.list<-lapply(mset.list,function (x) {names <- HMDBID2Name1(x); names[is.na(names)] <- x[is.na(names)]; return(names)})
+ }
+############End: Added by ZZY on 8/5/21.############
+
+ mset.ids <- paste("USER", sprintf("%04d",1:nrow(dat)), sep="");
+ names(mset.list)<-dat[,1];
+ names(mset.ids)<-dat[,1];
+
+ cmpd.db <- .get.my.lib("compound_db.qs");
+
+ # now need to check all metabolites match HMDB names
+ # and get the statistics
+ unmatched.nms <- NULL;
+ unmatched.num <- 0;
+ hmdb.nms <- tolower(cmpd.db$name);
+ for(i in 1:length(mset.list)){
+ mset <- mset.list[[i]];
+ hit.inx <- match(tolower(mset), hmdb.nms);
+ unmatched.nms <- c(unmatched.nms, mset[is.na(hit.inx)]);
+ unmatched.num <- unmatched.num + sum(is.na(hit.inx));
+ }
+
+ # save the lib data
+ mSetObj$dataSet$user.mset <- mset.list;
+ mSetObj$dataSet$user.mset.ids <- mset.ids;
+
+ if(unmatched.num > 0) {
+ mSetObj$dataSet$user.mset.info <- paste("A total of", unmatched.num, "compounds were not matched to HMDB common names.",
+ "They are:", paste(unmatched.nms, collapse="; "), ". Please correct these names. Otherwise,",
+ "they will be ignored during the enrichment analysis.");
+ }else{
+ mSetObj$dataSet$user.mset.info <- paste("A total of", length(mset.list), "sets were sucessfully added to the library.");
+ }
+
+ print(paste0("User-defined DB: ",mSetObj$dataSet$user.mset.info)) #Added by ZZY on 8/5/21.
+
+ return(.set.mSet(mSetObj));
+
+}
+
+#'Get the library check messages
+#'@description Get the library check messages
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@export
+#'
+GetMsetLibCheckMsg<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return (mSetObj$dataSet$user.mset.info);
+}
+
+#'Get the concentration reference
+#'@description Get the concentration reference
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param cmpd.nm Input the compound name
+#'@export
+#'
+Get.ConcRef<-function(mSetObj=NA, cmpd.nm){
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(!exists('conc.db')){
+ if(.on.public.web){
+ conc.db <<- .readDataTable("../../libs/cmpd_conc.csv");
+ }else{
+ conc.db <<- .readDataTable("https://www.metaboanalyst.ca/resources/libs/cmpd_conc.csv");
+ }
+ }
+ matches <- subset(conc.db, name == cmpd.nm & biotype==mSetObj$dataSet$biofluid, select=c(conc, pubmed, references, notes));
+ if(nrow(matches)==0){
+ return(NA);
+ }
+ return(list(concs = matches$conc, pmid = matches$pubmed, refs = matches$references, note = matches$notes));
+}
+
+#'Search metabolite set libraries
+#'@description Search metabolite set libraries
+#'@param mSetObj Input name of the created mSet Object
+#'@param query Input the query to search
+#'@param type Input the data type (name or compound)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+SearchMsetLibraries<-function(mSetObj=NA, query, type){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(!exists("lib.search", where = mSetObj$dataSet)){
+ mSetObj$dataSet$lib.search <<- list();
+ }
+
+ query <- ClearStrings(query);
+
+ if(nchar(query)==0){
+ return();
+ }
+
+ if(type=="name"){
+ SearchByName(query);
+ }else{
+ SearchByCompound(query);
+ }
+}
+
+#'Search for compound from all member compounds of metabolite set
+#'@description Search for compound from all member compounds of metabolite set
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param query Input the query to search
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+SearchByCompound <- function(mSetObj=NA, query){
+
+ mSetObj <- .get.mSet(mSetObj);
+ names.vec <- current.msetlib$member;
+ matched.inx <- NULL;
+ matched <- FALSE;
+ exact = FALSE;
+
+ # matching from close match to more dist match (max.dist = 0.5)
+ # once a closer match found, stop trying more distant one
+ matched.dist <- NULL;
+ s <- seq(0, 0.2, .1)
+ for (i in s) {
+ matched.inx <- agrep(query,names.vec,ignore.case=T, max.distance=i);
+ if(length(matched.inx) > 0) {
+ matched.dist <- i;
+ matched <- TRUE;
+ break;
+ }
+ }
+
+ if(matched){
+ # now break down the set into each individual metabolites and find out which one gives the best hit
+ matched.list<- vector(mode = "list", length=length(matched.inx));
+ for(i in 1:length(matched.inx)){
+ matched.list[i]<-strsplit(current.msetlib[matched.inx[i], "member"],"; *");
+ }
+
+ # re-do the matching, and record the matched values & sort
+ matched.score <- NULL;
+ hit.value <- vector(mode = "character", length=length(matched.inx)); # save the exact hit
+ matched.value <- vector(mode = "character", length=length(matched.inx)); # save the whole metset
+ for (i in 1:length(matched.inx)) {
+ matched.nm <- matched.list[[i]];
+ # test if it is exact match
+ if((matched.dist == 0.0) & (!is.na(hit.inx <- match(tolower(query), tolower(matched.nm))))){
+ matched.score[i] <- -1.0;
+ exact <- TRUE;
+ }else{ # try approximate match, note: we only record the first match in each set
+ hit.inx <- agrep(query,matched.nm,ignore.case=T, max.distance=matched.dist)[1];
+ # matched.dist 0.0, 0.1, 0.2, with the matches of the same distance, add fine adjustment
+ # based on the length b/w query and matched name
+ # use query length for normalization
+ matched.score[i] <- matched.dist + abs(nchar(matched.nm[hit.inx])-nchar(query))/(1000*nchar(query));
+ }
+
+ # wrap up hit metabolite sets in html tags
+ html.tag <- "<p>";
+ for(m in 1:length(matched.list[[i]])){
+ current.cmpd <- matched.list[[i]][m];
+ if(m == hit.inx){
+ current.cmpd <- paste("<font color=\"red\">", "<b>", current.cmpd, "</b>", "</font>",sep="");
+ }
+ if(m == 1){
+ html.tag <- paste(html.tag, current.cmpd, sep="");
+ }else {
+ html.tag <- paste(html.tag, "; ", current.cmpd, sep="");
+ }
+ }
+ hit.value[i] <-matched.list[[i]][hit.inx] ;
+ matched.value[i] <- paste(html.tag, "</p>");
+ }
+
+ matched.table <- cbind(current.msetlib$name[matched.inx],
+ matched.value,
+ current.msetlib$reference[matched.inx]);
+ if(exact){
+ exact.inx <- matched.score == -1;
+ mSetObj$dataSet$lib.search$matched.table <- matched.table[exact.inx, ];
+ mSetObj$dataSet$lib.search$best.hit <- "NA";
+ }else{
+ # rank results based on the matched scores
+ ord.inx <- order (matched.score, decreasing=F);
+ mSetObj$dataSet$lib.search$matched.table <- matched.table[ord.inx, ];
+ mSetObj$dataSet$lib.search$best.hit <- hit.value[ord.inx][1];
+ }
+ }else{
+ mSetObj$dataSet$lib.search$best.hit <- "NA";
+ }
+ if(.on.public.web){
+ .set.mSet(mSetObj);
+ mSetObj$dataSet$lib.search
+ }
+ return(.set.mSet(mSetObj));
+}
+
+#'Given a metabolite set name, search its index
+#'@description Given a metabolite set name, search its index
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param query Input the query to search
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+SearchByName <- function(mSetObj=NA, query){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # no need for suggestions for metabolite set name search
+ mSetObj$dataSet$lib.search$best.hit <- "NA";
+ names.vec <- current.msetlib$name;
+ matched <- FALSE;
+
+ # matching from exact match (max.dist = 0) to more dist match (max.dist = 0.5)
+ # once a closer match found, stop trying more distant one
+ matched.inx <- match(tolower(query), tolower(names.vec));
+ if(is.na(matched.inx)){ # try approximate match
+ s <- seq(0, 0.2, .1)
+ for (i in s) {
+ matched.inx <- agrep(query,names.vec,ignore.case=T, max.distance=i);
+ if(length(matched.inx) > 0) {
+ matched = TRUE;
+ break;
+ }
+ }
+ }else{
+ matched = TRUE;
+ }
+
+ if(matched){
+ # wrap up in html tags
+ matched.names <- paste("<p><font color=\"red\"><b>", names.vec[matched.inx], "</b></font></p>",sep="");
+ mSetObj$dataSet$lib.search$matched.table <- cbind(matched.names, current.msetlib$member[matched.inx], current.msetlib$reference[matched.inx]);
+ }else{
+ mSetObj$dataSet$lib.search$matched.table <-"NA";
+ }
+ if(.on.public.web){
+ .set.mSet(mSetObj);
+ mSetObj$dataSet$lib.search$matched.table;
+ }
+ return(.set.mSet(mSetObj));
+}
+
+#'Set KEGG pathway library
+#'@description note, this process can be long, need to return a value
+#'to force Java to wait
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param kegg.rda Input the name of the KEGG library
+#'@param lib.version Input the KEGG pathway version. "current" for the latest
+#'KEGG pathway library or "v2018" for the KEGG pathway library version prior to November 2019.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+SetKEGG.PathLib1<-function(mSetObj=NA, libNm, lib.version){
+
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$msgSet$lib.msg <- paste("Your selected pathway library code is \\textbf{", libNm, "}(KEGG organisms abbreviation).");
+
+ if(.on.public.web){ #Removed "!" by ZZY on 7/28/21.
+ if(libNm %in% c("spym", "kva", "kpn", "cvr") & lib.version != "current"){
+ AddErrMsg("Support for this organism is only available in the current version!");
+ return(0);
+ }
+ mSetObj$api <- list()
+ mSetObj$api$libVersion <- lib.version
+ mSetObj$api$libNm <- libNm
+ }else{
+ sub.dir <- "kegg/metpa";
+ destfile <- paste0(libNm, ".qs");
+ current.kegglib <<- .get.my.lib(destfile, sub.dir);
+ load_igraph();
+ }
+
+ mSetObj$pathwaylibtype <- "KEGG"
+ return(.set.mSet(mSetObj));
+}
+
+#'Set SMPDB pathway library
+#'@description note, this process can be long, need to return a value
+#'to force Java to wait
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param smpdb.rda Input the name of the SMPDB library (e.g. hsa or mmu)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+SetSMPDB.PathLib<-function(mSetObj=NA, libNm){
+
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$msgSet$lib.msg <- paste("Your selected pathway library code is \\textbf{", libNm, "}(KEGG organisms abbreviation).");
+
+ destfile <- paste0(libNm, ".qs");
+ current.kegglib <<- .get.my.lib(destfile, "smpdb");
+ load_igraph();
+
+ mSetObj$pathwaylibtype <- "SMPDB"
+ return(.set.mSet(mSetObj));
+}
+
+#'Read user uploaded metabolome as a list of KEGG pathway ids
+#'@description Read user uploaded metabolome as a list of KEGG pathway ids
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param filePath Input the path to the user's list of KEGG pathway ids
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+#Setup.KEGGReferenceMetabolome<-function(mSetObj=NA, filePath){ #Modified by ZZY on 7/29/21. See below.
+Setup.KEGGReferenceMetabolome1<-function(mSetObj=NA, filePath, ref.vec=NULL){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+if (is.null(ref.vec)) { #This line was added by ZZY.
+ inFile <- file(filePath, "r");
+ ref.vec<-try(scan(inFile, 'character', strip.white = T, sep="\n")); # must be single column
+ close(inFile);
+ libCheck.msg <- NULL;
+
+ if(class(ref.vec) == "try-error") {
+ libCheck.msg <-c(libCheck.msg, "Data format error - fail to read in the data!");
+ print(libCheck.msg);
+ AddErrMsg(libCheck.msg);
+ return(0);
+ }
+} else { #Added by ZZY.
+ ref.vec <- ref.vec[,1] #Added by ZZY.
+} #Added by ZZY.
+
+ if(anal.type %in% c("msetora", "msetssp", "msetqea")){
+ cmpd.db <- .get.my.lib("master_compound_db.qs");
+ }else{
+ cmpd.db <- .get.my.lib("compound_db.qs");
+ }
+
+ # now need to check all metabolites match HMDB names
+ # and get the statistics
+ hits <- tolower(ref.vec)%in%tolower(cmpd.db$kegg_id);
+# mSetObj$dataSet$metabo.filter.kegg <- ref.vec[hits]; #Changed by ZZY on 7/30/21. See below.
+ mSetObj$dataSet$metabo.filter.hmdb <- doKEGG2NameMapping(ref.vec[hits]);
+ unmatched.num <- sum(!hits);
+
+ if(unmatched.num > 0) {
+ unmatched.nms <- ref.vec[!hits];
+ mSetObj$dataSet$metabo.ref.info <- paste("A total of", unmatched.num, "compounds were not matched to KEGG compound IDs.",
+ "They are:", paste(unmatched.nms, collapse="; "), ". Please correct these names. Otherwise,",
+ "they will be ignored during the enrichment analysis.");
+ }else{
+ mSetObj$dataSet$metabo.ref.info <- paste("A total of", length(ref.vec), "were sucessfully added to the library.");
+ }
+ return(.set.mSet(mSetObj));
+}
+
+#'Read user uploaded metabolome as a list of HMDB compound names
+#'@description Read user uploaded metabolome as a list of HMDB compound names
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param filePath Input the path to the user's list of HMDB compound names
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+#Setup.HMDBReferenceMetabolome<-function(mSetObj=NA, filePath){ #Modified by ZZY on 7/30/21. See below.
+Setup.HMDBReferenceMetabolome1<-function(mSetObj=NA, filePath, ref.vec=NULL, isID=F){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+if (is.null(ref.vec)) { #This line was added by ZZY.
+ inFile <- file(filePath, "r");
+ ref.vec<-try(scan(inFile, 'character', strip.white = T, sep="\n")); # must be single column
+ close(inFile);
+ libCheck.msg <- NULL;
+ if(class(ref.vec) == "try-error") {
+ libCheck.msg <-c(libCheck.msg, "Data format error - fail to read in the data!");
+ AddErrMsg(libCheck.msg);
+ return(0);
+ }
+} else { #Added by ZZY.
+ ref.vec <- ref.vec[,1] #Added by ZZY.
+} #Added by ZZY.
+if (isID)
+ ref.vec<-HMDBID2Name1(ref.vec) #Added by ZZY.
+
+ if(anal.type %in% c("msetora", "msetssp", "msetqea")){
+ cmpd.db <- .get.my.lib("master_compound_db.qs");
+ }else{
+ cmpd.db <- .get.my.lib("compound_db.qs");
+ }
+
+ # now need to check all metabolites match HMDB names
+ # and get the statistics
+ hits <- tolower(ref.vec)%in%tolower(cmpd.db$name);
+ mSetObj$dataSet$metabo.filter.hmdb <- ref.vec[hits];
+ unmatched.num <- sum(!hits);
+
+ if(unmatched.num > 0) {
+ unmatched.nms <- ref.vec[!hits];
+ mSetObj$dataSet$metabo.ref.info <- paste("A total of", unmatched.num, "compounds were not matched to HMDB compound names.",
+ "They are:", paste(unmatched.nms, collapse="; "), ". Please correct these names. Otherwise,",
+ "they will be ignored during the enrichment analysis.");
+ }else{
+ mSetObj$dataSet$metabo.ref.info <- paste("A total of", length(ref.vec), "were successfully added to the library.");
+ }
+ return(.set.mSet(mSetObj));
+}
+
+##############################################
+##############################################
+########## Utilities for web-server ##########
+##############################################
+##############################################
+
+#'Return the selected metset library to java for display
+#'@description Return the selected metset library to java for display
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+GetMsetNames<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(current.msetlib$name);
+}
+
+GetMsetMembers<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(current.msetlib$member);
+}
+
+GetMsetReferences<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(current.msetlib$reference);
+}
+
+GetRefLibCheckMsg<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$dataSet$metabo.ref.info);
+}
+
+#'Set metabolome filter
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param TorF Input metabolome filter
+#'@export
+SetMetabolomeFilter1<-function(mSetObj=NA, TorF){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(!.on.public.web){
+ mSetObj$api$filter <- TorF
+ }
+
+ mSetObj$dataSet$use.metabo.filter <- TorF;
+ return(.set.mSet(mSetObj));
+}
+
+getBestHit<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$dataSet$lib.search$best.hit);
+}
+
+
+#'Return metset search results
+#'@description since String[][] is not supported, have to return as 1D vector,
+#'matrix can be directly convert to vector, note default will be column first
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+GetMsetLibSearchResult<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(as.vector(mSetObj$dataSet$lib.search$matched.table));
+}
+
+GetSMPDBimg<-function(mSetObj=NA, msetInx){
+ mSetObj <- .get.mSet(mSetObj);
+ msetNm <- GetMetSetName(msetInx);
+ inx <- which(current.msetlib$name == msetNm);
+ return(current.msetlib$image[inx]);
+}
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/enrich_name_match.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/enrich_name_match.R
new file mode 100755
index 0000000000000000000000000000000000000000..77f8f773b04084dbb2428acc2c47143abcb638e5
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/enrich_name_match.R
@@ -0,0 +1,881 @@
+#'Various functions for mapping b/w names & database identifiers
+
+#'Given a list of compound names or ids, find matched name or ids from selected databases
+#'@description Given a list of compound names or ids
+#'find matched name or IDs from selected databases
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects).
+#'@param q.type Input the query type, "name" for compound names, "hmdb" for HMDB IDs, "kegg" for KEGG IDs, "pubchem"
+#'for PubChem CIDs, "chebi" for ChEBI IDs, "metlin" for METLIN IDs, and "hmdb_kegg" for a both KEGG and HMDB IDs.
+#'@param hmdb Logical, T to cross reference to HMDB, F to not.
+#'@param pubchem Logical, T to cross reference to PubChem, F to not.
+#'@param chebi Logical, T to cross reference to CheBI, F to not.
+#'@param kegg Logical, T to cross reference to KEGG, F to not.
+#'@param metlin Logical, T to cross reference to MetLin, F to not.
+#'@param lipid Logical, if features are lipids (T), a different database will be used for
+#'compound matching.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+CrossReferencing1 <- function(mSetObj=NA, q.type, hmdb=T, pubchem=T,
+ chebi=F, kegg=T, metlin=F, lipid=F){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # record the filter for 8 major databases
+ mSetObj$return.cols <- c(hmdb, pubchem, chebi, kegg, metlin);
+ mSetObj$lipid.feats <- lipid
+
+ # record all the data
+ if(!exists("name.map", where = mSetObj)){
+ mSetObj$name.map <- list();
+ }
+
+ # distribute job
+ mSetObj$dataSet$q.type <- q.type;
+
+ if(.on.public.web){
+ .set.mSet(mSetObj);
+ MetaboliteMappingExact(mSetObj, q.type, lipid);
+ mSetObj <- .get.mSet(mSetObj);
+ }else{
+ mSetObj <- MetaboliteMappingExact(mSetObj, q.type, lipid);
+ }
+ # do some sanity check
+ todo.inx <- which(is.na(mSetObj$name.map$hit.inx));
+ if(length(mSetObj$name.map$hit.inx) == 0){
+ mSetObj$msgSet$nmcheck.msg <- c(0, "No hits found for the given compound ID. Please make
+ sure that correct compound IDs or common compound names are used.");
+ }else if(length(todo.inx)/length(mSetObj$name.map$hit.inx) > 0.5){
+ mSetObj$msgSet$nmcheck.msg <- c(0, "Over half of the compound IDs could not be matched to our database. Please make
+ sure that correct compound IDs or common compound names are used.");
+ }else if (length(todo.inx) > 15){
+ mSetObj$msgSet$nmcheck.msg <- c(2, "There are >15 compounds without matches. You can either proceed or if necessary, update these compound IDs and upload again.");
+ }else{
+ mSetObj$msgSet$nmcheck.msg <- c(1, "Name matching OK, please inspect (and manual correct) the results then proceed.");
+ }
+
+ if(!.on.public.web){
+# print(mSetObj$msgSet$nmcheck.msg) #Changed by ZZY on 7/30/21. See below.
+ print(mSetObj$msgSet$nmcheck.msg[2])
+
+ if(length(todo.inx) == length(mSetObj$name.map$hit.inx)){
+ AddErrMsg("Name matching failed! Please make sure that correct standardized feature names are used!")
+ return(0)
+ }
+ }
+
+ return(.set.mSet(mSetObj));
+}
+
+#'Mapping from different metabolite IDs
+#'@description For compound names to other ids, can do exact or approximate matches
+#'For other IDs, except HMDB ID, all others may return multiple/non-unique hits
+#'Multiple hits or non-unique hits will allow users to manually select
+#'@param mSetObj Input the name of the created mSetObj.
+#'@param q.type Inpute the query-type, "name" for compound names, "hmdb" for HMDB IDs, "kegg" for KEGG IDs, "pubchem"
+#'for PubChem CIDs, "chebi" for ChEBI IDs, "metlin" for METLIN IDs, and "hmdb_kegg" for a both KEGG and HMDB IDs.
+#'@param lipid Boolean, if features are lipids, a different database will be used for
+#'compound matching.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+MetaboliteMappingExact <- function(mSetObj=NA, q.type, lipid = F){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(lipid & anal.type == "msetqea"){
+ qvec <- unname(mSetObj$dataSet$orig.var.nms) #Bug fix: mSet changed to mSetObj by zzy on 5/26/2021.
+ }else{
+ qvec <- mSetObj$dataSet$cmpd;
+ }
+
+ # variables to record results
+ hit.inx <- vector(mode='numeric', length=length(qvec)); # record hit index, initial 0
+ names(hit.inx) <- qvec;
+ match.values <- vector(mode='character', length=length(qvec)); # the best matched values (hit names), initial ""
+ match.state <- vector(mode='numeric', length=length(qvec)); # match status - 0, no match; 1, exact match; initial 0
+
+ if(anal.type %in% c("msetora", "msetssp", "msetqea") & lipid){
+ cmpd.db <- .get.my.lib("lipid_compound_db.qs");
+ }else if(anal.type == "utils"){
+ cmpd.db <- .get.my.lib("master_compound_db.qs");
+ }else{
+ cmpd.db <- .get.my.lib("compound_db.qs");
+ }
+
+ if(q.type == "hmdb"){
+ n <- 5 # Number of digits for V3 of HMDB
+ hmdb.digits <- as.vector(sapply(cmpd.db$hmdb, function(x) strsplit(x, "HMDB", fixed=TRUE)[[1]][2]))
+ hmdb.v3.ids <- paste0("HMDB", substr(hmdb.digits, nchar(hmdb.digits)-n+1, nchar(hmdb.digits)))
+ hit.inx.v3 <- match(tolower(qvec), tolower(hmdb.v3.ids));
+ hit.inx <- match(tolower(qvec), tolower(cmpd.db$hmdb));
+ hit.inx[is.na(hit.inx)] <- hit.inx.v3[is.na(hit.inx)]
+ match.values <- cmpd.db$name[hit.inx];
+ match.state[!is.na(hit.inx)] <- 1;
+ }else if(q.type == "pubchem"){
+ hit.inx <- match(tolower(qvec), tolower(cmpd.db$pubchem));
+ match.values <- cmpd.db$name[hit.inx];
+ match.state[!is.na(hit.inx)] <- 1;
+ }else if(q.type == "chebi"){
+ hit.inx <- match(tolower(qvec), tolower(cmpd.db$chebi));
+ match.values <- cmpd.db$name[hit.inx];
+ match.state[!is.na(hit.inx)] <- 1;
+ }else if(q.type == "metlin"){
+ hit.inx <- match(tolower(qvec), tolower(cmpd.db$metlin));
+ match.values <- cmpd.db$name[hit.inx];
+ match.state[!is.na(hit.inx)] <- 1;
+ }else if(q.type == "kegg"){
+ hit.inx <- match(tolower(qvec), tolower(cmpd.db$kegg));
+ #hit.inx2 <- match(tolower(qvec), rev(tolower(cmpd.db$kegg)));
+
+ # unique hits
+ #nonuniq.hits <- hit.inx + hit.inx2 != nrow(cmpd.db) + 1;
+ #hit.inx[nonuniq.hits] <- NA;
+ match.values <- cmpd.db$name[hit.inx];
+ match.state[!is.na(hit.inx)] <- 1;
+
+ }else if(q.type == "name"){
+ # first find exact match to the common compound names
+ hit.inx <- match(tolower(qvec), tolower(cmpd.db$name));
+ match.values <- cmpd.db$name[hit.inx];
+ match.state[!is.na(hit.inx)] <- 1;
+
+ # then try to find exact match to synonyms for the remaining unmatched query names one by one
+ if(anal.type %in% c("msetora", "msetssp", "msetqea") & lipid){
+ syn.db <- .get.my.lib("lipid_syn_nms.qs")
+ }else if(anal.type == "utils"){
+ syn.db <- .get.my.lib("master_syn_nms.qs")
+ }else{
+ syn.db <- .get.my.lib("syn_nms.qs")
+ }
+
+ syns.list <- syn.db$syns.list;
+ todo.inx <- which(is.na(hit.inx));
+
+ if(length(todo.inx) > 0){
+ for(i in 1:length(syns.list)){
+ syns <- syns.list[[i]];
+ hitInx <- match(tolower(qvec[todo.inx]), tolower(syns));
+
+ hitPos <- which(!is.na(hitInx));
+ if(length(hitPos)>0){
+ # record matched ones
+ orig.inx<-todo.inx[hitPos];
+ hit.inx[orig.inx] <- i;
+ # match.values[orig.inx] <- syns[hitInx[hitPos]]; # show matched synnames
+ match.values[orig.inx] <- cmpd.db$name[i]; # show common name
+ match.state[orig.inx] <- 1;
+
+ # update unmatched list
+ todo.inx<-todo.inx[is.na(hitInx)];
+ }
+ if(length(todo.inx) == 0) break;
+ }
+ }
+ }else{
+ print(paste("Unknown compound ID type:", q.type));
+ # guess a mix of kegg and hmdb ids
+ hit.inx <- match(tolower(qvec), tolower(cmpd.db$hmdb));
+ hit.inx2 <- match(tolower(qvec), tolower(cmpd.db$kegg));
+ nohmdbInx <- is.na(hit.inx);
+ hit.inx[nohmdbInx]<-hit.inx2[nohmdbInx]
+ match.values <- cmpd.db$name[hit.inx];
+ match.state[!is.na(hit.inx)] <- 1;
+
+ }
+ # empty memory
+ gc();
+
+ mSetObj$name.map$query.vec <- qvec;
+ mSetObj$name.map$hit.inx <- hit.inx;
+ mSetObj$name.map$hit.values <- match.values;
+ mSetObj$name.map$match.state <- match.state;
+
+ return(.set.mSet(mSetObj));
+}
+
+CleanLipidNames <- function(qvec){
+
+ qvec <- qvec
+
+ # first remove A/B
+ qvec <- gsub("/A", "", qvec, fixed = TRUE)
+ qvec <- gsub("_A", "", qvec, fixed = TRUE)
+ qvec <- gsub("/B", "", qvec, fixed = TRUE)
+ qvec <- gsub("_B", "", qvec, fixed = TRUE)
+
+ dash <- paste(c("-1", "-2", "_1", "_2", "_3", "_4", "_5"), collapse = "|")
+ qvec <- gsub(dash, "", qvec)
+
+ # second remove any RT and adduct info
+ load_stringr()
+
+ rt.pat <- paste0(c("@", "\\[M"), collapse = "|")
+ at.inx <- str_detect(qvec, rt.pat)
+
+ if(sum(at.inx) > 0){
+ qvec[at.inx] <- gsub("[;].*", "", qvec[at.inx], fixed = TRUE)
+ }
+
+ # third remove everything inside + including square brackets
+ square.pattern <- paste0(c("\\[", "\\]"), collapse = "|")
+ square.inx <- str_detect(qvec, square.pattern)
+
+ if(sum(square.inx)>0){
+ qvec <- gsub("\\[.*?\\]", "", qvec, fixed = TRUE)
+ }
+
+ # fix up non-standard acronyms
+ coq.inx <- str_detect(qvec, "Co\\(Q")
+ if(sum(coq.inx) > 0){
+ qvec[coq.inx] <- trimws(gsub("[()]", " ", gsub("Co", "Coenzyme", qvec[coq.inx], fixed = TRUE)))
+ }
+
+ acca.inx <- str_detect(qvec, "AcCa")
+ if(sum(acca.inx) > 0){
+ qvec[acca.inx] <- trimws(gsub("[()]", " ", gsub("AcCa", "CAR", qvec[acca.inx], fixed = TRUE)))
+ }
+
+ ac.inx <- str_detect(qvec, "AC\\(")
+ if(sum(ac.inx) > 0){
+ qvec[ac.inx] <- trimws(gsub("[()]", " ", gsub("AC", "CAR", qvec[ac.inx], fixed = TRUE)))
+ }
+
+ a.dash.inx <- str_detect(qvec, "\\(a-")
+ if(sum(a.dash.inx) > 0){
+ qvec[a.dash.inx] <- trimws(gsub("[()]", " ", gsub("a-", "", qvec[a.dash.inx], fixed = TRUE)))
+ }
+
+ pa.inx <- str_detect(qvec, fixed("Plasmanyl-", ignore_case=TRUE))
+ if(sum(pa.inx) > 0){
+ qvec[pa.inx] <- trimws(gsub("[()]", " ", str_replace(qvec[pa.inx], fixed("Plasmanyl-", ignore_case=TRUE), "")))
+ }
+
+ pe.inx <- str_detect(qvec, fixed("Plasmenyl-", ignore_case=TRUE))
+ if(sum(pe.inx) > 0){
+ qvec[pe.inx] <- trimws(gsub("[()]", " ", str_replace(qvec[pe.inx], fixed("Plasmenyl-", ignore_case=TRUE), "")))
+ }
+
+ foura.inx <- str_detect(qvec, fixed("aaaa-", ignore_case=TRUE))
+ if(sum(foura.inx) > 0){
+ qvec[foura.inx] <- trimws(gsub("[()]", " ", str_replace(qvec[foura.inx], fixed("aaaa-", ignore_case=TRUE), "")))
+ }
+
+ twoa.inx <- str_detect(qvec, fixed("aaaa-", ignore_case=TRUE))
+ if(sum(twoa.inx) > 0){
+ qvec[twoa.inx] <- trimws(gsub("[()]", " ", str_replace(qvec[twoa.inx], fixed("aa-", ignore_case=TRUE), "")))
+ }
+
+ phy.inx <- str_detect(qvec, fixed("Phytocer", ignore_case=TRUE))
+ if(sum(phy.inx) > 0){
+ qvec[phy.inx] <- trimws(gsub("[()]", " ", str_replace(qvec[phy.inx], fixed("Phytocer", ignore_case=TRUE), "Cer")))
+ }
+
+ dec.inx <- str_detect(qvec, fixed("deoxy-Cer", ignore_case=TRUE))
+ if(sum(dec.inx) > 0){
+ qvec[dec.inx] <- trimws(gsub("[()]", " ", str_replace(qvec[dec.inx], fixed("deoxy-Cer", ignore_case=TRUE), "1-DeoxyCer")))
+ }
+
+ hex.inx <- str_detect(qvec, fixed("Hex-Cer", ignore_case=TRUE))
+ if(sum(hex.inx) > 0){
+ qvec[hex.inx] <- trimws(gsub("[()]", " ", str_replace(qvec[hex.inx], fixed("Hex-Cer", ignore_case=TRUE), "HexCer")))
+ }
+
+ cerp.inx <- str_detect(qvec, fixed("CerP", ignore_case=TRUE))
+ if(sum(cerp.inx) > 0){
+ qvec[cerp.inx] <- trimws(gsub(";O2", "", gsub("[()]", " ", str_replace(qvec[cerp.inx], " ", " d"))))
+ }
+
+ lpc.inx <- str_detect(qvec, fixed("LPC", ignore_case=TRUE))
+ if(sum(lpc.inx) > 0){
+ qvec[lpc.inx] <- trimws(gsub("[()]", " ", str_replace(qvec[lpc.inx], fixed("LPC", ignore_case=TRUE), "LysoPC")))
+ }
+
+ lpe.inx <- str_detect(qvec, fixed("LPE", ignore_case=TRUE))
+ if(sum(lpe.inx) > 0){
+ qvec[lpe.inx] <- trimws(gsub("[()]", " ", str_replace(qvec[lpe.inx], fixed("LPE", ignore_case=TRUE), "LysoPE")))
+ }
+
+ # last replace . _ ; to slash if no instances of slash in qvec
+
+ slash.inx <- str_detect(qvec, "/")
+
+ if(sum(slash.inx) == 0){
+
+ period.inx <- str_detect(qvec, "[.]")
+ under.inx <- str_detect(qvec, "[_]")
+ semi.inx <- str_detect(qvec, "[;]")
+
+ if(sum(period.inx) > 0){
+ qvec <- gsub(".", "/", qvec, fixed = TRUE)
+ }
+
+ if(sum(under.inx) > 0){
+ qvec <- gsub("_", "/", qvec, fixed = TRUE)
+ }
+
+ if(sum(semi.inx) > 0){
+
+ qvec <- lapply(seq_along(qvec), function(i) {
+
+ change <- semi.inx[i]
+ lipid <- qvec[i]
+
+ if(change & nchar(lipid) > 25){
+ lipid <- gsub(".*[;]", "", lipid, fixed = TRUE)
+ }else{
+ lipid <- gsub(";", "/", lipid, fixed = TRUE)
+ }
+ lipid
+ } )
+
+ qvec <- unlist(qvec)
+ }
+ }
+ return(trimws(qvec))
+}
+
+#' Perform detailed name match
+#'@description Given a query, perform compound matching.
+#'@param mSetObj Input name of the created mSet Object.
+#'@param q Input the query.
+#'@export
+#'
+PerformDetailMatch <- function(mSetObj=NA, q){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ lipid = mSetObj$lipid.feats
+
+ if(mSetObj$dataSet$q.type == "name"){
+ PerformApproxMatch(mSetObj, q, lipid);
+ }else{
+ PerformMultiMatch(mSetObj, q, lipid);
+ }
+}
+
+#' Perform multiple name matches
+#'@description Given a query, performs compound name matching.
+#'@param mSetObj Input name of the created mSet Object.
+#'@param q Input the query.
+#'@export
+#'
+PerformMultiMatch <- function(mSetObj=NA, q, lipid){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(anal.type %in% c("msetora", "msetssp", "msetqea") & lipid){
+ cmpd.db <- .get.my.lib("lipid_compound_db.qs");
+ }else if(anal.type == "utils"){
+ cmpd.db <- .get.my.lib("master_compound_db.qs");
+ }else{
+ cmpd.db <- .get.my.lib("compound_db.qs");
+ }
+
+ matched.inx <- which(cmpd.db$kegg %in% q);
+ if(length(matched.inx) > 0) {
+ # record all the candidates,
+ candidates <- cbind(matched.inx, cmpd.db$name[matched.inx]);
+ mSetObj$dataSet$candidates <- candidates;
+ }else{
+ mSetObj$dataSet$candidates <- NULL;
+ }
+ return(.set.mSet(mSetObj));
+}
+
+#'Perform approximate compound matches
+#'@description Given a query, perform approximate compound matching
+#'@param mSetObj Input the name of the created mSetObj.
+#'@param q Input the q vector.
+#'@export
+#'
+PerformApproxMatch <- function(mSetObj=NA, q, lipid){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(anal.type %in% c("msetora", "msetssp", "msetqea") & lipid){
+ cmpd.db <- .get.my.lib("lipid_compound_db.qs");
+ }else if(anal.type == "utils"){
+ cmpd.db <- .get.my.lib("master_compound_db.qs");
+ }else{
+ cmpd.db <- .get.my.lib("compound_db.qs");
+ }
+
+ if(anal.type %in% c("msetora", "msetssp", "msetqea") & lipid){
+ syn.db <- .get.my.lib("lipid_syn_nms.qs")
+ }else if(anal.type == "utils"){
+ syn.db <- .get.my.lib("master_syn_nms.qs")
+ }else{
+ syn.db <- .get.my.lib("syn_nms.qs")
+ }
+
+ if(!lipid){
+ # only for none lipids
+ nonLipidInx <- cmpd.db$lipid == 0;
+ com.nms <- cmpd.db$name[nonLipidInx];
+
+ syns.vec <- syn.db$syns.vec[nonLipidInx];
+ syns.list <- syn.db$syns.list[nonLipidInx];
+
+ matched.dist <- NULL;
+ q.length <- nchar(q);
+ s <- c(0, 0.1, 0.2);
+
+ # init withno hits, then see if any hits
+ mSetObj$dataSet$candidates <- NULL;
+
+ for (j in s) {
+ new.q <- q;
+ if(q.length > 32){ # note: agrep fail for exact match when length over 32 characters
+ new.q<-substr(q, 1, 32);
+ }
+ matched <- FALSE;
+ matched.inx <- agrep(new.q, syns.vec, ignore.case=T, max.distance=j, useBytes=T);
+
+ if(length(matched.inx) > 0) {
+ # record all the candidates,
+ # don't use cbind, since all will be converted to character mode
+ # for data.frame specify "stringsAsFactors" to prevent convert value col into factor
+ candidates <- data.frame(index=vector(mode = "numeric", length=length(matched.inx)),
+ value=vector(mode = "character", length=length(matched.inx)),
+ score=vector(mode = "numeric", length=length(matched.inx)),
+ stringsAsFactors = FALSE);
+
+ for(n in 1:length(matched.inx)){
+ nm.vec<-syns.list[[matched.inx[n]]];
+ # try approximate match, note: in some cases, split into element will break match using whole string
+ hit3.inx <- agrep(q,nm.vec,ignore.case=T, max.distance=j, useBytes=T);
+ if(length(hit3.inx)>0){
+ hit3.nm <- vector(mode = "character", length=length(hit3.inx));
+ hit3.score <- vector(mode = "numeric", length=length(hit3.inx));
+ for(k in 1:length(hit3.inx)){
+ idx <- hit3.inx[k];
+ hit3.nm[k] <- nm.vec[idx];
+ hit3.score[k] <- j + abs(nchar(nm.vec[idx])-nchar(q))/(10*nchar(q));
+ }
+
+ # now get the best match, the rule is that the first two character should matches
+ # first check if first two character are digits or characters, otherwise will cause error
+ matches2 <- c();
+ if(length(grep("^[1-9a-z]{2}", q, ignore.case=T))>0){
+ matches2 <- grep(paste("^", substr(q, 1, 2), sep=""), hit3.nm);
+ }else if (length(grep("^[1-9a-z]", q, ignore.case=T))>0){
+ matches2 <- grep(paste("^", substr(q, 1, 1), sep=""), hit3.nm);
+ }
+
+ if(length(matches2)>0){
+ hit3.score[matches2] <- hit3.score[matches2] - 0.05;
+ }
+
+ best.inx<-which(hit3.score==min(hit3.score))[1];
+ candidates[n,1]<-matched.inx[n];
+ # candidates[n,2]<-hit3.nm[best.inx]; # show matched syn names
+ candidates[n,2]<-com.nms[matched.inx[n]] # show common names
+ candidates[n,3]<-hit3.score[best.inx];
+ }
+ }
+
+ rm.inx <- is.na(candidates[,2]) | candidates[,2]=="NA" | candidates[,2]=="";
+ mSetObj$dataSet$candidates<-candidates[!rm.inx, ];
+ mSetObj$dataSet$candidates<-candidates[order(candidates[,3], decreasing=F), , drop=F];
+
+ if(nrow(candidates) > 10){
+ mSetObj$dataSet$candidates<-candidates[1:10,];
+ }
+ return(.set.mSet(mSetObj));
+ }
+ }
+ }else{
+
+ mSetObj$dataSet$candidates <- NULL;
+
+ new.q <- CleanLipidNames(q)
+ syns.vec <- syn.db$syns.vec;
+ com.nms <- cmpd.db$name
+
+ matched.inx <- agrep(new.q, syns.vec, ignore.case=T, max.distance=0, useBytes=T);
+
+ if(length(matched.inx) == 0){
+ matched.inx <- agrep(new.q, syns.vec, ignore.case=T, max.distance=0.1, useBytes=T);
+ }
+
+ if(length(matched.inx) > 0){
+
+ candidates <- data.frame(index=vector(mode = "numeric", length=length(matched.inx)),
+ value=vector(mode = "character", length=length(matched.inx)),
+ score=vector(mode = "numeric", length=length(matched.inx)),
+ stringsAsFactors = FALSE);
+
+ for(n in seq_along(matched.inx)){
+ candidates[n,1] <- matched.inx[n];
+ candidates[n,2] <- com.nms[matched.inx[n]] # show common names
+ candidates[n,3] <- min(as.numeric(adist(new.q, unlist(strsplit(syns.vec[matched.inx[1]], "; ")) )))
+ }
+
+
+ candidates <- candidates[order(candidates[,3]),]
+
+ if(nrow(candidates) > 10){
+ matched.inx <- candidates[1:10, ]
+ }
+
+ mSetObj$dataSet$candidates <- candidates
+ }
+ }
+ return(.set.mSet(mSetObj));
+}
+
+#'Set matched name based on user selection from all potential hits
+#'@description Note: to change object in the enclosing enviroment, use "<<-"
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects).
+#'@param query_nm Input the query name.
+#'@param can_nm Input the candidate name.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+SetCandidate <- function(mSetObj=NA, query_nm, can_nm){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ lipid = mSetObj$lipid.feats
+
+ query_inx <- which(mSetObj$name.map$query.vec == query_nm);
+
+ can_mat <- mSetObj$dataSet$candidates;
+
+ if(!is.null(can_mat)){
+
+ if(anal.type %in% c("msetora", "msetssp", "msetqea") & lipid){
+ cmpd.db <- .get.my.lib("lipid_compound_db.qs");
+ }else if(anal.type == "utils"){
+ cmpd.db <- .get.my.lib("master_compound_db.qs");
+ }else{
+ cmpd.db <- .get.my.lib("compound_db.qs");
+ }
+
+ can_inx <- which(can_mat[,2] == can_nm);
+
+ if(can_inx <= nrow(can_mat)){
+ can_inx <- which(cmpd.db$name == can_nm);
+ hit <- cmpd.db[can_inx, ,drop=F];
+ mSetObj$name.map$hit.inx[query_inx] <- can_inx;
+ mSetObj$name.map$hit.values[query_inx] <- hit[,2];
+ mSetObj$name.map$match.state[query_inx] <- 1;
+
+ # re-generate the CSV file
+ csv.res <- mSetObj$dataSet$map.table;
+ if(ncol(csv.res) > 7){ # general utilities
+ csv.res[query_inx, ]<-c(csv.res[query_inx, 1],
+ mSetObj$name.map$hit.values[query_inx],
+ hit$hmdb_id,
+ hit$pubchem_id,
+ hit$chebi_id,
+ hit$kegg_id,
+ hit$metlin_id,
+ hit$smiles,
+ 1);
+ }else{ # pathway analysis
+ csv.res[query_inx, ]<-c(csv.res[query_inx, 1],
+ mSetObj$name.map$hit.values[query_inx],
+ hit$hmdb_id,
+ hit$pubchem_id,
+ hit$kegg_id,
+ hit$smiles,
+ 1);
+ }
+ fast.write.csv(csv.res, file="name_map.csv", row.names=F);
+ mSetObj$dataSet$map.table <- csv.res;
+ }else{ #no match
+ mSetObj$name.map$hit.inx[query_inx] <- 0;
+ mSetObj$name.map$hit.values[query_inx] <- "";
+ mSetObj$name.map$match.state[query_inx] <- 0;
+ print("No name matches found.")
+ }
+ }
+
+ if(.on.public.web){
+ .set.mSet(mSetObj);
+ return(query_inx);
+ }else{
+ return(.set.mSet(mSetObj));
+ }
+}
+
+##############################################
+##############################################
+########## Utilities for web-server ##########
+##############################################
+##############################################
+
+#'Get all candidate compound names for a given index
+#'@description Returns 3 coloumns - inx, name, score
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+GetCandidateList <- function(mSetObj=NA, lipid){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ lipid = mSetObj$lipid.feats
+
+ can_hits <- mSetObj$dataSet$candidates;
+
+ if(is.null(can_hits)){
+ can.mat <- matrix("", nrow=1, ncol= 6);
+ }else{
+ # construct the result table with cells wrapped in html tags
+ # the unmatched will be highlighted in different background
+
+ can.mat <- matrix("", nrow=nrow(can_hits)+1, ncol= 6);
+
+ if(anal.type %in% c("msetora", "msetssp", "msetqea") & lipid){
+ cmpd.db <- .get.my.lib("lipid_compound_db.qs");
+ }else if(anal.type == "utils"){
+ cmpd.db <- .get.my.lib("master_compound_db.qs");
+ }else{
+ cmpd.db <- .get.my.lib("compound_db.qs");
+ }
+
+ if(!lipid){
+ # need to exclude lipids, to be consistent with approx matching part so that same index can be used to fetch db entries
+ nonLipidInx <- cmpd.db$lipid == 0;
+ cmpd.db <-cmpd.db[nonLipidInx,];
+ }
+
+ for (i in 1:nrow(mSetObj$dataSet$candidates)){
+ hit.inx <- mSetObj$dataSet$candidates[i, 1];
+ hit.name <- mSetObj$dataSet$candidates[i, 2];
+ hit <- cmpd.db[hit.inx, ,drop=F];
+ can.mat[i, ] <- c(hit.name,
+ paste(ifelse(hit$hmdb_id=="NA","", paste("<a href=http://www.hmdb.ca/metabolites/", hit$hmdb_id, " target='_blank'>",hit$hmdb_id,"</a>", sep="")), sep=""),
+ paste(ifelse(hit$pubchem_id=="NA", "", paste("<a href=http://pubchem.ncbi.nlm.nih.gov/summary/summary.cgi?cid=", hit$pubchem_id," target='_blank'>", hit$pubchem_id,"</a>", sep="")), sep=""),
+ paste(ifelse(hit$chebi_id=="NA","", paste("<a href=http://www.ebi.ac.uk/chebi/searchId.do?chebiId=", hit$chebi_id, " target='_blank'>",hit$chebi_id,"</a>", sep="")), sep=""),
+ paste(ifelse(hit$kegg_id=="NA","",paste("<a href=http://www.genome.jp/dbget-bin/www_bget?", hit$kegg_id, " target='_blank'>", hit$kegg_id,"</a>", sep="")), sep=""),
+ paste(ifelse(hit$metlin_id=="NA","",paste("<a href=http://metlin.scripps.edu/metabo_info.php?molid=", hit$metlin_id," target='_blank'>",hit$metlin_id,"</a>", sep="")), sep=""));
+ }
+ # add "none" option
+ can.mat[nrow(mSetObj$dataSet$candidates)+1,] <- c("None of the above", "", "", "", "", "");
+ }
+ # add the hit columns
+ return.cols <- c(TRUE, mSetObj$return.cols);
+
+ if(.on.public.web){
+ return(as.vector(can.mat[,return.cols, drop=F]));
+ }
+
+ mSetObj$name.map$hits.candidate.list <- can.mat[,mSetObj$return.cols, drop=F]
+
+ return(.set.mSet(mSetObj));
+}
+
+GetCanListRowNumber <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ if(is.null(mSetObj$dataSet$candidates)){
+ return(1);
+ }else{
+ return(nrow(mSetObj$dataSet$candidates)+1); # include the "none" row
+ }
+}
+
+GetQuery <- function(mSetObj=NA, inx){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$dataSet$cmpd[inx]);
+}
+
+#'Return the final (after user selection) map as dataframe
+#'@description Returns three columns: original name, HMDB name and KEGG ID,
+#'for enrichment and pathway analysis, respectively
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+GetFinalNameMap <- function(mSetObj=NA, lipid = FALSE){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ lipid = mSetObj$lipid.feats
+
+ if (is.null(lipid)) {
+ lipid = FALSE
+ }
+
+ hit.inx <- mSetObj$name.map$hit.inx;
+ hit.values <- mSetObj$name.map$hit.values;
+ match.state <- mSetObj$name.map$match.state;
+
+ qvec <- mSetObj$dataSet$cmpd;
+ nm.mat <- matrix(nrow=length(qvec), ncol=4);
+ colnames(nm.mat) <- c("query", "hmdb", "kegg", "hmdbid");
+
+ if(anal.type %in% c("msetora", "msetssp", "msetqea") & lipid){
+ cmpd.db <- .get.my.lib("lipid_compound_db.qs");
+ }else if(anal.type == "utils"){
+ cmpd.db <- .get.my.lib("master_compound_db.qs");
+ }else{
+ cmpd.db <- .get.my.lib("compound_db.qs");
+ }
+
+ for (i in 1:length(qvec)){
+ hit <-cmpd.db[hit.inx[i], ,drop=F];
+ if(match.state[i]==0){
+ hmdb.hit <- NA;
+ hmdb.hit.id <- NA;
+ kegg.hit <- NA;
+ }else{
+ hmdb.hit <- ifelse(nchar(hit.values[i])==0, NA, hit.values[i]);
+ hmdb.hit.id <- ifelse(nchar(hit$hmdb_id)==0, NA, hit$hmdb_id);
+ kegg.hit <- ifelse(nchar(hit$kegg_id)==0, NA, hit$kegg_id);
+ }
+ nm.mat[i, ]<-c(qvec[i], hmdb.hit, kegg.hit, hmdb.hit.id);
+ }
+ return(as.data.frame(nm.mat));
+}
+
+#'Get mapping table
+#'@description Return results from compound name mapping in a table
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@export
+
+GetMapTable <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ print(xtable::xtable(mSetObj$dataSet$map.table, caption="Result from Compound Name Mapping"),
+ tabular.environment = "longtable", caption.placement="top", size="\\scriptsize");
+}
+
+#'Creates the mapping result table
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@export
+CreateMappingResultTable1 <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ lipid <- mSetObj$lipid.feats
+
+ if(lipid & anal.type == "msetqea"){
+ qvec <- unname(mSetObj$dataSet$orig.var.nms) #Bug fix: mSet changed to mSetObj by zzy on 5/26/2021.
+ }else{
+ qvec <- mSetObj$dataSet$cmpd;
+ }
+
+ if(is.null(qvec)){
+ return();
+ }
+ # style for highlighted background for unmatched names
+ pre.style<-NULL;
+ post.style<-NULL;
+
+ # style for no matches
+ if(mSetObj$dataSet$q.type == "name"){
+ no.prestyle<-"<strong style=\"background-color:yellow; font-size=125%; color=\"black\">";
+ no.poststyle<-"</strong>";
+ }else{
+ no.prestyle<-"<strong style=\"background-color:red; font-size=125%; color=\"black\">";
+ no.poststyle<-"</strong>";
+ }
+
+ hit.inx<-mSetObj$name.map$hit.inx;
+ hit.values<-mSetObj$name.map$hit.values;
+ match.state<-mSetObj$name.map$match.state;
+
+ # construct the result table with cells wrapped in html tags
+ # the unmatched will be highlighted in different background
+ html.res <- matrix("", nrow=length(qvec), ncol=8);
+ csv.res <- matrix("", nrow=length(qvec), ncol=9);
+ colnames(csv.res) <- c("Query", "Match", "HMDB", "PubChem", "ChEBI", "KEGG", "METLIN", "SMILES", "Comment");
+
+ if(anal.type %in% c("msetora", "msetssp", "msetqea") & lipid){
+ cmpd.db <- .get.my.lib("lipid_compound_db.qs");
+ }else if(anal.type == "utils"){
+ cmpd.db <- .get.my.lib("master_compound_db.qs");
+ }else{
+ cmpd.db <- .get.my.lib("compound_db.qs");
+ }
+
+ for (i in 1:length(qvec)){
+ if(match.state[i]==1){
+ pre.style<-"";
+ post.style="";
+ }else{ # no matches
+ pre.style<-no.prestyle;
+ post.style<-no.poststyle;
+ }
+ hit <-cmpd.db[hit.inx[i], ,drop=F];
+ html.res[i, ]<-c(paste(pre.style, qvec[i], post.style, sep=""),
+ paste(ifelse(match.state[i]==0, "", hit.values[i]), sep=""),
+ paste(ifelse(match.state[i]==0 || is.na(hit$hmdb_id) || hit$hmdb_id=="" || hit$hmdb_id=="NA","-", paste("<a href=http://www.hmdb.ca/metabolites/", hit$hmdb_id, " target='_blank'>",hit$hmdb_id,"</a>", sep="")), sep=""),
+ paste(ifelse(match.state[i]==0 || is.na(hit$pubchem_id) || hit$pubchem_id=="" || hit$pubchem_id=="NA", "-", paste("<a href=http://pubchem.ncbi.nlm.nih.gov/summary/summary.cgi?cid=", hit$pubchem_id," target='_blank'>", hit$pubchem_id,"</a>", sep="")), sep=""),
+ paste(ifelse(match.state[i]==0 || is.na(hit$chebi_id) || hit$chebi_id==""|| hit$chebi_id=="NA","-", paste("<a href=http://www.ebi.ac.uk/chebi/searchId.do?chebiId=", hit$chebi_id, " target='_blank'>",hit$chebi_id,"</a>", sep="")), sep=""),
+ paste(ifelse(match.state[i]==0 || is.na(hit$kegg_id) || hit$kegg_id==""|| hit$kegg_id=="NA","-",paste("<a href=http://www.genome.jp/dbget-bin/www_bget?", hit$kegg_id, " target='_blank'>", hit$kegg_id,"</a>", sep="")), sep=""),
+ paste(ifelse(match.state[i]==0 || is.na(hit$metlin_id) || hit$metlin_id==""|| hit$metlin_id=="NA","-",paste("<a href=http://metlin.scripps.edu/metabo_info.php?molid=", hit$metlin_id," target='_blank'>",hit$metlin_id,"</a>", sep="")), sep=""),
+ ifelse(match.state[i]!=1,"View",""));
+ csv.res[i, ]<-c(qvec[i],
+ ifelse(match.state[i]==0, "NA", hit.values[i]),
+ ifelse(match.state[i]==0, "NA", hit$hmdb_id),
+ ifelse(match.state[i]==0, "NA", hit$pubchem_id),
+ ifelse(match.state[i]==0, "NA", hit$chebi_id),
+ ifelse(match.state[i]==0, "NA", hit$kegg_id),
+ ifelse(match.state[i]==0, "NA", hit$metlin_id),
+ ifelse(match.state[i]==0, "NA", hit$smiles),
+ match.state[i]);
+ }
+ # return only columns user selected
+
+ # add query and match columns at the the beginning, and 'Detail' at the end
+ return.cols <- c(TRUE, TRUE, mSetObj$return.cols, TRUE);
+ html.res <- html.res[,return.cols, drop=F];
+ csv.res <- csv.res[,return.cols, drop=F];
+
+ # store the value for report
+ mSetObj$dataSet$map.table <- csv.res;
+ fast.write.csv(csv.res, file="name_map.csv", row.names=F);
+
+ if(.on.public.web){
+ .set.mSet(mSetObj);
+ return(as.vector(html.res));
+ }else{
+ return(.set.mSet(mSetObj));
+ }
+}
+
+GetHitsRowNumber<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(length(mSetObj$name.map$hit.inx));
+}
+
+GetPathNames<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$dataSet$path.res[,1]);
+}
+
+GetMatchedCompounds<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$dataSet$path.res[,2]);
+}
+
+GetIsLipids <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ is.lipid <- mSetObj$lipid.feats
+
+ if(is.lipid){
+ is.lipid <- "lipid"
+ }else{
+ is.lipid <- "met"
+ }
+
+ return(is.lipid)
+}
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/enrich_path_graphics.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/enrich_path_graphics.R
new file mode 100755
index 0000000000000000000000000000000000000000..afacfc79bfd47fdc92db59a5801c03e49ea8cc15
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/enrich_path_graphics.R
@@ -0,0 +1,581 @@
+#'Plot metabolome pathway
+#'@description Plot KEGG pathway graph
+#'@param mSetObj Input name of the created mSet Object
+#'@param pathName Input the name of the selected pathway
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@param height Input the height of the created plot.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotKEGGPath1 <- function(mSetObj=NA, pathName, width=NA, height=NA, format="png", dpi=NULL){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(!.on.public.web){ #Added "!" by ZZY on 7/26/21.
+ load_kegggraph()
+ load_rgraphwiz()
+
+ if(mSetObj$analSet$type == "pathinteg"){
+ return(PlotInmexPath(mSetObj, pathName, width, height, format, dpi));
+ }else{
+ return(PlotMetpaPath1(mSetObj, pathName, width, height, format, dpi));
+ }
+
+ # plotting via microservice
+ }else{
+
+ mSetObj$api$analType <- mSetObj$analSet$type
+
+ if(is.null(dpi)){
+ dpi <- 72
+ }
+
+ if(is.na(width)){
+ width <- 8;
+ }
+
+ if(is.na(height)){
+ height <- 8;
+ }
+
+ # first need to post to create image on server
+ if(mSetObj$api$analType == "pathinteg"){
+ toSend <- list(guestName = mSetObj$api$guestName, analType = mSetObj$api$analType, pathName = pathName,
+ width = width, height = height, format = format, dpi = dpi, pathintegImpMatName = mSetObj$dataSet$pathinteg.impMat[,1],
+ pathintegImpMatFC = mSetObj$dataSet$pathinteg.impMat[,2])
+ }else{
+ toSend <- list(guestName = mSetObj$api$guestName, analType = mSetObj$api$analType, pathName = pathName,
+ width = width, height = height, format = format, dpi = dpi)
+ }
+
+ load_httr()
+ base <- api.base
+ endpoint <- paste0("/createimage/", mSetObj$api$guestName)
+ call <- paste(base, endpoint, sep="")
+ query_results <- httr::POST(call, body = toSend, encode= "json")
+ query_results_text <- content(query_results, "text")
+ query_results_json <- RJSONIO::fromJSON(query_results_text, flatten = TRUE)
+ mSetObj$api$imageName <- query_results_json$plotName
+
+ if(is.null(mSetObj$api$imageName)){
+ AddErrMsg("Error! Unable to connect to api.metaboanalyst.ca!")
+ return(0)
+ }
+
+ # second need to get image from server
+ endpoint_image <- paste0("/getFile/", mSetObj$api$guestName, "/", mSetObj$api$imageName)
+ image_call <- paste(base, endpoint_image, sep="")
+ download.file(image_call, destfile = basename(mSetObj$api$imageName))
+ print(paste0(mSetObj$api$imageName, " saved to current working directory!"))
+
+ return(.set.mSet(mSetObj));
+ }
+}
+
+#'Plot KEGG pathway
+#'@param mSetObj Input name of the created mSet Object
+#'@param pathName Input the name of the selected KEGG pathway
+#'@param format Select the image format, "png", or "pdf".
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotMetpaPath1<-function(mSetObj=NA, pathName, width=NA, height=NA, format="png", dpi=NULL){
+
+ path.id <- current.kegglib$path.ids[pathName];
+ g <- current.kegglib$graph.list[[path.id]];
+ tooltip <- names(KEGGgraph::nodes(g));
+
+ nm.vec <- NULL;
+
+ fillcolvec <- rep("lightblue", length(KEGGgraph::nodes(g)));
+ pvec <- histvec <- rep("NA", length(KEGGgraph::nodes(g)));
+ names(tooltip) <- names(fillcolvec) <- names(histvec) <- names(pvec) <- KEGGgraph::nodes(g);
+
+ if(mSetObj$analSet$type == "pathora"){
+ if(!is.null(mSetObj$analSet$ora.hits)){
+ fillcolvec[mSetObj$analSet$ora.hits[[path.id]]] <- "red";
+ if(mSetObj$dataSet$use.metabo.filter && !is.null(mSetObj$analSet$ora.filtered.mset)){
+ fillcolvec[!(names(fillcolvec) %in% mSetObj$analSet$ora.filtered.mset[[path.id]])]<- "lightgrey";
+ }
+ }
+ }else{
+ if(!is.null(mSetObj$analSet$qea.hits)){
+ hit.cmpds <- mSetObj$analSet$qea.hits[[path.id]];
+ # now plotting summary graphs for each compounds
+ for(i in 1:length(hit.cmpds)){
+ cmpd <- hit.cmpds[i];
+ histvec[cmpd] <- cmpd;
+ cmpd.name <- paste(cmpd,"_",gsub("/","_",names(cmpd)), ".pdf", sep=""); #Changed from "png" to "pdf" by ZZY on 8/1/21. Changed cmpd to its name.
+ Cairo::Cairo(file=cmpd.name, width=180, height=180, bg = "white", type="pdf", dpi=72); #Changed by ZZY on 7/31/21. bg from "transparent" to "white"; type from "png" to "pdf"; added dpi=72.
+ # remember to change jscode for image size when the change the size above
+ par(mar=c(4,4,1,1));
+
+ y.label <- GetAbundanceLabel(mSetObj$dataSet$type);
+ if(is.factor(mSetObj$dataSet$cls)){
+ cls.lbls <- mSetObj$dataSet$cls;
+ if(max(nchar(levels(mSetObj$dataSet$cls))) > 6){
+ cls.lbls <- as.factor(abbreviate(as.character(cls.lbls), 6));
+ }
+ boxplot(mSetObj$dataSet$norm.path[, cmpd]~cls.lbls, col= unique(GetColorSchema(cls.lbls)), ylab=y.label, las=2);
+ }else{
+ Rgraphviz::plot(mSetObj$dataSet$norm.path[, cmpd], mSetObj$dataSet$cls, pch=19, col="forestgreen", xlab="Index", ylab=y.label);
+ abline(lm(mSetObj$dataSet$cls~mSetObj$dataSet$norm.path[, cmpd]), col="red")
+ }
+ dev.off();
+ nm.vec <- c(nm.vec, cmpd.name);
+ }
+
+ pvals <- mSetObj$analSet$qea.univp[hit.cmpds];
+ pvec[hit.cmpds] <- pvals;
+
+ bg.vec <- heat.colors(length(pvals));
+
+ # reorder the colors according to the ordered p values
+ ord.inx <- match(pvals, sort(pvals));
+ fillcolvec[hit.cmpds] <- bg.vec[ord.inx];
+
+ if(mSetObj$dataSet$use.metabo.filter && !is.null(mSetObj$analSet$qea.filtered.mset)){
+ fillcolvec[!(names(fillcolvec) %in% mSetObj$analSet$qea.filtered.mset[[path.id]])]<- "lightgrey";
+ }
+ }
+ }
+
+ if(is.null(dpi)){
+ if(is.null(mSetObj$analSet$node.imp) || mSetObj$analSet$node.imp == "rbc"){
+ impvec <- current.kegglib$rbc[[path.id]];
+ }else{
+ impvec <- current.kegglib$dgr[[path.id]];
+ }
+
+ imgName <- paste(pathName, ".png", sep="");
+ imgName <- gsub('/','_',imgName) #Added by ZZY on 7/29/21.
+
+ ## Open plot device
+ Cairo::Cairo(file=imgName, width=width, height=height, type="png", bg="white");
+ par(mai=rep(0,4));
+ g.obj <- plot(g, nodeAttrs = setRendAttrs(g, fillcolor=fillcolvec));
+ nodeInfo <- GetMetPANodeInfo(pathName, g.obj, tooltip, histvec, pvec, impvec, width, height);
+ dev.off();
+ mSetObj$imgSet$current.metpa.graph <- g.obj;
+ mSetObj$analSet$nodeInfo <- nodeInfo;
+
+ if(.on.public.web){
+ .set.mSet(mSetObj);
+ return(nodeInfo);
+ }else{
+ return(.set.mSet(mSetObj));
+ }
+ }else{
+ pathName <- gsub("\\s","_", pathName);
+ pathName <- gsub(",","", pathName);
+
+ imgName = paste(pathName, "_dpi", dpi, ".", format, sep="");
+ imgName <- gsub('/','_',imgName) #Added by ZZY on 7/29/21.
+
+ if(is.na(width)){
+ width <- 8;
+ }
+ w <- h <- width;
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ par(mai=rep(0,4));
+ g.obj <- plot(g, nodeAttrs = setRendAttrs(g, fillcolor=fillcolvec));
+ dev.off();
+
+ return(imgName);
+ }
+}
+
+# Used in higher function
+
+GetMetPANodeInfo<-function(pathName, object, tags, histvec, pvec, impvec, width, height, usr = par("usr")){
+
+ nn = sapply(Rgraphviz::AgNode(object), function(x) x@name);
+
+ ## transform user to pixel coordinates
+ x.u2p = function(x) { rx=(x-usr[1])/diff(usr[1:2]); stopifnot(all(rx>=0&rx<=1)); return(rx*width) }
+ y.u2p = function(y) { ry=(usr[4]-y)/diff(usr[3:4]); stopifnot(all(ry>=0&ry<=1)); return(ry*height) }
+
+ nxy = Rgraphviz::getNodeXY(object);
+ nh = Rgraphviz::getNodeHeight(object)/2;
+ xl = floor(x.u2p( nxy$x - Rgraphviz::getNodeLW(object) ));
+ xr = ceiling(x.u2p( nxy$x + Rgraphviz::getNodeRW(object)));
+ yu = floor(y.u2p( nxy$y - nh ));
+ yl = ceiling(y.u2p( nxy$y + nh ));
+ names(xl) = names(xr) = names(yu) = names(yl) = nn;
+
+ # create the javascript code
+ jscode <- paste("keggPathLnk=\'<a href=\"javascript:void(0);\" onclick=\"window.open(\\'http://www.genome.jp/kegg-bin/show_pathway?", current.kegglib$path.ids[pathName], "\\',\\'KEGG\\');\">", pathName,"</a>\'", sep="");
+ tag.ids <- names(tags);
+ kegg.ids <- names(tags);
+ hmdb.ids <- KEGGID2HMDBID(kegg.ids);
+ for(i in 1:length(tag.ids)) {
+ nd <- tag.ids[i];
+ x1 <- floor(100*(xl[nd])/width);
+ x2 <- ceiling(100*(xr[nd])/width);
+ y1 <- floor(100*(yl[nd])/height);
+ y2 <- ceiling(100*(yu[nd])/height);
+
+ #add code for mouseover locations, basically the annotation info
+ #in this case, the name of the node
+ jscode <- paste(jscode, paste("rectArray.push({x1:", x1, ", y1:", y1, ", x2:", x2, ", y2:", y2,
+ ", lb: \"", tags[i], "\", kegg: \"", kegg.ids[i], "\", hmdb: \"", hmdb.ids[i],
+ "\", icon: \"", histvec[i], "\", pvalue: \"", pvec[i], "\", impact: \"", impvec[i], "\"})", sep=""), sep="\n");
+ }
+ return(jscode);
+}
+
+# Generate suitable features for nodes and edges
+# adapted from PathRender, used in higher functions.
+# Jeff Xia \email{jeff.xia@mcgill.ca}
+# McGill University, Canada
+# License: GNU GPL (>= 2)
+
+setRendAttrs = function(g, AllBorder="transparent",
+ AllFixedsize=FALSE, AllFontsize=16, AllShape="rectangle",
+ fillcolor="lightgreen", ...) {
+ nn = KEGGgraph::nodes(g)
+ numn = length(nn)
+ color = rep(AllBorder, numn)
+ names(color)=nn
+ fixedsize = rep(AllFixedsize, numn)
+ names(fixedsize) = nn
+ if (length(fillcolor)==1) {
+ fillcolvec = rep(fillcolor, numn)
+ names(fillcolvec) = nn
+ } else if (!identical(names(fillcolor), as.vector(KEGGgraph::nodes(g)))){
+ stop("names on vector fillcolor must match nodes(g) exactly")
+ } else {
+ fillcolvec = fillcolor
+ }
+ shape = rep(AllShape, numn)
+ names(shape) = nn
+ fontsize = rep(AllFontsize, numn)
+ names(fontsize) = nn;
+ list(color=color, fixedsize=fixedsize, fillcolor=fillcolvec, shape=shape,
+ fontsize=fontsize )
+}
+
+#'Plot a scatterplot (circle) overview of the matched pathways
+#'@description x axis is the pathway impact factor
+#'y axis is the p value (from ORA or globaltest)
+#'return the circle information
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'@param x Input the X
+#'@param y Input the Y
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotPathSummary1<-function(mSetObj=NA, show.grid, imgName, format="png", dpi=72, width=NA, x, y, labeling=F){
+
+ mSetObj <- .get.mSet(mSetObj);
+ if(mSetObj$analSet$type == "pathora"){
+ x <- mSetObj$analSet$ora.mat[,8];
+ y <- mSetObj$analSet$ora.mat[,4];
+ names(x) <- names(y) <- rownames(mSetObj$analSet$ora.mat);
+
+ if(!.on.public.web){
+ path.nms <- rownames(mSetObj$analSet$ora.mat);
+ }
+
+ }else if(mSetObj$analSet$type == "pathqea"){
+ x <- mSetObj$analSet$qea.mat[,7];
+ y <- mSetObj$analSet$qea.mat[,3];
+ names(x) <- names(y) <- rownames(mSetObj$analSet$qea.mat);
+
+ if(!.on.public.web){
+ path.nms <- rownames(mSetObj$analSet$qea.mat);
+ }
+
+ }else if (mSetObj$analSet$type == "pathinteg"){ # this is integrative analysis
+ x <- as.numeric(mSetObj$dataSet$path.mat[,8]);
+ y <- as.numeric(mSetObj$dataSet$path.mat[,4]);
+ names(x) <- names(y) <- rownames(mSetObj$dataSet$path.mat);
+
+ if(!.on.public.web){
+ path.nms <- rownames(mSetObj$analSet$jointPAMatches);
+ }
+
+ }else{
+ print(paste("Unknown analysis type: ", mSetObj$analSet$type));
+ return(0);
+ }
+
+ # first sort values based on p
+ y = -log10(y);
+ inx <- order(y, decreasing= T);
+ x <- x[inx];
+ y <- y[inx];
+
+ # set circle size according to impact
+ # take sqrt to increase spread out
+ sqx <- sqrt(x);
+ min.x<- min(sqx, na.rm = TRUE);
+ max.x <- max(sqx, na.rm = TRUE);
+
+ if(min.x == max.x){ # only 1 value
+ max.x = 1.5*max.x;
+ min.x = 0.5*min.x;
+ }
+
+ maxR <- (max.x - min.x)/40;
+ minR <- (max.x - min.x)/160;
+ radi.vec <- minR+(maxR-minR)*(sqx-min.x)/(max.x-min.x);
+
+ # set background color according to y
+ bg.vec <- heat.colors(length(y));
+
+ if(.on.public.web){
+ if(mSetObj$analSet$type == "pathinteg"){
+ path.nms <- names(current.kegglib$path.ids)[match(names(x),current.kegglib$path.ids)];
+ }else{
+ path.nms <- names(current.kegglib$path.ids)[match(names(x),current.kegglib$path.ids)];
+ }
+ }
+
+ ## Open plot device
+ # if(format == "png"){
+ # bg = "transparent";
+ # }else{
+ bg="white";
+ # }
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+
+ if(is.na(width)){
+ w <- 7;
+ }else if(width == 0){
+ w <- 7;
+ }else{
+ w <- width;
+ }
+ h <- w;
+
+ mSetObj$imgSet$path.overview<-imgName;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg=bg);
+ op <- par(mar=c(6,5,2,3));
+ plot(x, y, type="n", axes=F, xlab="Pathway Impact", ylab="-log10(p)");
+###########Begin: Added by ZZY on 8/4/21.###############
+ if (labeling==T) {
+ if(mSetObj$analSet$type == "pathora")
+ text(x, y, GetORA.pathNames(mSetObj), pos=3, cex=0.5)
+ if(mSetObj$analSet$type == "pathqea")
+ text(x, y, GetQEA.pathNames(mSetObj), pos=3, cex=0.5)
+ if(mSetObj$analSet$type == "pathinteg")
+ text(x, y, GetIntegResultPathNames(mSetObj), pos=3, cex=0.5)
+ }
+###########End: Added by ZZY on 8/4/21.###############
+ axis(1);
+ axis(2);
+ if(show.grid){
+ grid(col="blue");
+ }
+ symbols(x, y, add = TRUE, inches = F, circles = radi.vec, bg = bg.vec, xpd=T);
+
+ # convert to pixel positions, only for web interaction dpi=72
+ if(dpi == 72){
+ width.px <- height.px <- w*dpi;
+ mSetObj$imgSet$circleInfo <- CalculateCircleInfo(x, y, radi.vec, width.px, height.px, path.nms);
+ }
+ par(op);
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+# Used in higher function
+CalculateCircleInfo <- function(x, y, r, width, height, lbls){
+ jscode <- paste("leftImgWidth = ", width, "\n", "leftImgHeight = ", height, sep="");
+ dot.len <- length(r);
+ for(i in 1:dot.len){
+ xy <- cbind(c(x[i],r[i],0),c(y[i],0,0));
+ xy <- usr2dev(xy,dev.cur());
+ xyrc <- cbind(ceiling(xy[,1]*width),ceiling((1-xy[,2])*height));
+ radius <- abs(xyrc[2,1]-xyrc[3,1]);
+
+ #add code for mouseover locations, basically the annotation info
+ #in this case, the name of the node
+ jscode <- paste(jscode, paste("circleArray.push({xc:", xyrc[1,1], ", yc:", xyrc[1,2],
+ ", r:", radius, ", lb: \"", lbls[i], "\"})", sep=""), sep="\n");
+ }
+ return(jscode);
+}
+
+# Generate json file of selected pathway to visualize using sigma.js
+# Jeff Xia \email{jeff.xia@mcgill.ca}
+# McGill University, Canada
+# License: GNU GPL (>= 2)
+
+GeneratePathwayJSON<-function(mSetObj,pathway.nm){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ smpdb.path <- paste("../../libs/smpdb/", mSetObj$org, ".qs", sep="");
+ current.kegglib <- qs::qread(smpdb.path);
+
+ jsons.path <- paste("../../libs/smpdb/jsons/", mSetObj$org, ".qs", sep="");
+ smpdb.jsons <- qs::qread(jsons.path) # no need to be global!
+
+ if(pathway.nm == "top"){
+ if(mSetObj$analSet$type == "pathora"){
+ pathway.id <- rownames(mSetObj$analSet$ora.mat)[1]
+ } else{
+ pathway.id <- rownames(mSetObj$analSet$qea.mat)[1]
+ }
+ pathway.nm <- names(current.kegglib$path.ids)[which(current.kegglib$path.ids == pathway.id)]
+ } else {
+ pathway.id <- current.kegglib$path.ids[which(names(current.kegglib$path.ids) == pathway.nm)]
+ }
+
+ # Get matched metabolites
+ if(mSetObj$analSet$type == "pathora"){
+ metab.matches <- paste(mSetObj$analSet$ora.hits[[pathway.id]], collapse=",");
+ } else{
+ metab.matches <- paste(mSetObj$analSet$qea.hits[[pathway.id]], collapse=",");
+ }
+
+ title <- paste(pathway.id, ";", pathway.nm, sep="");
+
+ # store json file
+ smpdbpw.nm <- paste("smpdb_pathway_netview", smpdbpw.count, ".json", sep="");
+ smpdbpw.count <<- smpdbpw.count + 1;
+ sink(smpdbpw.nm);
+ cat(jsonlite::toJSON(smpdb.jsons[[pathway.id]], pretty = TRUE));
+ sink();
+
+ smpdbpw.nm <- paste0(smpdbpw.nm, ";", metab.matches, ";", title)
+ return(smpdbpw.nm)
+}
+
+
+##############################################
+##############################################
+########## Utilities for web-server ##########
+##############################################
+##############################################
+
+#'Redraw current graph for zooming or clipping then return a value
+#'@description Redraw current graph for zooming or clipping then return a value
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input the name of the plot
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@param height Input the height of the created plot.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+RerenderMetPAGraph <- function(mSetObj=NA, imgName, width, height, zoom.factor=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ Cairo::Cairo(file=imgName, width=width, height=height,type="png", bg="white");
+ if(mSetObj$analSet$type == "pathinteg"){
+ font.cex <- 0.7*zoom.factor/100;
+ if(font.cex < 0.6){
+ font.cex=0.6;
+ }
+ g <- mSetObj$dataSet$current.kegg$graph;
+ if(is_igraph(g)){
+ g <- upgrade_graph(g);
+ }
+ plotGraph(g,
+ vertex.color=mSetObj$dataSet$current.kegg$bg.color,
+ vertex.frame.color=mSetObj$dataSet$current.kegg$line.color,
+ vertex.label=V(mSetObj$dataSet$current.kegg$graph)$plot_name,
+ vertex.label.cex=font.cex
+ );
+
+ }else{
+ KEGGgraph::plot(mSetObj$imgSet$current.metpa.graph);
+ }
+ dev.off();
+ return(1);
+}
+
+#' Export information about selected circle
+#'@param mSetObj Input name of the created mSet Object
+#'@export
+GetCircleInfo<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$imgSet$circleInfo);
+}
+
+##########Utility Functions########
+
+#'Perform utilities for MetPa
+#'@description Convert user coords (as used in current plot) to pixels in a png
+#'adapted from the imagemap package
+#'@param xy Input coordinates
+#'@param im Input coordinates
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+usr2png <- function(xy, im){
+ xy <- usr2dev(xy,dev.cur())
+ cbind(
+ ceiling(xy[,1]*im$Width),
+ ceiling((1-xy[,2])*im$Height)
+ )
+}
+
+usr2plt <- function(xy, dev=dev.cur()){
+ olddev <- dev.cur()
+ dev.set(dev)
+ usr <- par("usr")
+ dev.set(olddev)
+ xytrans(xy,usr)
+}
+
+plt2fig <- function(xy, dev=dev.cur()){
+ olddev <- dev.cur()
+ dev.set(dev)
+ plt <- par("plt")
+ dev.set(olddev)
+ xytrans2(xy,plt)
+}
+
+fig2dev <- function(xy, dev=dev.cur()){
+ olddev <- dev.cur()
+ dev.set(dev)
+ fig <- par("fig")
+ dev.set(olddev)
+ xytrans2(xy,fig)
+}
+
+usr2dev <- function(xy, dev=dev.cur()){
+ fig2dev(plt2fig(usr2plt(xy,dev),dev),dev)
+}
+
+xytrans2 <- function(xy, par){
+ cbind(par[1]+((par[2]-par[1])*xy[,1]),
+ par[3]+((par[4]-par[3])*xy[,2]))
+}
+
+xytrans <- function(xy, par){
+ cbind((xy[,1]-par[1])/(par[2]-par[1]),
+ (xy[,2]-par[3])/(par[4]-par[3]))
+}
+
+getndp <- function(x, tol=2*.Machine$double.eps){
+ ndp <- 0
+ while(!isTRUE(all.equal(x, round(x, ndp), tol=tol))) ndp <- ndp+1
+ if(ndp > -log10(tol)) {
+ warning("Tolerance reached, ndp possibly underestimated.")
+ }
+ ndp
+}
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/enrich_path_stats.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/enrich_path_stats.R
new file mode 100755
index 0000000000000000000000000000000000000000..5ce86faf7dbc4d4022d0649290a81ed1ce5bd390
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/enrich_path_stats.R
@@ -0,0 +1,858 @@
+### Over-representation analysis using hypergeometric tests
+### The probability is calculated from obtaining the equal or higher number
+### of hits using 1-phyper. Since phyper is a cumulative probability,
+### to get P(X>=hit.num) => P(X>(hit.num-1))
+
+#'Calculate ORA score
+#'@description Calculate the over representation analysis score
+#'@usage CalculateOraScore(mSetObj=NA, nodeImp, method)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param nodeImp Indicate the pathway topology analysis, "rbc" for relative-betweeness centrality,
+#'and "dgr" for out-degree centrality.
+#'@param method is "fisher" or "hyperg"
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+CalculateOraScore1 <- function(mSetObj=NA, nodeImp, method){
+
+ mSetObj <- .get.mSet(mSetObj);
+ # make a clean dataSet$cmpd data based on name mapping
+ # only valid kegg id will be used
+
+ nm.map <- GetFinalNameMap(mSetObj);
+ if(mSetObj$pathwaylibtype == "KEGG"){
+ valid.inx <- !(is.na(nm.map$kegg)| duplicated(nm.map$kegg));
+ ora.vec <- nm.map$kegg[valid.inx];
+ } else if(mSetObj$pathwaylibtype == "SMPDB"){
+ valid.inx <- !(is.na(nm.map$hmdbid)| duplicated(nm.map$hmdbid));
+ ora.vec <- nm.map$hmdbid[valid.inx];
+ }
+ q.size<-length(ora.vec);
+
+ if(q.size==0) { #Removed "|| is.na(ora.vec)" by ZZY on 7/31/24.
+ if(mSetObj$pathwaylibtype == "KEGG"){
+ AddErrMsg("No valid KEGG compounds found!");
+ } else if(mSetObj$pathwaylibtype == "SMPDB"){
+ AddErrMsg("No valid SMPDB compounds found!");
+ }
+ return(0);
+ }
+
+ if(.on.public.web & mSetObj$pathwaylibtype == "KEGG"){ #Removed "!" by ZZY on 7/28/21.
+ mSetObj$api$nodeImp <- nodeImp;
+ mSetObj$api$method <- method;
+ mSetObj$api$oraVec <- ora.vec;
+
+ if(mSetObj$api$filter){
+# mSetObj$api$filterData <- mSetObj$dataSet$metabo.filter.kegg #Change by ZZY on 7/30/21. See below.
+ mSetObj$api$filterData <- mSetObj$dataSet$metabo.filter.hmdb
+
+ toSend <- list(mSet = mSetObj, libVersion = mSetObj$api$libVersion, libNm = mSetObj$api$libNm, filter = mSetObj$api$filter, nodeImp = mSetObj$api$nodeImp,
+ method = mSetObj$api$method, oraVec = mSetObj$api$oraVec, filterData = mSetObj$api$filterData)
+ }else{
+ toSend <- list(mSet = mSetObj, libVersion = mSetObj$api$libVersion, libNm = mSetObj$api$libNm, filter = mSetObj$api$filter, nodeImp = mSetObj$api$nodeImp,
+ method = mSetObj$api$method, oraVec = mSetObj$api$oraVec)
+ }
+# browser() #Disabled by ZZY on 3/16/2021.
+ #json to be sent to server
+ #oraData <- RJSONIO::toJSON(toSend, .na='null')
+ #write(oraData, file="ora_test.JSON")
+ # code to send to server
+ # change path when on server, use local for now
+
+ load_httr()
+ base <- api.base
+ endpoint <- "/pathwayora"
+ call <- paste(base, endpoint, sep="")
+ query_results <- httr::POST(call, body = toSend, encode= "json")
+ query_results_text <- content(query_results, "text")
+ query_results_json <- RJSONIO::fromJSON(query_results_text, flatten = TRUE)
+
+ # parse json response from server to results
+ oraDataRes <- do.call(rbind.data.frame, query_results_json$enrichRes)
+ colnames(oraDataRes) <- query_results_json$enrichResColNms
+ rownames(oraDataRes) <- query_results_json$enrichResRowNms
+
+ fast.write.csv(oraDataRes, file="pathway_results.csv");
+ mSetObj$analSet$ora.mat <- oraDataRes
+ mSetObj$api$guestName <- query_results_json$guestName
+ return(.set.mSet(mSetObj));
+ }
+
+ current.mset <- current.kegglib$mset.list;
+ uniq.count <- current.kegglib$uniq.count;
+
+ # check if need to be filtered against reference metabolome
+ # TODO: address the following filtering for SMPDB if needed
+# if(mSetObj$dataSet$use.metabo.filter && !is.null(mSetObj$dataSet$metabo.filter.kegg)){ #Replaced by ZZY on 7/30/21. See below.
+# current.mset <- lapply(current.mset, function(x){x[x %in% mSetObj$dataSet$metabo.filter.kegg]});
+############Replacement: Begin##############
+ if(mSetObj$dataSet$use.metabo.filter && !is.null(mSetObj$dataSet$metabo.filter.hmdb)){
+ if (mSetObj$pathwaylibtype=="KEGG")
+ current.mset <- lapply(current.mset, function(x){x[doKEGG2NameMapping(x) %in% mSetObj$dataSet$metabo.filter.hmdb]});
+ if (mSetObj$pathwaylibtype=="SMPDB")
+ current.mset <- lapply(current.mset, function(x){x[HMDBID2Name1(x) %in% mSetObj$dataSet$metabo.filter.hmdb]});
+############Replacement: End##############
+ }
+ mSetObj$analSet$ora.filtered.mset <- current.mset;
+ uniq.count <- length(unique(unlist(current.mset, use.names=FALSE)));
+
+ hits <- lapply(current.mset, function(x){x[x %in% ora.vec]});
+ hit.num <-unlist(lapply(hits, function(x){length(x)}), use.names=FALSE);
+ set.size <-length(current.mset);
+ set.num <- unlist(lapply(current.mset, length), use.names=FALSE);
+
+ # deal with no hits
+ if(length(hits)==0){
+ msg.vec <<- c(msg.vec, "No hits in the selected pathway library!")
+ return(0)
+ }
+
+ # prepare for the result table
+ res.mat<-matrix(0, nrow=set.size, ncol=8);
+ rownames(res.mat)<-names(current.mset);
+ colnames(res.mat)<-c("Total", "Expected", "Hits", "Raw p", "-log10(p)", "Holm adjust", "FDR", "Impact");
+
+ if(nodeImp == "rbc"){
+ imp.list <- current.kegglib$rbc;
+ mSetObj$msgSet$topo.msg <- "Your selected node importance measure for topological analysis is \\textbf{relative betweenness centrality}.";
+ }else{
+ imp.list <- current.kegglib$dgr;
+ mSetObj$msgSet$topo.msg <- "Your selected node importance measure for topological analysis is \\textbf{out degree centrality}.";
+ }
+
+ res.mat[,1]<-set.num;
+ res.mat[,2]<-q.size*(set.num/uniq.count);
+ res.mat[,3]<-hit.num;
+
+ if(method == "fisher"){
+ res.mat[,4] <- GetFisherPvalue(hit.num, q.size, set.num, uniq.count);
+ mSetObj$msgSet$rich.msg <- "The selected over-representation analysis method is \\textbf{Fishers' exact test}.";
+ }else{
+ # use lower.tail = F for P(X>x)
+ res.mat[,4] <- phyper(hit.num-1, set.num, uniq.count-set.num, q.size, lower.tail=F);
+ mSetObj$msgSet$rich.msg <- "The selected over-representation analysis method is \\textbf{Hypergeometric test}.";
+ }
+
+ res.mat[,5] <- -log10(res.mat[,4]);
+
+ # adjust for multiple testing problems
+ res.mat[,6] <- p.adjust(res.mat[,4], "holm");
+ res.mat[,7] <- p.adjust(res.mat[,4], "fdr");
+ # calculate the sum of importance
+ res.mat[,8] <- mapply(function(x, y){sum(x[y])}, imp.list, hits);
+
+ res.mat <- res.mat[hit.num>0, , drop=FALSE];
+ res.mat <- res.mat[!is.na(res.mat[,8]), , drop=FALSE];
+
+ if(nrow(res.mat) > 1){
+ ord.inx <- order(res.mat[,4], res.mat[,8]);
+ res.mat <- res.mat[ord.inx,];
+ }
+
+ mSetObj$analSet$ora.mat <- signif(res.mat,5);
+ mSetObj$analSet$ora.hits <- hits;
+ mSetObj$analSet$node.imp <- nodeImp;
+
+ save.mat <- mSetObj$analSet$ora.mat;
+ hit.inx <- match(rownames(save.mat), current.kegglib$path.ids);
+ rownames(save.mat) <- names(current.kegglib$path.ids)[hit.inx];
+ save.mat <- cbind(save.mat,CreateMatchingTable1(mSetObj)) #Added by ZZY on 8/4/21.
+ fast.write.csv(save.mat, file="pathway_results.csv");
+
+ return(.set.mSet(mSetObj));
+}
+
+#'Export pathway names from ORA analysis
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@export
+GetORA.pathNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ hit.inx <- match(rownames(mSetObj$analSet$ora.mat), current.kegglib$path.ids);
+ return(names(current.kegglib$path.ids)[hit.inx]);
+}
+
+#'Calculate quantitative enrichment score
+#'@description Calculate quantitative enrichment score
+#'@usage CalculateQeaScore(mSetObj=NA, nodeImp, method)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param nodeImp Indicate the pathway topology analysis, "rbc" for relative-betweeness centrality,
+#'and "dgr" for out-degree centrality.
+#'@param method Indicate the pathway enrichment analysis, global test is "gt" and global ancova is "ga".
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@import qs
+#'@export
+
+# contains three inner functions to be compatible with microservice
+CalculateQeaScore1 <- function(mSetObj=NA, nodeImp, method){
+
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj <- .prepare.qea.score(mSetObj, nodeImp, method); # on local, everything is done
+
+ if(!.on.public.web){ #Added "!" by ZZY on 7/31/21.
+ .perform.computing();
+ mSetObj <- .save.qea.score(mSetObj);
+ }
+
+ return(.set.mSet(mSetObj));
+}
+
+.prepare.qea.score <- function(mSetObj=NA, nodeImp, method){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # first, need to make a clean dataSet$norm data based on name mapping
+ # only contain valid kegg id will be used
+ nm.map <- GetFinalNameMap(mSetObj);
+
+ if(mSetObj$pathwaylibtype == "KEGG"){
+ valid.inx <- !(is.na(nm.map$kegg)| duplicated(nm.map$kegg));
+ } else if(mSetObj$pathwaylibtype == "SMPDB"){
+ valid.inx <- !(is.na(nm.map$hmdbid)| duplicated(nm.map$hmdbid));
+ }
+
+ nm.map <- nm.map[valid.inx,];
+ orig.nms <- nm.map$query;
+
+ kegg.inx <- match(colnames(mSetObj$dataSet$norm),orig.nms);
+ hit.inx <- !is.na(kegg.inx);
+ path.data<-mSetObj$dataSet$norm[,hit.inx];
+
+ if(mSetObj$pathwaylibtype == "KEGG"){
+ colnames(path.data) <- nm.map$kegg[kegg.inx[hit.inx]];
+ } else if(mSetObj$pathwaylibtype == "SMPDB"){
+ colnames(path.data) <- nm.map$hmdbid[kegg.inx[hit.inx]];
+ }
+
+ # calculate univariate p values when click indivisual compound node
+ # use lm model for t-tests (with var.equal=T), one-way anova, and linear regression (continuous);
+ univ.p <- apply(as.matrix(path.data), 2, function(x) {
+ tmp <- try(lm(as.numeric(mSetObj$dataSet$cls)~x));
+ if(class(tmp) == "try-error") {
+ return(NA);
+ }else{
+ tmp<-anova(tmp)
+ return(tmp[1,5]);
+ }
+ });
+
+ names(univ.p) <- colnames(path.data);
+
+ if(.on.public.web & mSetObj$pathwaylibtype == "KEGG"){ #Removed "!" by ZZY on 7/31/21.
+ mSetObj$api$nodeImp <- nodeImp;
+ mSetObj$api$method <- method;
+ mSetObj$api$pathDataColNms <- colnames(path.data)
+ path.data <- as.matrix(path.data)
+ dimnames(path.data) = NULL
+ mSetObj$api$pathData <- path.data;
+ mSetObj$api$univP <- as.numeric(univ.p);
+ mSetObj$api$cls <- mSetObj$dataSet$cls
+
+ if(mSetObj$api$filter){
+# mSetObj$api$filterData <- mSetObj$dataSet$metabo.filter.kegg #Changed by ZZY on 7/30/21. See below.
+ mSetObj$api$filterData <- mSetObj$dataSet$metabo.filter.hmdb
+
+ toSend <- list(libVersion = mSetObj$api$libVersion, libNm = mSetObj$api$libNm, filter = mSetObj$api$filter, nodeImp = mSetObj$api$nodeImp,
+ method = mSetObj$api$method, pathData = mSetObj$api$pathData, pathDataColNms = mSetObj$api$pathDataColNms,
+ filterData = mSetObj$api$filterData, univP = mSetObj$api$univP, cls = mSetObj$api$cls)
+ }else{
+ toSend <- list(libVersion = mSetObj$api$libVersion, libNm = mSetObj$api$libNm, filter = mSetObj$api$filter, nodeImp = mSetObj$api$nodeImp,
+ method = mSetObj$api$method, pathData = mSetObj$api$pathData, pathDataColNms = mSetObj$api$pathDataColNms,
+ univP = mSetObj$api$univP, cls = mSetObj$api$cls)
+ }
+
+ #json to be sent to server
+ #oraData <- RJSONIO::toJSON(toSend, .na='null')
+ #write(oraData, file="ora_test.JSON")
+ # code to send to server
+ # change path when on server, use local for now
+
+ load_httr()
+ base <- api.base
+ endpoint <- "/pathwayqea"
+ call <- paste(base, endpoint, sep="")
+ query_results <- httr::POST(call, body = toSend, encode= "json")
+ query_results_text <- content(query_results, "text")
+ query_results_json <- RJSONIO::fromJSON(query_results_text, flatten = TRUE)
+
+ if(is.null(query_results_json$enrichRes)){
+ AddErrMsg("Error! Pathway QEA via api.metaboanalyst.ca unsuccessful!")
+ return(0)
+ }
+
+ # parse json response from server to results
+ qeaDataRes <- do.call(rbind.data.frame, query_results_json$enrichRes)
+ colnames(qeaDataRes) <- query_results_json$enrichResColNms
+ rownames(qeaDataRes) <- query_results_json$enrichResRowNms
+
+ fast.write.csv(qeaDataRes, file="pathway_results.csv", row.names=TRUE);
+ mSetObj$analSet$qea.mat <- qeaDataRes
+ mSetObj$api$guestName <- query_results_json$guestName
+ print("Pathway QEA via api.metaboanalyst.ca successful!")
+ return(.set.mSet(mSetObj));
+ }
+
+ # now, perform topology & enrichment analysis
+ current.mset <- current.kegglib$mset.list;
+ uniq.count <- current.kegglib$uniq.count;
+
+ # check if a reference metabolome is applied
+# if(mSetObj$dataSet$use.metabo.filter && !is.null(mSetObj$dataSet[["metabo.filter.kegg"]])){ #Changed by ZZY on 7/30/21. See below.
+# current.mset<-lapply(current.mset, function(x) {x[x %in% mSetObj$dataSet$metabo.filter.kegg]});
+############Replacement: Begin##############
+ if(mSetObj$dataSet$use.metabo.filter && !is.null(mSetObj$dataSet$metabo.filter.hmdb)){
+ if (mSetObj$pathwaylibtype=="KEGG")
+ current.mset <- lapply(current.mset, function(x){x[doKEGG2NameMapping(x) %in% mSetObj$dataSet$metabo.filter.hmdb]});
+ if (mSetObj$pathwaylibtype=="SMPDB")
+ current.mset <- lapply(current.mset, function(x){x[HMDBID2Name1(x) %in% mSetObj$dataSet$metabo.filter.hmdb]});
+ }
+############Replacement: End##############
+ mSetObj$analSet$qea.filtered.mset <- current.mset;
+ uniq.count <- length(unique(unlist(current.mset), use.names=FALSE));
+
+ hits <- lapply(current.mset, function(x) {x[x %in% colnames(path.data)]});
+ hit.inx <- unlist(lapply(hits, function(x) {length(x)}), use.names=FALSE) > 0;
+ hits <- hits[hit.inx]; # remove no hits
+
+ # deal with no hits
+ if(length(hits)==0){
+ msg.vec <<- c(msg.vec, "No hits in the selected pathway library!")
+ return(0)
+ }
+
+ # calculate the impact values
+ if(nodeImp == "rbc"){
+ imp.list <- current.kegglib$rbc[hit.inx];
+ mSetObj$msgSet$topo.msg <- "Your selected node importance measure for topological analysis is \\textbf{relative betweenness centrality}.";
+ }else{
+ imp.list <- current.kegglib$dgr[hit.inx];
+ mSetObj$msgSet$topo.msg <- "Your selected node importance measure for topological analysis is \\textbf{out degree centrality}.";
+ }
+ imp.vec <- mapply(function(x, y){sum(x[y])}, imp.list, hits);
+ set.num<-unlist(lapply(current.mset[hit.inx], length), use.names=FALSE);
+
+ if(method == "gt"){
+ mSetObj$msgSet$rich.msg <- "The selected pathway enrichment analysis method is \\textbf{Globaltest}.";
+ my.fun <- function(){
+ gt.obj <- globaltest::gt(dat.in$cls, dat.in$data, subsets=dat.in$subsets);
+ gt.res <- globaltest::result(gt.obj);
+ return(gt.res[,c(5,1)]);
+ }
+ }else{
+ mSetObj$msgSet$rich.msg <- "The selected pathway enrichment analysis method is \\textbf{GlobalAncova}.";
+ my.fun <- function(){
+ path.data <- dat.in$data;
+ ga.out <- GlobalAncova::GlobalAncova(xx=t(path.data), group=dat.in$cls, test.genes=dat.in$subsets, method="approx");
+ return(ga.out[,c(1,3)]);
+ }
+ }
+
+ dat.in <- list(cls=mSetObj$dataSet$cls, data=path.data, subsets=hits, my.fun=my.fun);
+ qs::qsave(dat.in, file="dat.in.qs");
+
+ # store data before microservice
+ mSetObj$analSet$qea.univp <- signif(univ.p,7);
+ mSetObj$analSet$node.imp <- nodeImp;
+ mSetObj$dataSet$norm.path <- path.data;
+ mSetObj$analSet$qea.hits <- hits;
+ mSetObj$analSet$imp.vec <- imp.vec;
+ mSetObj$analSet$set.num <- set.num;
+
+ return(.set.mSet(mSetObj));
+}
+
+.save.qea.score <- function(mSetObj = NA){
+ mSetObj <- .get.mSet(mSetObj);
+ dat.in <- qs::qread("dat.in.qs");
+ qea.res <- dat.in$my.res;
+ set.num <- mSetObj$analSet$set.num;
+ imp.vec <- mSetObj$analSet$imp.vec;
+
+ match.num <- qea.res[,1];
+ raw.p <- qea.res[,2];
+
+ log.p <- -log10(raw.p);
+ # add adjust p values
+ holm.p <- p.adjust(raw.p, "holm");
+ fdr.p <- p.adjust(raw.p, "fdr");
+
+ res.mat <- cbind(set.num, match.num, raw.p, log.p, holm.p, fdr.p, imp.vec);
+ rownames(res.mat)<-rownames(qea.res);
+ colnames(res.mat)<-c("Total Cmpd", "Hits", "Raw p", "-log10(p)", "Holm adjust", "FDR", "Impact");
+ res.mat <- res.mat[!is.na(res.mat[,7]), , drop=FALSE];
+
+ ord.inx<-order(res.mat[,3], -res.mat[,7]);
+ res.mat<-signif(res.mat[ord.inx,],5);
+ mSetObj$analSet$qea.mat <- res.mat;
+
+ hit.inx <- match(rownames(res.mat), current.kegglib$path.ids);
+ pathNames <- names(current.kegglib$path.ids)[hit.inx];
+ rownames(res.mat) <- pathNames; # change from ids to names for users
+ res.mat <- cbind(res.mat,CreateMatchingTable1(mSetObj)) #Added by ZZY on 8/4/21.
+ fast.write.csv(res.mat, file="pathway_results.csv");
+
+ mSetObj$analSet$qea.pathNames <- pathNames;
+ return(.set.mSet(mSetObj));
+}
+
+#'Export pathway names from QEA analysis
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@export
+GetQEA.pathNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$analSet$qea.pathNames);
+}
+
+#'Only works for human (hsa.rda) data
+#'@description Only works for human (hsa.rda) data
+#'2018 - works for ath, eco, mmu, sce
+#'@param kegg.ids Input the list of KEGG ids to add SMPDB links
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+SetupSMPDBLinks <- function(kegg.ids){
+ smpdb.vec <- names(current.kegglib$path.smps)[match(kegg.ids,current.kegglib$path.smps)]
+ lk.len <- length(smpdb.vec);
+ all.lks <- vector(mode="character", length=lk.len);
+ for(i in 1:lk.len){
+ lks <- strsplit(as.character(smpdb.vec[i]), "; ", fixed=TRUE)[[1]];
+ if(!is.na(lks[1])){
+ all.lks[i]<-paste("<a href=http://www.smpdb.ca/view/",lks," target=_new>SMP</a>", sep="", collapse="\n");
+ }
+ }
+ return(all.lks);
+}
+
+#'Only works for human (hsa.rda) data
+#'@description Only works for human (hsa.rda) data
+#'2018 - works for ath, eco, mmu, sce
+#'@param kegg.ids Input the list of KEGG ids to add SMPDB links
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+SetupKEGGLinks <- function(smpdb.ids){
+ kegg.vec <- current.kegglib$path.keggs[match(smpdb.ids,names(current.kegglib$mset.list))]
+ lk.len <- length(kegg.vec);
+ all.lks <- vector(mode="character", length=lk.len);
+ for(i in 1:lk.len){
+ lks <- strsplit(kegg.vec[i], "; ", fixed=TRUE)[[1]];
+ if(!is.na(lks[1])){
+ all.lks[i] <- paste("<a href=http://www.genome.jp/kegg-bin/show_pathway?",lks," target=_new>KEGG</a>", sep="");
+ # all.lks[i]<-paste("<a href=http://pathman.smpdb.ca/pathways/",lks,"/pathway target=_new>SMP</a>", sep="", collapse="\n");
+ }
+ }
+ return(all.lks);
+}
+
+##############################################
+##############################################
+########## Utilities for web-server ##########
+##############################################
+##############################################
+
+#'Given a metset inx, return hmtl highlighted pathway cmpds
+#'@description Given a metset inx, return hmtl highlighted pathway cmpds
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param msetNm Input the name of the metabolite set
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+GetHTMLPathSet <- function(mSetObj=NA, msetNm){
+ mSetObj <- .get.mSet(mSetObj);
+ pathid <- current.kegglib$path.ids[msetNm];
+ mset <- current.kegglib$mset.list[[pathid]];
+ hits <- NULL;
+ if(mSetObj$analSet$type=="pathora"){
+ hits <- mSetObj$analSet$ora.hits;
+ }else{
+ hits <- mSetObj$analSet$qea.hits;
+ }
+
+ # highlighting with different colors
+ red.inx <- which(mset %in% hits[[pathid]]);
+
+ # use actual cmpd names
+ nms <- names(mset);
+ nms[red.inx] <- paste("<font color=\"red\">", "<b>", nms[red.inx], "</b>", "</font>",sep="");
+ return(cbind(msetNm, paste(unique(nms), collapse="; ")));
+}
+
+GetORA.keggIDs <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ if(mSetObj$pathwaylibtype == "KEGG"){
+ kegg.vec <- rownames(mSetObj$analSet$ora.mat);
+ kegg.vec <- paste("<a href=http://www.genome.jp/kegg-bin/show_pathway?",kegg.vec," target=_new>KEGG</a>", sep="");
+ } else{ # pathwaylibtype == "HMDB"
+ return(SetupKEGGLinks(rownames(mSetObj$analSet$ora.mat)));
+ }
+ return(kegg.vec);
+}
+
+#'Only for human pathways (SMPDB)
+#'@description Only for human pathways + ath, eco, mmu & sce
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+GetORA.smpdbIDs <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ if(mSetObj$pathwaylibtype == "KEGG"){
+ return(SetupSMPDBLinks(rownames(mSetObj$analSet$ora.mat)));
+ } else{
+ hmdb.vec <- rownames(mSetObj$analSet$ora.mat);
+ all.lks <-paste("<a href=http://www.smpdb.ca/view/",hmdb.vec," target=_new>SMP</a>", sep="");
+ return(all.lks)
+ }
+}
+
+#'Only for human pathways (KEGG)
+#'@description Only for human pathways + ath, eco, mmu & sce
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+GetQEA.keggIDs <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ if(mSetObj$pathwaylibtype == "KEGG"){
+ kegg.vec <- rownames(mSetObj$analSet$qea.mat);
+ kegg.vec <- paste("<a href=http://www.genome.jp/kegg-bin/show_pathway?",kegg.vec," target=_new>KEGG</a>", sep="");
+ } else{ # pathwaylibtype == "HMDB"
+ return(SetupKEGGLinks(rownames(mSetObj$analSet$qea.mat)));
+ }
+ return(kegg.vec);
+}
+
+GetQEA.smpdbIDs <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ if(mSetObj$pathwaylibtype == "KEGG"){
+ return(SetupSMPDBLinks(rownames(mSetObj$analSet$qea.mat)));
+ } else{
+ hmdb.vec <- rownames(mSetObj$analSet$qea.mat);
+ all.lks <-paste("<a href=http://www.smpdb.ca/view/",hmdb.vec," target=_new>SMP</a>", sep="");
+ return(all.lks)
+ }
+}
+
+
+ComputePathHeatmapTable <- function(mSetObj=NA, libOpt, fileNm){
+
+ mSetObj <- .get.mSet(mSetObj);
+ dataSet <- mSetObj$dataSet;
+ data <- t(dataSet$norm)
+ sig.ids <- rownames(data);
+
+ res <- PerformFastUnivTests(mSetObj$dataSet$norm, mSetObj$dataSet$cls);
+
+ stat.pvals <- unname(as.vector(res[,2]));
+ t.stat <- unname(as.vector(res[,1]));
+ org <- unname(strsplit(libOpt,"_")[[1]][1])
+ mSetObj$org <- org
+ # scale each gene
+ dat <- t(scale(t(data)));
+
+ rankPval = order(as.vector(stat.pvals))
+ stat.pvals = stat.pvals[rankPval]
+ dat = dat[rankPval,]
+
+ t.stat = t.stat[rankPval]
+
+ # now pearson and euclidean will be the same after scaleing
+ dat.dist <- dist(dat);
+
+ orig.smpl.nms <- colnames(dat);
+ orig.gene.nms <- rownames(dat);
+
+ # do clustering and save cluster info
+ # convert order to rank (score that can used to sort)
+ if(nrow(dat)> 1){
+ dat.dist <- dist(dat);
+ gene.ward.ord <- hclust(dat.dist, "ward.D")$order;
+ gene.ward.rk <- match(orig.gene.nms, orig.gene.nms[gene.ward.ord]);
+ gene.ave.ord <- hclust(dat.dist, "ave")$order;
+ gene.ave.rk <- match(orig.gene.nms, orig.gene.nms[gene.ave.ord]);
+ gene.single.ord <- hclust(dat.dist, "single")$order;
+ gene.single.rk <- match(orig.gene.nms, orig.gene.nms[gene.single.ord]);
+ gene.complete.ord <- hclust(dat.dist, "complete")$order;
+ gene.complete.rk <- match(orig.gene.nms, orig.gene.nms[gene.complete.ord]);
+
+ dat.dist <- dist(t(dat));
+ smpl.ward.ord <- hclust(dat.dist, "ward.D")$order;
+ smpl.ward.rk <- match(orig.smpl.nms, orig.smpl.nms[smpl.ward.ord])
+ smpl.ave.ord <- hclust(dat.dist, "ave")$order;
+ smpl.ave.rk <- match(orig.smpl.nms, orig.smpl.nms[smpl.ave.ord])
+ smpl.single.ord <- hclust(dat.dist, "single")$order;
+ smpl.single.rk <- match(orig.smpl.nms, orig.smpl.nms[smpl.single.ord])
+ smpl.complete.ord <- hclust(dat.dist, "complete")$order;
+ smpl.complete.rk <- match(orig.smpl.nms, orig.smpl.nms[smpl.complete.ord])
+ }else{
+ # force not to be single element vector which will be scaler
+ #stat.pvals <- matrix(stat.pvals);
+ gene.ward.rk <- gene.ave.rk <- gene.single.rk <- gene.complete.rk <- matrix(1);
+ smpl.ward.rk <- smpl.ave.rk <- smpl.single.rk <- smpl.complete.rk <- 1:ncol(dat);
+ }
+
+ gene.cluster <- list(
+ ward = gene.ward.rk,
+ average = gene.ave.rk,
+ single = gene.single.rk,
+ complete = gene.complete.rk,
+ pval = stat.pvals,
+ stat = t.stat
+ );
+
+ sample.cluster <- list(
+ ward = smpl.ward.rk,
+ average = smpl.ave.rk,
+ single = smpl.single.rk,
+ complete = smpl.complete.rk
+ );
+
+ # prepare meta info
+ # 1) convert meta.data info numbers
+ # 2) match number to string (factor level)
+ meta <- data.frame(dataSet$cls);
+ grps <- "Condition"
+ nmeta <- meta.vec <- NULL;
+ uniq.num <- 0;
+ for (i in 1:ncol(meta)){
+ cls <- meta[,i];
+ grp.nm <- grps[i];
+ meta.vec <- c(meta.vec, as.character(cls))
+ # make sure each label are unqiue across multiple meta data
+ ncls <- paste(grp.nm, as.numeric(cls)); # note, here to retain ordered factor
+ nmeta <- c(nmeta, ncls);
+ }
+
+ # convert back to numeric
+ nmeta <- as.numeric(as.factor(nmeta))+99;
+ unik.inx <- !duplicated(nmeta)
+
+ # get corresponding names
+ meta_anot <- meta.vec[unik.inx];
+ names(meta_anot) <- nmeta[unik.inx]; # name annotatation by their numbers
+
+ nmeta <- matrix(nmeta, ncol=ncol(meta), byrow=F);
+ colnames(nmeta) <- grps;
+
+ # for each gene/row, first normalize and then tranform real values to 30 breaks
+ res <- t(apply(dat, 1, function(x){as.numeric(cut(x, breaks=30))}));
+
+ # note, use {} will lose order; use [[],[]] to retain the order
+
+ gene.id = orig.gene.nms; if(length(gene.id) ==1) { gene.id <- matrix(gene.id) };
+ json.res <- list(
+ data.type = dataSet$type,
+ gene.id = gene.id,
+ gene.entrez = gene.id,
+ gene.name = gene.id,
+ gene.cluster = gene.cluster,
+ sample.cluster = sample.cluster,
+ sample.names = orig.smpl.nms,
+ meta = data.frame(nmeta),
+ meta.anot = meta_anot,
+ data = res,
+ org = org
+ );
+
+ mSetObj$dataSet$hm_peak_names = gene.id
+ mSetObj$dataSet$gene.cluster = gene.cluster
+
+ .set.mSet(mSetObj)
+ require(RJSONIO);
+ json.mat <- toJSON(json.res, .na='null');
+ sink(fileNm);
+ cat(json.mat);
+ sink();
+ current.msg <<- "Data is now ready for heatmap visualization!";
+ return(1);
+}
+
+ComputePathHeatmap <-function(mSetObj=NA, libOpt, fileNm, type){
+ if(type == "pathqea"){
+ return(ComputePathHeatmapTable(mSetObj, libOpt, fileNm));
+ }else{
+ return(ComputePathHeatmapList(mSetObj, libOpt, fileNm));
+ }
+}
+
+ComputePathHeatmapList <- function(mSetObj=NA, libOpt, fileNm){
+
+ mSetObj <- .get.mSet(mSetObj);
+ # make a clean dataSet$cmpd data based on name mapping
+ # only valid kegg id will be used
+
+ nm.map <- GetFinalNameMap(mSetObj);
+ if(mSetObj$pathwaylibtype == "KEGG"){
+ valid.inx <- !(is.na(nm.map$kegg)| duplicated(nm.map$kegg));
+ ora.vec <- mSetObj$dataSet$cmpd[valid.inx];
+ } else if(mSetObj$pathwaylibtype == "SMPDB"){
+ valid.inx <- !(is.na(nm.map$hmdbid)| duplicated(nm.map$hmdbid));
+ ora.vec <- mSetObj$dataSet$cmpd[valid.inx];
+ }
+
+ exp.vec <- rep(0, length(ora.vec));
+ dataSet <- mSetObj$dataSet
+ dataSet$prot.mat <- data.frame(datalist1=exp.vec)
+ rownames(dataSet$prot.mat) <- ora.vec
+
+ sig.ids <- rownames(dataSet$prot.mat);
+ gene.symbols=sig.ids
+ stat.pvals <- dataSet$prot.mat[,1]
+
+ expval <- 0
+ expval <- sum(dataSet$prot.mat)
+
+ # scale each gene
+ dat <- dataSet$prot.mat
+
+ # now pearson and euclidean will be the same after scaleing
+ dat.dist <- dist(dat);
+
+ orig.smpl.nms <- colnames(dat);
+ orig.gene.nms <- rownames(dat);
+
+ # prepare meta info
+ # 1) convert meta.data info numbers
+ # 2) match number to string (factor level)
+
+ grps <- "datalist1"
+ cls <- "datalist1"
+
+ # convert back to numeric
+
+ # for each gene/row, first normalize and then tranform real values to 30 breaks
+ if(expval !=0){
+ dat_pos <- as.matrix(dat[sign(dat[,1]) == 1,])
+ dat_neg <- as.matrix(dat[sign(dat[,1]) == -1,])
+ if(nrow(dat_pos) == 0){
+ res <- apply(unname(dat), 2, function(x){
+ y =log(abs(x)) + 0.000001
+ 16-as.numeric(cut(y, breaks=15))
+ });
+ }else if(nrow(dat_neg) == 0){
+ res <- apply(unname(dat), 2, function(x){
+ y =log(x) + 0.000001
+ 15+as.numeric(cut(y, breaks=15))
+ });
+ }else{
+ res_pos <- apply(unname(dat_pos), 2, function(x){
+ y =log(x) + 0.000001
+ as.numeric(cut(y, breaks=15))+15
+ });
+ res_neg <- apply(unname(dat_neg), 2, function(x){
+ y =log(abs(x)) + 0.000001
+ 16 - as.numeric(cut(y, breaks=15))
+ });
+ res <- rbind(res_pos, res_neg);
+ }
+ }else{
+ zero.inx <- dataSet$prot.mat == 0
+ res <- dataSet$prot.mat;
+ res[zero.inx] <- 31
+ }
+
+ res_list <- list()
+ for(i in 1:nrow(res)){
+ res_list[[i]] <- unname(list(res[i,1]))
+ }
+
+ # note, use {} will lose order; use [[],[]] to retain the order
+
+ nmeta <- list(100)
+ nmeta.anot <- list()
+
+ nmeta.anot["datalist1"] <- nmeta[1]
+
+ nmeta <- list(nmeta)
+ names(nmeta) <- "datalists"
+
+ org <- unname(strsplit(libOpt,"_")[[1]][1])
+ mSetObj$org <- org
+ json.res <- list(
+ data.type = "singlelist",
+ gene.id = gene.symbols,
+ gene.entrez = sig.ids,
+ gene.name = gene.symbols,
+ gene.cluster = 1,
+ sample.cluster = 1,
+ sample.names = list("datalist1"),
+ meta = nmeta,
+ meta.anot = nmeta.anot,
+ data = res_list,
+ expval = expval,
+ org = org
+ );
+
+ .set.mSet(mSetObj)
+ require(RJSONIO);
+ json.mat <- toJSON(json.res, .na='null');
+ sink(fileNm);
+ cat(json.mat);
+ sink();
+ current.msg <<- "Data is now ready for heatmap visualization!";
+ return(1);
+}
+
+#############Begin: Added by ZZY on 8/2/21##################
+CreateMatchingTable1 <- function(mSetObj){ #Copied and modified from CreateIntegMatchingTable1() in enrich_integ.R.
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(.on.public.web){ #Not applicable.
+ return(.set.mSet(mSetObj));
+ }
+ if (anal.type == "msetora") {
+ results <- mSetObj$analSet$ora.mat
+ match_paths <- rownames(results)
+ ms.list <- mSetObj$dataSet$filtered.mset[match_paths]
+ libname <- mSetObj$analSet$msetlibname
+ } else if (anal.type == "msetqea") {
+ results <- mSetObj$analSet$qea.mat
+ match_paths <- rownames(results)
+ ms.list <- mSetObj$dataSet$filtered.mset[match_paths]
+ libname <- mSetObj$analSet$msetlibname
+ } else if (anal.type == "pathora") {
+ results <- mSetObj$analSet$ora.mat
+ match_paths <- rownames(results)
+ ms.list <- mSetObj$analSet$ora.filtered.mset[match_paths]
+ libname <- mSetObj$pathwaylibtype
+ } else if (anal.type == "pathqea") {
+ results <- mSetObj$analSet$qea.mat
+ match_paths <- rownames(results)
+ ms.list <- mSetObj$analSet$qea.filtered.mset[match_paths]
+ libname <- mSetObj$pathwaylibtype
+ }
+
+ if (libname == "KEGG" || libname == "kegg_pathway") {
+ ora.vec <- mSetObj$dataSet$map.table[,"KEGG"]
+ } else {
+ ora.vec <- mSetObj$dataSet$map.table[,"HMDB"]
+ }
+ ora.vec.names <- mSetObj$dataSet$map.table[,"Match"]
+ names(ora.vec.names) <- ora.vec
+ if (anal.type == "msetora" || anal.type == "msetqea") {
+ overlap.results <- lapply(ms.list, function(overlap) {vec <- intersect(overlap, ora.vec.names); return(paste0(vec, collapse="; "))})
+ } else if (anal.type == "pathora" || anal.type == "pathqea") {
+ overlap.results <- lapply(ms.list, function(overlap) {vec <- intersect(overlap, ora.vec); return(paste0(ora.vec.names[vec], collapse="; "))})
+ }
+
+ res <- data.frame(matrix(unlist(overlap.results), nrow=length(overlap.results), byrow=T), stringsAsFactors=FALSE)
+# rownames(res) <- names(current.kegglib$path.ids)[match(match_paths, current.kegglib$path.ids)]
+ colnames(res) <- "matched_features"
+# fast.write.csv(res, "matched_features.csv", row.names = T)
+
+ return(res);
+}
+#############End: Added by ZZY on 8/2/21##################
+
+
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/enrich_stats.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/enrich_stats.R
new file mode 100755
index 0000000000000000000000000000000000000000..b59f57fe3a96b1c33a764b0c2f15431305db8785
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/enrich_stats.R
@@ -0,0 +1,775 @@
+### Various enrichment analysis algorithms
+### Jeff Xia \email{jeff.xia@mcgill.ca}
+### McGill University, Canada
+### License: GNU GPL (>= 2)
+
+#'Over-representation analysis using hypergeometric tests
+#'@description Over-representation analysis using hypergeometric tests
+#'The probability is calculated from obtaining equal or higher number
+#'of hits using 1-phyper. Since phyper is a cumulative probability,
+#'to get P(X>=hit.num) => P(X>(hit.num-1))
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+CalculateHyperScore1 <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # make a clean dataSet$cmpd data based on name mapping
+ # only valid hmdb name will be used
+ nm.map <- GetFinalNameMap(mSetObj);
+ valid.inx <- !(is.na(nm.map$hmdb)| duplicated(nm.map$hmdb));
+ ora.vec <- nm.map$hmdb[valid.inx];
+
+ q.size<-length(ora.vec);
+
+ if(q.size==0) { #Removed "|| is.na(ora.vec)" by ZZY on 7/31/24.
+ AddErrMsg("No valid HMDB compound names found!");
+ return(0);
+ }
+
+ # move to api only if R package + KEGG msets
+# if(!.on.public.web & grepl("kegg", mSetObj$analSet$msetlibname)){
+#The above line was changed to the following line by ZZY on 3/5/2021.
+ if(.on.public.web){
+
+ mSetObj$api$oraVec <- ora.vec;
+
+ if(mSetObj$api$filter){
+ mSetObj$api$filterData <- mSetObj$dataSet$metabo.filter.kegg
+ toSend <- list(libNm = mSetObj$api$libname, filter = mSetObj$api$filter, oraVec = mSetObj$api$oraVec, filterData = mSetObj$api$filterData,
+ excludeNum = mSetObj$api$excludeNum)
+ }else{
+ toSend <- list(libNm = mSetObj$api$libname, filter = mSetObj$api$filter, oraVec = mSetObj$api$oraVec, excludeNum = mSetObj$api$excludeNum)
+ }
+
+ #json to be sent to server
+ #oraData <- RJSONIO::toJSON(toSend, .na='null')
+ #write(oraData, file="ora_test.JSON")
+ # code to send to server
+ # change path when on server, use local for now
+ load_httr()
+ base <- api.base
+ endpoint <- "/enrichmentora"
+ call <- paste(base, endpoint, sep="")
+ query_results <- httr::POST(call, body = toSend, encode= "json")
+ query_results_text <- content(query_results, "text")
+ query_results_json <- RJSONIO::fromJSON(query_results_text, flatten = TRUE)
+
+ if(is.null(query_results_json$enrichRes)){
+ AddErrMsg("Error! Enrichment ORA via api.metaboanalyst.ca unsuccessful!")
+ return(0)
+ }
+ # parse json response from server to results
+ oraDataRes <- do.call(rbind.data.frame, query_results_json$enrichRes)
+ colnames(oraDataRes) <- query_results_json$enrichResColNms
+ rownames(oraDataRes) <- query_results_json$enrichResRowNms
+ fast.write.csv(oraDataRes, file="msea_ora_result.csv");
+ mSetObj$analSet$ora.mat <- oraDataRes
+ mSetObj$api$guestName <- query_results_json$guestName
+ return(.set.mSet(mSetObj));
+ }
+
+ current.mset <- current.msetlib$member
+
+ # make a clean metabilite set based on reference metabolome filtering
+ # also need to update ora.vec to the updated mset
+ if(mSetObj$dataSet$use.metabo.filter && !is.null(mSetObj$dataSet$metabo.filter.hmdb)){
+ current.mset <- lapply(current.mset, function(x){x[x %in% mSetObj$dataSet$metabo.filter.hmdb]})
+# mSetObj$dataSet$filtered.mset <- current.mset; #Moved by ZZY on 8/5/21. See below.
+ ora.vec <- ora.vec[ora.vec %in% unique(unlist(current.mset, use.names = FALSE))]
+ q.size <- length(ora.vec);
+ }
+ mSetObj$dataSet$filtered.mset <- current.mset; #Moved by ZZY on 8/5/21.
+
+
+ # total uniq cmpds in the current mset lib
+ uniq.count <- length(unique(unlist(current.mset, use.names = FALSE)));
+
+#############Added by ZZY on 7/30/21: Begin#################
+ if(uniq.count < q.size){
+ AddErrMsg("Cannot perform enrichment analysis because the number of metabolites exceeds the DB size!");
+ return(NULL);
+ }
+#############Added by ZZY on 7/30/21: End#################
+
+ set.size<-length(current.mset);
+
+ if(set.size ==1){
+ AddErrMsg("Cannot perform enrichment analysis on a single metabolite set!");
+ return(0);
+ }
+
+ hits<-lapply(current.mset, function(x){x[x %in% ora.vec]});
+ # lapply(current.mset, function(x) grepl("Ammonia", x))
+ #hits<-lapply(current.mset, function(x) grepl(paste(ora.vec, collapse = "|"), x))
+
+ hit.num<-unlist(lapply(hits, function(x) length(x)), use.names = FALSE);
+
+ if(sum(hit.num>0)==0){
+ AddErrMsg("No match was found to the selected metabolite set library!");
+ return(0);
+ }
+
+ set.num<-unlist(lapply(current.mset, length), use.names = FALSE);
+
+ # prepare for the result table
+ res.mat<-matrix(NA, nrow=set.size, ncol=6);
+ rownames(res.mat)<-names(current.mset);
+ colnames(res.mat)<-c("total", "expected", "hits", "Raw p", "Holm p", "FDR");
+ for(i in 1:set.size){
+ res.mat[i,1]<-set.num[i];
+ res.mat[i,2]<-q.size*(set.num[i]/uniq.count);
+ res.mat[i,3]<-hit.num[i];
+
+ # use lower.tail = F for P(X>x)
+ # phyper("# of white balls drawn", "# of white balls in the urn", "# of black balls in the urn", "# of balls drawn")
+ res.mat[i,4]<-phyper(hit.num[i]-1, set.num[i], uniq.count-set.num[i], q.size, lower.tail=F);
+ }
+
+ # adjust for multiple testing problems
+ res.mat[,5] <- p.adjust(res.mat[,4], "holm");
+ res.mat[,6] <- p.adjust(res.mat[,4], "fdr");
+
+ res.mat <- res.mat[hit.num>0,];
+
+ ord.inx<-order(res.mat[,4]);
+ mSetObj$analSet$ora.mat <- signif(res.mat[ord.inx,],3);
+ mSetObj$analSet$ora.hits <- hits;
+ mSetObj$analSet$ora.mat <- cbind(mSetObj$analSet$ora.mat, CreateMatchingTable1(mSetObj)) #Added by ZZY on 8/5/21.
+ fast.write.csv(mSetObj$analSet$ora.mat, file="msea_ora_result.csv");
+ return(.set.mSet(mSetObj));
+}
+
+#'Quantitative enrichment analysis with globaltest
+#'@description Various enrichment analysis algorithms
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+CalculateGlobalTestScore1 <- function(mSetObj=NA){
+# browser() #Disabled by ZZY on 3/16/2021.
+ mSetObj <- .get.mSet(mSetObj);
+ if(.on.public.web){
+ .prepare.globaltest.score(mSetObj);
+ .perform.computing();
+ .save.globaltest.score(mSetObj);
+ return(.set.mSet(mSetObj));
+ }else{
+ mSetObj <- .prepare.globaltest.score(mSetObj);
+ .perform.computing();
+ mSetObj <- .save.globaltest.score(mSetObj);
+ }
+
+ return(.set.mSet(mSetObj));
+}
+
+.prepare.globaltest.score <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+ # now, need to make a clean dataSet$norm data based on name mapping
+ # only contain valid hmdb hit will be used
+ nm.map <- GetFinalNameMap(mSetObj);
+ valid.inx <- !(is.na(nm.map$hmdb)| duplicated(nm.map$hmdb));
+ nm.map <- nm.map[valid.inx,];
+ orig.nms <- nm.map$query;
+
+ hmdb.inx <- match(colnames(mSetObj$dataSet$norm),orig.nms);
+ hit.inx <- !is.na(hmdb.inx);
+ msea.data <- mSetObj$dataSet$norm[,hit.inx];
+ colnames(msea.data) <- nm.map$hmdb[hmdb.inx[hit.inx]];
+
+# if(!.on.public.web & grepl("kegg", mSetObj$analSet$msetlibname)){
+#The above line was changed to the following line by ZZY on 3/12/2021.
+ if(.on.public.web){
+ mSetObj$api$mseaDataColNms <- colnames(msea.data)
+ msea.data <- as.matrix(msea.data)
+ dimnames(msea.data) = NULL
+ mSetObj$api$mseaData <- msea.data;
+ mSetObj$api$cls <- mSetObj$dataSet$cls
+
+ if(mSetObj$api$filter){
+ mSetObj$api$filterData <- mSetObj$dataSet$metabo.filter.hmdb
+
+ toSend <- list(libNm = mSetObj$api$libname, filter = mSetObj$api$filter, mseaData = mSetObj$api$mseaData, mseaDataColNms = mSetObj$api$mseaDataColNms,
+ filterData = mSetObj$api$filterData, cls = mSetObj$api$cls, excludeNum = mSetObj$api$excludeNum)
+ }else{
+ toSend <- list(libNm = mSetObj$api$libname, filter = mSetObj$api$filter, mseaData = mSetObj$api$mseaData, mseaDataColNms = mSetObj$api$mseaDataColNms,
+ cls = mSetObj$api$cls, excludeNum = mSetObj$api$excludeNum)
+ }
+
+ #json to be sent to server
+ #oraData <- RJSONIO::toJSON(toSend, .na='null')
+ #write(oraData, file="ora_test.JSON")
+ # code to send to server
+ # change path when on server, use local for now
+
+ load_httr()
+ base <- api.base
+ endpoint <- "/enrichmentqea"
+ call <- paste(base, endpoint, sep="")
+ query_results <- httr::POST(call, body = toSend, encode= "json")
+ query_results_text <- content(query_results, "text")
+ query_results_json <- RJSONIO::fromJSON(query_results_text, flatten = TRUE)
+
+ if(is.null(query_results_json$enrichRes)){
+ AddErrMsg("Error! Pathway QEA via api.metaboanalyst.ca unsuccessful!")
+ return(0)
+ }
+
+ # parse json response from server to results
+ qeaDataRes <- do.call(rbind.data.frame, query_results_json$enrichRes)
+ colnames(qeaDataRes) <- query_results_json$enrichResColNms
+ rownames(qeaDataRes) <- query_results_json$enrichResRowNms
+
+ fast.write.csv(qeaDataRes, file="msea_qea_result.csv");
+ mSetObj$analSet$qea.mat <- qeaDataRes
+ mSetObj$api$guestName <- query_results_json$guestName
+ print("Enrichment QEA via api.metaboanalyst.ca successful!")
+ return(.set.mSet(mSetObj));
+ }
+
+ # now, perform the enrichment analysis
+ set.size <- length(current.msetlib);
+
+ if(set.size == 1){
+ AddErrMsg("Cannot perform enrichment analysis on a single metabolite sets!");
+ return(0);
+ }
+
+ current.mset <- current.msetlib$member;
+
+ # make a clean metabolite set based on reference metabolome filtering
+# if(mSetObj$dataSet$use.metabo.filter && !is.null('mSetObj$dataSet$metabo.filter.hmdb')){ #Changed by ZZY on 7/30/21. See below.
+ if(mSetObj$dataSet$use.metabo.filter && !is.null(mSetObj$dataSet$metabo.filter.hmdb)){
+ current.mset <- lapply(current.msetlib$member, function(x){x[x %in% mSetObj$dataSet$metabo.filter.hmdb]})
+# mSetObj$dataSet$filtered.mset <- current.mset; #Moved by ZZY on 8/5/21. See below.
+ }
+ mSetObj$dataSet$filtered.mset <- current.mset; #Moved by ZZY on 8/5/21.
+
+ set.num <- unlist(lapply(current.mset, length), use.names = FALSE);
+
+ # first, get the matched entries from current.mset
+ hits <- lapply(current.mset, function(x){x[x %in% colnames(msea.data)]});
+ phenotype <- mSetObj$dataSet$cls;
+
+ # there are more steps, better drop a function to compute in the remote env.
+ my.fun <- function(){
+ gt.obj <- globaltest::gt(dat.in$cls, dat.in$data, subsets=dat.in$subsets);
+ gt.res <- globaltest::result(gt.obj);
+
+ match.num <- gt.res[,5];
+ if(sum(match.num>0)==0){
+ return(NA);
+ }
+ all.cmpds <- unlist(gt.obj@subsets, recursive = TRUE, use.names = FALSE);
+ all.cmpds <- unique(all.cmpds);
+ stat.mat <- matrix(0, length(all.cmpds), 5);
+ colnames(stat.mat) <- c("p", "S", "ES", "sdS", "ncov")
+ rownames(stat.mat) <- all.cmpds
+ for(i in 1:length(all.cmpds)){
+ stat.mat[i,] <- gt.obj@functions$test(all.cmpds[i]);
+ }
+ return(list(gt.res=gt.res, pvals=stat.mat[,1]));
+ }
+
+ dat.in <- list(cls=phenotype, data=msea.data, subsets=hits, my.fun=my.fun);
+ qs::qsave(dat.in, file="dat.in.qs");
+
+ # store necessary data
+ mSetObj$analSet$set.num <- set.num;
+ mSetObj$analSet$qea.hits <- hits;
+ mSetObj$analSet$msea.data <- msea.data;
+ return(.set.mSet(mSetObj));
+}
+
+.save.globaltest.score <- function(mSetObj = NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+ dat.in <- qs::qread("dat.in.qs");
+ my.res <- dat.in$my.res;
+ set.num <- mSetObj$analSet$set.num;
+
+ if(length(my.res)==1 && is.na(my.res)){
+ AddErrMsg("No match was found to the selected metabolite set library!");
+ return(0);
+ }
+
+ mSetObj$analSet$qea.pvals <- my.res$pvals; # p value for individual cmpds
+ gt.res <- my.res$gt.res;
+
+ raw.p <- gt.res[,1];
+ # add adjust p values
+ bonf.p <- p.adjust(raw.p, "holm");
+ fdr.p <- p.adjust(raw.p, "fdr");
+
+ res.mat <- cbind(set.num, gt.res[,5], gt.res[,2], gt.res[,3], raw.p, bonf.p, fdr.p);
+ rownames(res.mat) <- rownames(gt.res);
+ colnames(res.mat) <- c("Total Cmpd", "Hits", "Statistic Q", "Expected Q", "Raw p", "Holm p", "FDR");
+
+ hit.inx<-res.mat[,2]>0;
+ res.mat<-res.mat[hit.inx, , drop = FALSE];
+ ord.inx<-order(res.mat[,5]);
+ res.mat<-res.mat[ord.inx, , drop = FALSE];
+ mSetObj$analSet$qea.mat <- signif(res.mat,5);
+ mSetObj$analSet$qea.mat <- cbind(mSetObj$analSet$qea.mat, CreateMatchingTable1(mSetObj)) #Added by ZZY on 8/5/21.
+ fast.write.csv(mSetObj$analSet$qea.mat, file="msea_qea_result.csv");
+
+ return(.set.mSet(mSetObj));
+}
+
+#'Single sample profiling to compare with
+#'@description reference concentrations stored in the library
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+CalculateSSP<-function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # first update the compound name to hmdb valid name
+ nm.map <- GetFinalNameMap(mSetObj);
+
+ valid.inx <- !(is.na(nm.map$hmdb)|duplicated(nm.map$hmdb));
+ nm.map <- nm.map[valid.inx,];
+ orig.nms <- nm.map$query;
+
+ hmdb.inx <- match(mSetObj$dataSet$cmpd, orig.nms);
+ match.inx <- !is.na(hmdb.inx);
+
+ # note, must use "as.character" since string column from data frame will be converted to factors
+ # when they used with numerics, they will be changed to numbers, not string
+ ssp.nm <- as.character(nm.map$hmdb[hmdb.inx[match.inx]]);
+ ssp.vec <- mSetObj$dataSet$norm[match.inx];
+
+ cmpd.db <- .get.my.lib("compound_db.qs");
+
+ hit.inx <- match(tolower(ssp.nm), tolower(cmpd.db$name));
+
+ # create the result mat
+ res.mat<-matrix("NA", nrow=length(ssp.nm), ncol=6);
+ colnames(res.mat)<-c("name","conc", "hmdb", "refs", "state", "details");
+
+ ssp.lows <- list();
+ ssp.highs <- list();
+ ssp.means <- list();
+ ssp.refs <- list();
+ ssp.pmids <- list();
+ ssp.notes <- list();
+ for(i in 1:length(ssp.nm)){
+ inx <- hit.inx[i];
+ if(is.na(inx)){ # no match to HMDB ID
+ res.mat[i, ]<-c(ssp.nm[i],ssp.vec[i], "--", "--", "--", "");
+ ssp.lows[[i]]<-NA;
+ ssp.highs[[i]]<-NA;
+ ssp.means[[i]]<-NA;
+ ssp.refs[[i]]<-NA;
+ ssp.pmids[[i]]<-NA;
+ ssp.notes[[i]] <- NA;
+ }else{
+ hits <- Get.ConcRef(mSetObj, ssp.nm[i]);
+ if(is.na(hits)){ # no conc info
+ res.mat[i, ]<-c(ssp.nm[i], ssp.vec[i], cmpd.db$hmdb[inx], "--", "--", "");
+ ssp.lows[[i]]<-NA;
+ ssp.highs[[i]]<-NA;
+ ssp.means[[i]]<-NA;
+ ssp.refs[[i]]<-NA;
+ ssp.pmids[[i]]<-NA;
+ ssp.notes[[i]] <- NA;
+ }else{ # concentration info
+ concs<-as.numeric(unlist(strsplit(hits$conc, " - ", fixed=TRUE), use.names = FALSE));
+ pmid <- hits$pmid;
+ refs <- hits$refs;
+
+ low.inx<-seq(1,length(concs)-2, 3);
+ mean.inx<-seq(2,length(concs)-1, 3);
+ high.inx<-seq(3,length(concs), 3);
+ low.conc<-concs[low.inx];
+ mean.conc <-concs[mean.inx];
+ high.conc<-concs[high.inx];
+ conc.show <- paste(mean.conc, " (", low.conc, " - ", high.conc, ")", sep="", collapse="; ");
+
+ ssp.lows[[i]]<-low.conc;
+ ssp.means[[i]]<-mean.conc;
+ ssp.highs[[i]]<-high.conc;
+ ssp.refs[[i]]<-hits$refs;
+ ssp.pmids[[i]]<-hits$pmid;
+ if(is.na(hits$note)){
+ ssp.notes[[i]] <- NA;
+ }else{
+ ssp.notes[[i]] <- hits$note;
+ }
+ state <- NULL;
+ if(ssp.vec[i]<min(low.conc)){
+ state = "L";
+ }else if(ssp.vec[i]>max(high.conc)){
+ state = "H";
+ }else{
+ state = "M";
+ }
+ res.mat[i, ]<-c(ssp.nm[i], ssp.vec[i], cmpd.db$hmdb[inx], conc.show, state, "View");
+ }
+ }
+ }
+ names(ssp.highs) <- names(ssp.lows) <- names(ssp.means) <- names(ssp.refs) <- names(ssp.pmids) <- names(ssp.notes)<- ssp.nm;
+ mSetObj$analSet$ssp.highs <- ssp.highs;
+ mSetObj$analSet$ssp.lows <- ssp.lows;
+ mSetObj$analSet$ssp.means <- ssp.means;
+ mSetObj$analSet$ssp.refs <- ssp.refs;
+ mSetObj$analSet$ssp.pmids <- ssp.pmids;
+ mSetObj$analSet$ssp.notes <- ssp.notes;
+ mSetObj$analSet$ssp.mat <- res.mat;
+ return(.set.mSet(mSetObj));
+}
+
+#'Create a pie chart for compound classes
+#'@description This function creates a pie-chart for compound classes
+#'in the enrichment analysis if the library is based on chemical ontologies.
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Numeric, input the width, the default is 8.
+#'@param maxClass Numeric, input the maximum number of lipid classes to
+#'include in the pie-chart. By default this is set to 15.
+#'@param colPal Character, input the preferred R Color Brewer palette to be
+#'used for the pie chart. By default this is set to "Set1".
+#'@import ggplot2
+
+PlotEnrichPieChart1 <- function(mSetObj=NA, enrichType, imgName, format="png", dpi=72, width=8,
+ maxClass = 15, colPal = "Set1"){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(.on.public.web){
+ load_ggplot()
+ }
+
+ # make a clean dataSet$cmpd data based on name mapping
+ # only valid hmdb name will be used
+ nm.map <- GetFinalNameMap(mSetObj);
+ valid.inx <- !(is.na(nm.map$hmdb)| duplicated(nm.map$hmdb));
+ ora.vec <- nm.map$hmdb[valid.inx];
+
+ q.size <- length(ora.vec);
+
+ if(is.na(ora.vec) || q.size==0) {
+ AddErrMsg("No valid HMDB compound names found!");
+ return(0);
+ }
+
+ current.mset <- current.msetlib$member
+
+ # make a clean metabilite set based on reference metabolome filtering
+ # also need to update ora.vec to the updated mset
+ if(mSetObj$dataSet$use.metabo.filter && !is.null(mSetObj$dataSet$metabo.filter.hmdb)){
+ current.mset <- lapply(current.mset, function(x){x[x %in% mSetObj$dataSet$metabo.filter.hmdb]})
+ mSetObj$dataSet$filtered.mset <- current.mset;
+ ora.vec <- ora.vec[ora.vec %in% unique(unlist(current.mset, use.names = FALSE))]
+ q.size <- length(ora.vec);
+ }
+
+ set.size <- length(current.mset);
+
+ if(set.size ==1){
+ AddErrMsg("Cannot create pie-chart for a single metabolite set!");
+ return(0);
+ }
+
+ hits <- lapply(current.mset, function(x){x[x %in% ora.vec]});
+ hit.num <- unlist(lapply(hits, function(x) length(x)), use.names = FALSE);
+
+ if(sum(hit.num>0)==0){
+ AddErrMsg("No matches were found to the selected metabolite set library!");
+ return(0);
+ }
+
+ hit.members <- unlist(lapply(hits, function(x) paste(x, collapse = "; ")))
+
+ pie.data <- data.frame(Group = names(hits), Hits = as.numeric(hit.num), Members = hit.members)
+ pie.data <- pie.data[!(pie.data[,2]==0), ]
+ ord.inx <- order(pie.data[,2], decreasing = T);
+ pie.data <- pie.data[ord.inx, , drop = FALSE];
+
+ if(nrow(pie.data) > maxClass){
+ pie.data <- pie.data[1:maxClass,]
+ }
+
+ mSetObj$analSet$enrich.pie.data <- pie.data
+
+ if(nrow(pie.data) > 9){
+ col.fun <- grDevices::colorRampPalette(RColorBrewer::brewer.pal(8, colPal))
+ group_colors <- col.fun(nrow(pie.data))
+ }else{
+ group_colors <- RColorBrewer::brewer.pal(8, colPal)[1:nrow(pie.data)]
+ }
+
+ names(group_colors) <- pie.data[,1]
+ mSetObj$analSet$enrich.pie.cols <- group_colors
+
+ # Basic piechart
+ p <- ggplot(pie.data, aes(x="", y=Hits, fill=Group)) +
+ geom_bar(stat="identity", width=1, color="white") +
+ coord_polar("y", start=0) + theme_void() +
+ scale_fill_manual(values = group_colors) +
+ theme(plot.margin = unit(c(5, 7.5, 2.5, 5), "pt")) +
+ theme(legend.text=element_text(size=12),
+ legend.title=element_text(size=13))
+
+ imgName <- paste(imgName, "dpi", dpi, ".", format, sep="");
+
+ long.name <- max(nchar(pie.data[,1]))
+
+ if(long.name > 25){
+ w <- 10
+ h <- 7
+ }else{
+ h <- width - 1
+ w <- width
+ }
+
+ ggsave(p, filename = imgName, dpi=dpi, width=w, height=h, limitsize = FALSE)
+ fast.write.csv(mSetObj$analSet$enrich.pie.data, file="msea_pie_data.csv");
+ return(.set.mSet(mSetObj));
+}
+
+
+##############################################
+##############################################
+########## Utilities for web-server ##########
+##############################################
+##############################################
+
+GetSSP.Names<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$analSet$ssp.mat[,1]);
+}
+
+# measured concentration
+GetSSP.Concs<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$analSet$ssp.mat[,2]);
+}
+
+GetSSP.HMDB<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$analSet$ssp.mat[,3]);
+}
+
+GetSSP.RefConcs<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$analSet$ssp.mat[,4]);
+}
+
+GetSSP.States<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$analSet$ssp.mat[,5]);
+}
+
+GetSSP.Details<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$analSet$ssp.mat[,6]);
+}
+
+GetSSP.RefConc<-function(mSetObj=NA, nm){
+ mSetObj <- .get.mSet(mSetObj);
+ if(is.na(mSetObj$analSet$ssp.means[[nm]])){
+ return ("NA");
+ }
+ return(paste(mSetObj$analSet$ssp.means[[nm]], " (", mSetObj$analSet$ssp.lows[[nm]], " - ", mSetObj$analSet$ssp.highs[[nm]], ")", sep=""));
+}
+
+GetSSP.Refs<-function(mSetObj=NA, nm){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$analSet$ssp.refs[[nm]]);
+}
+
+GetSSP.Pmids<-function(mSetObj=NA, nm){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$analSet$ssp.pmids[[nm]]);
+}
+
+GetSSP.Notes<-function(mSetObj=NA, nm){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$analSet$ssp.notes[[nm]]);
+}
+
+#'Replace the last column of the ssp.mat with the final selection from users
+#'@description Replace the last column of the ssp.mat with the final selection from users
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+GetSSPTable<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ ssp.res<-mSetObj$analSet$ssp.mat[,-c(1,3,6)];
+ rownames(ssp.res)<-mSetObj$analSet$ssp.mat[,1]
+ selected.col<-rep(0, nrow(ssp.res));
+ inx<-match(mSetObj$dataSet$cmpd, mSetObj$analSet$ssp.mat[,1]);
+ selected.col[inx]<-1;
+
+ print(xtable::xtable(cbind(ssp.res, selected = selected.col),align="l|l|p{8cm}|c|c", caption="Comparison with Reference Concentrations"),
+ tabular.environment = "longtable", caption.placement="top", size="\\scriptsize");
+}
+
+#'Given a metset inx, return hmtl highlighted metset cmpds and references
+#'@description Given a metset inx, return hmtl highlighted metset cmpds and references
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param msetNm Input the name of the metabolite set
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+GetHTMLMetSet<-function(mSetObj=NA, msetNm){
+ mSetObj <- .get.mSet(mSetObj);
+
+ hits <- NULL;
+
+ if(mSetObj$analSet$type=="msetora" || mSetObj$analSet$type=="msetssp"){
+ hits <- mSetObj$analSet$ora.hits;
+ }else{
+ hits <- mSetObj$analSet$qea.hits;
+ }
+
+ # highlighting with different colors
+ # this is meaningless for very large (>200) metabolite sets (i.e. chemical class)
+ mset <- current.msetlib$member[[msetNm]];
+ if(length(mset) < 200){
+ red.inx <- which(mset %in% hits[[msetNm]]);
+ }else{
+ mset <- hits[[msetNm]];
+ red.inx <- 1:length(mset);
+ }
+
+ mset[red.inx] <- paste("<font color=\"red\">", "<b>", mset[red.inx], "</b>", "</font>",sep="");
+ if(mSetObj$dataSet$use.metabo.filter && exists('filtered.mset')){
+ grey.inx <- which(!(mset %in% filtered.mset[[msetNm]]));
+ mset[grey.inx] <- paste("<font color=\"grey\">", "<b>", mset[grey.inx], "</b>", "</font>",sep="");
+ }
+ # get references
+ matched.inx <- match(tolower(msetNm), tolower(current.msetlib$name))[1];
+ return(cbind(msetNm, paste(mset, collapse="; "), current.msetlib$reference[matched.inx]));
+}
+
+#'Given a metset inx, give its name
+#'@description Given a metset inx, give its name
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param msetInx Input the index of the metabolite set
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+GetMetSetName<-function(mSetObj=NA, msetInx){
+ mSetObj <- .get.mSet(mSetObj);
+ if(mSetObj$analSet$type=="msetora" || mSetObj$analSet$type=="msetssp"){
+ msetNm <- rownames(mSetObj$analSet$ora.mat)[msetInx];
+ }else{
+ msetNm <- rownames(mSetObj$analSet$qea.mat)[msetInx];
+ }
+ return (msetNm);
+}
+
+GetORA.colorBar<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ len <- nrow(mSetObj$analSet$ora.mat);
+ ht.col <- GetMyHeatCols(len);
+ rbg.cols <- hex2rgb(ht.col);
+ return (rbg.cols);
+}
+
+GetORA.rowNames<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ nms <- rownames(mSetObj$analSet$ora.mat);
+ if(is.null(nms)){
+ return("NA");
+ }
+ return (nms);
+}
+
+GetORA.mat<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$analSet$ora.mat);
+}
+
+#'Get ORA table
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@export
+GetORATable<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ res <- mSetObj$analSet$ora.mat;
+ if(substr(mSetObj$analSet$type, 0, 4) == 'mset'){
+ print(xtable::xtable(mSetObj$analSet$ora.mat,align="p{5cm}|l|l|l|l|l|l", display=c("s","d","f","d","E","E","E"), caption="Result from Over Representation Analysis"),
+ tabular.environment = "longtable", caption.placement="top", size="\\scriptsize");
+ }else{
+ rownames(res)<-GetORA.pathNames(mSetObj);
+ print(xtable::xtable(res,align="p{5cm}|l|l|l|l||ll|l|l", display=c("s","d","f","d","E","E", "E","E", "f"),
+ caption="Result from Pathway Analysis"),
+ tabular.environment = "longtable", caption.placement="top", size="\\scriptsize");
+ }
+}
+
+GetQEA.colorBar<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ len <- nrow(mSetObj$analSet$qea.mat);
+ ht.col <- GetMyHeatCols(len);
+ return (ht.col);
+}
+
+GetQEA.rowNames<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ nms <- rownames(mSetObj$analSet$qea.mat);
+ if(is.null(nms)){
+ return("NA");
+ }
+ return (nms);
+}
+
+GetQEA.mat<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$analSet$qea.mat);
+}
+
+#'QEA table
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@export
+GetQEATable<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ res <- mSetObj$analSet$qea.mat;
+ if(substr(mSetObj$analSet$type, 0, 4) == 'mset'){
+ print(xtable::xtable(res,align="p{4cm}|l|l|l|l|l|l|l", display=c("s","d","d","f","f","E","E","E"),
+ caption="Result from Quantitative Enrichment Analysis"),
+ tabular.environment = "longtable", caption.placement="top", size="\\scriptsize");
+ }else{
+ rownames(res)<- GetQEA.pathNames();
+ print(xtable::xtable(res,align="p{5cm}|l|l|l|l|l|l|l", display=c("s","d","d","E","E", "E","E","f"),
+ caption="Result from Pathway Analysis"),
+ tabular.environment = "longtable", caption.placement="top", size="\\scriptsize");
+ }
+}
+
+GetEnrichPieNames <- function(mSetObj = NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$analSet$enrich.pie.data$Group)
+}
+
+GetEnrichPieHits <- function(mSetObj = NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(as.matrix(as.numeric(mSetObj$analSet$enrich.pie.data[,2])))
+}
+
+GetEnrichPieColors <- function(mSetObj = NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$analSet$enrich.pie.cols)
+}
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/gene_fun_utils.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/gene_fun_utils.R
new file mode 100755
index 0000000000000000000000000000000000000000..17a7fd310541acc928f064badcd2a01d2ed5f6ff
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/gene_fun_utils.R
@@ -0,0 +1,202 @@
+##################################################
+## R script for MetaboAnalyst
+## Description: GO/Pathway ORA
+## Author: Jeff Xia, jeff.xia@mcgill.ca
+###################################################
+
+# note: hit.query, resTable must synchronize
+PerformNetEnrichment <- function(mSetObj=NA, file.nm, fun.type, IDs){
+ # prepare query
+ ora.vec <- unlist(strsplit(IDs, "; ", fixed=TRUE));
+ names(ora.vec) <- as.character(ora.vec);
+ mSetObj <- .get.mSet(mSetObj);
+ res <- PerformEnrichAnalysis(mSetObj$org, file.nm, fun.type, ora.vec);
+ return(res);
+}
+
+# note: hit.query, resTable must synchronize
+# ora.vec should contains entrez ids, named by their gene symbols
+PerformEnrichAnalysis <- function(org.code, file.nm, fun.type, ora.vec){
+ if(fun.type %in% c("keggc", "smpdb")){
+ .load.enrich.compound.lib(org.code, fun.type);
+ }else{
+ .load.enrich.lib(org.code, fun.type);
+ }
+
+
+ # prepare query
+ ora.nms <- names(ora.vec);
+ ora <<- ora.vec
+
+ # prepare for the result table
+ set.size<-length(current.geneset);
+ res.mat<-matrix(0, nrow=set.size, ncol=5);
+ rownames(res.mat)<-names(current.geneset);
+ colnames(res.mat)<-c("Total", "Expected", "Hits", "P.Value", "FDR");
+
+ # need to cut to the universe covered by the pathways, not all genes
+ hits.inx <- ora.vec %in% current.universe;
+ ora.vec <- ora.vec[hits.inx];
+ ora.nms <- ora.nms[hits.inx];
+
+ q.size<-length(ora.vec);
+
+ # get the matched query for each pathway
+
+ if(fun.type %in% c("keggc", "smpdb")){
+
+ hits.query <- lapply(current.geneset, function(x){x[names(x) %in% ora.vec]});
+hits.query<- lapply(hits.query, function(x){names(x)});
+}else{
+ hits.query <- lapply(current.geneset,
+ function(x) {
+ ora.nms[ora.vec%in%unlist(x)];
+ }
+ );
+}
+
+ names(hits.query) <- names(current.geneset);
+ hit.num<-unlist(lapply(hits.query, function(x){length(x)}), use.names=FALSE);
+
+ # total unique gene number
+ uniq.count <- length(current.universe);
+
+ # unique gene count in each pathway
+ set.size <- unlist(lapply(current.geneset, length));
+
+ res.mat[,1]<-set.size;
+ res.mat[,2]<-q.size*(set.size/uniq.count);
+ res.mat[,3]<-hit.num;
+
+ # use lower.tail = F for P(X>x)
+ raw.pvals <- phyper(hit.num-1, set.size, uniq.count-set.size, q.size, lower.tail=F);
+ res.mat[,4]<- raw.pvals;
+ res.mat[,5] <- p.adjust(raw.pvals, "fdr");
+
+ # now, clean up result, synchronize with hit.query
+ res.mat <- res.mat[hit.num>0,,drop = F];
+ hits.query <- hits.query[hit.num>0];
+
+ if(nrow(res.mat)> 1){
+ # order by p value
+ ord.inx<-order(res.mat[,4]);
+ res.mat <- signif(res.mat[ord.inx,],3);
+ hits.query <- hits.query[ord.inx];
+
+ imp.inx <- res.mat[,4] <= 0.05;
+ if(sum(imp.inx) < 10){ # too little left, give the top ones
+ topn <- ifelse(nrow(res.mat) > 10, 10, nrow(res.mat));
+ res.mat <- res.mat[1:topn,];
+ hits.query <- hits.query[1:topn];
+ }else{
+ res.mat <- res.mat[imp.inx,];
+ hits.query <- hits.query[imp.inx];
+ if(sum(imp.inx) > 120){
+ # now, clean up result, synchronize with hit.query
+ res.mat <- res.mat[1:120,];
+ hits.query <- hits.query[1:120];
+ }
+ }
+ }
+
+ #get gene symbols
+ resTable <- data.frame(Pathway=rownames(res.mat), res.mat);
+ AddMsg("Functional enrichment analysis was completed");
+
+ # write json
+ fun.anot = hits.query;
+ fun.pval = resTable[,5]; if(length(fun.pval) ==1) { fun.pval <- matrix(fun.pval) };
+ hit.num = resTable[,4]; if(length(hit.num) ==1) { hit.num <- matrix(hit.num) };
+ if(fun.type %in% c("keggc", "smpdb")){
+fun.ids <- as.vector(current.setids[which(current.setids %in% names(fun.anot))]);
+names(fun.anot) = as.vector(names(current.setids[which(current.setids %in% names(fun.anot))]));
+
+}else{
+ fun.ids <- as.vector(current.setids[names(fun.anot)]);
+}
+ if(length(fun.ids) ==1) { fun.ids <- matrix(fun.ids) };
+ json.res <- list(
+ fun.link = current.setlink[1],
+ fun.anot = fun.anot,
+ fun.ids = fun.ids,
+ fun.pval = fun.pval,
+ hit.num = hit.num
+ );
+ json.mat <- RJSONIO::toJSON(json.res, .na='null');
+ json.nm <- paste(file.nm, ".json", sep="");
+
+ sink(json.nm)
+ cat(json.mat);
+ sink();
+
+ # write csv
+ fun.hits <<- hits.query;
+ fun.pval <<- resTable[,5];
+ hit.num <<- resTable[,4];
+ csv.nm <- paste(file.nm, ".csv", sep="");
+ fast.write.csv(resTable, file=csv.nm, row.names=F);
+ return(1);
+}
+
+
+# these are geneset libraries
+.load.enrich.lib<-function(org.code, fun.type){
+ # prepare lib
+ is.go <- FALSE;
+ if(tolower(fun.type) == 'kegg'){
+ nm <- "kegg";
+ }else if(tolower(fun.type) == 'reactome'){
+ nm <- "reactome";
+ }else if(tolower(fun.type) == 'motif'){
+ nm <- "motif_set";
+ }else{ # GO
+ is.go <- TRUE;
+ nm <- paste0("go_", tolower(fun.type));
+ }
+ lib.nm <- paste0(nm, ".qs");
+ sub.dir <- paste0("genesets/", org.code);
+ my.lib <- .get.my.lib(lib.nm, sub.dir);
+ if(is.go){ # fix some issue in go lib
+ if(is.null(names(my.lib))){
+ names(my.lib) <- c("link", "term", "sets");
+ }
+ }
+
+ current.setlink <- my.lib$link;
+ current.mset <- my.lib$sets;
+ set.ids<- names(current.mset);
+ names(set.ids) <- names(current.mset) <- my.lib$term;
+
+ current.setlink <<- current.setlink;
+ current.setids <<- set.ids;
+ current.geneset <<- current.mset;
+ current.universe <<- unique(unlist(current.geneset));
+}
+
+
+# these are geneset libraries
+.load.enrich.compound.lib<-function(org.code, fun.type){
+ # prepare lib
+ is.go <- FALSE;
+ mSetObj <- .get.mSet();
+ if(tolower(fun.type) == 'smpdb'){
+ nm <- mSetObj$org;
+ sub.dir <- paste0("smpdb");
+ }else if(tolower(fun.type) == 'keggc'){
+ nm <- mSetObj$org;
+ sub.dir <- paste0("kegg/metpa");
+ }
+
+ lib.nm <- paste0(nm, ".qs");
+
+ my.lib <- .get.my.lib(lib.nm, sub.dir);
+
+ current.setlink <- my.lib$link;
+ current.mset <- my.lib$mset.list;
+ set.ids<- my.lib$path.ids;
+
+ current.setlink <<- current.setlink;
+ current.setids <<- set.ids;
+ current.geneset <<- current.mset;
+ current.universe <<- unique(names(unlist(unname(current.geneset))));
+}
\ No newline at end of file
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/general_anot_utils.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/general_anot_utils.R
new file mode 100755
index 0000000000000000000000000000000000000000..695a20416b8926c48ff8a5881124d4978788b918
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/general_anot_utils.R
@@ -0,0 +1,259 @@
+
+
+#'Save concentration data
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param conc Input the concentration data
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+Setup.ConcData<-function(mSetObj=NA, conc){
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$dataSet$norm <- conc;
+ return(.set.mSet(mSetObj));
+}
+
+#'Save biofluid type for SSP
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param type Input the biofluid type
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+Setup.BiofluidType<-function(mSetObj=NA, type){
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$dataSet$biofluid <- type;
+ return(.set.mSet(mSetObj));
+}
+
+#'Set organism for further analysis
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param org Set organism ID
+#'@export
+SetOrganism <- function(mSetObj=NA, org){
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$org <- org;
+ return(.set.mSet(mSetObj))
+}
+
+GetKEGG.PathNames<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(names(current.kegglib$path.ids));
+}
+
+#'Given a vector containing KEGGIDs, returns a vector of KEGG compound names
+#'@description This function, given a vector containing KEGGIDs, returns a vector of KEGG compound names.
+#'@param ids Vector of KEGG ids
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+KEGGID2Name<-function(ids){
+ cmpd.db <- .get.my.lib("compound_db.qs");
+ hit.inx<- match(ids, cmpd.db$kegg);
+ return(cmpd.db[hit.inx, 3]);
+}
+
+#'Given a vector containing KEGG pathway IDs, return a vector containing SMPDB IDs (only for hsa)
+#'@description This function, when given a vector of KEGG pathway IDs, return a vector of SMPDB IDs (only for hsa).
+#'SMPDB standing for the Small Molecule Pathway Database, and hsa standing for human serum albumin.
+#'@param ids Vector of KEGG pathway IDs
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+KEGGPATHID2SMPDBIDs<-function(ids){
+ hit.inx<-match(ids, path.map[,1]);
+ return(path.map[hit.inx, 3]);
+}
+
+#'Given a vector of HMDBIDs, return a vector of HMDB compound names
+#'@description This function, when given a vector of HMDBIDs, return a vector of HMDB compound names. HMDB standing
+#'for the Human Metabolome Database.
+#'@param ids Input the vector of HMDB Ids
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+HMDBID2Name1<-function(ids){ #Changed by ZZY on 7/30/21.
+ cmpd.db <- .get.my.lib("compound_db.qs");
+# hit.inx<- match(ids, cmpd.db$hmdb); #Replaced by ZZY. See bwlow. The code was copied from the MetaboliteMappingExact() function in enrich_name_match.R
+#######Replacement: Begin##########
+ n <- 5 # Number of digits for V3 of HMDB
+ hmdb.digits <- as.vector(sapply(cmpd.db$hmdb, function(x) strsplit(x, "HMDB", fixed=TRUE)[[1]][2]))
+ hmdb.v3.ids <- paste0("HMDB", substr(hmdb.digits, nchar(hmdb.digits)-n+1, nchar(hmdb.digits)))
+ hit.inx.v3 <- match(tolower(ids), tolower(hmdb.v3.ids));
+ hit.inx <- match(tolower(ids), tolower(cmpd.db$hmdb));
+ hit.inx[is.na(hit.inx)] <- hit.inx.v3[is.na(hit.inx)]
+#######Replacement: End##########
+ return(cmpd.db[hit.inx, "name"]);
+}
+
+#'Given a vector of KEGGIDs, return a vector of HMDB ID
+#'@description This functionn, when given a vector of KEGGIDs, returns a vector of HMDB IDs. HMDB standing
+#'for the Human Metabolome Database.
+#'@param ids Vector of KEGG ids
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+KEGGID2HMDBID<-function(ids){
+
+ cmpd.db <- .get.my.lib("compound_db.qs");
+
+ hit.inx<- match(ids, cmpd.db$kegg);
+ return(cmpd.db[hit.inx, "hmdb_id"]);
+}
+
+#'Given a vector of HMDBIDs, return a vector of KEGG IDs
+#'@description This function, when given a vector of HMDBIDs, returns a vector of KEGG ID. HMDB standing
+#'for the Human Metabolome Database.
+#'@param ids Input the vector of HMDB Ids
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+HMDBID2KEGGID<-function(ids){
+ cmpd.db <- .get.my.lib("compound_db.qs");
+ hit.inx<- match(ids, cmpd.db$hmdb);
+ return(cmpd.db[hit.inx, "kegg_id"]);
+}
+
+
+#'Convert different gene IDs into entrez IDs for downstream analysis
+#'@description Gene ID mapping, gene annotation, compound
+#'mapping, KEGG mapping
+#'@param q.vec Input the query
+#'@param org Input the organism type
+#'@param type Input the type of data to annotate
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+doGeneIDMapping1 <- function(q.vec, org, type){
+
+ sqlite.path <- file.path(url.pre, paste0(org, "_genes.sqlite")); #Changed by ZZY on 7/23/2021.
+ con <- .get.sqlite.con(sqlite.path);
+
+ if(type == "symbol"){
+ db.map = dbReadTable(con, "entrez")
+ hit.inx <- match(q.vec, db.map[, "symbol"]);
+ }else if(type == "entrez"){
+ db.map = dbReadTable(con, "entrez")
+ hit.inx <- match(q.vec, db.map[, "gene_id"]);
+ }else if(type == "entrez_to_symbol"){ #Added by ZZY on 8/2/21. See lines below.
+ db.map = dbReadTable(con, "entrez");
+ q.vec <- match(q.vec, db.map[, "gene_id"], nomatch=0)
+ symbols <- rep(NA,length(q.vec))
+ symbols[q.vec!=0] <- db.map[q.vec, "symbol"]
+ rm(db.map, q.vec); gc();
+ dbDisconnect(con);
+ return(symbols);
+ }else{
+ if(type == "genbank"){
+ db.map = dbReadTable(con, "entrez_gb");
+ }else if(type == "embl"){
+ db.map = dbReadTable(con, "entrez_embl_gene");
+ }else if(type == "refseq"){
+ db.map = dbReadTable(con, "entrez_refseq");
+ q.mat <- do.call(rbind, strsplit(q.vec, "\\."));
+ q.vec <- q.mat[,1];
+ }else if(type == "kos"){
+ db.map = dbReadTable(con, "entrez_ortholog");
+ }
+ hit.inx <- match(q.vec, db.map[, "accession"]);
+ }
+
+ if(org %in% c("bta", "dre", "gga", "hsa", "mmu", "osa", "rno")){
+ entrezs=db.map[hit.inx, "gene_id"];
+ }else{
+ entrezs=db.map[hit.inx, "symbol"];
+ }
+
+ rm(db.map, q.vec); gc();
+ dbDisconnect(con);
+ return(entrezs);
+}
+
+#'Perform compound mapping
+#'@param cmpd.vec Input compound vector
+#'@param q.type Query type
+#'@export
+doCompoundMapping<-function(cmpd.vec, q.type){
+
+ cmpd.map <- .get.my.lib("compound_db.qs");
+
+ if(q.type == "name"){
+
+ # first find exact match to the common compound names
+ hit.inx <- match(tolower(cmpd.vec), tolower(cmpd.map$name));
+
+ # then try to find exact match to synanyms for the remaining unmatched query names one by one
+ todo.inx <-which(is.na(hit.inx));
+ if(length(todo.inx) > 0){
+ # then try to find exact match to synanyms for the remaining unmatched query names one by one
+ syn.db <- .get.my.lib("syn_nms.qs")
+ syns.list <- syn.db$syns.list;
+ for(i in 1:length(syns.list)){
+ syns <- syns.list[[i]];
+ hitInx <- match(tolower(cmpd.vec[todo.inx]), tolower(syns));
+ hitPos <- which(!is.na(hitInx));
+ if(length(hitPos)>0){
+ # record matched ones
+ orig.inx<-todo.inx[hitPos];
+ hit.inx[orig.inx] <- i;
+ # update unmatched list
+ todo.inx<-todo.inx[is.na(hitInx)];
+ }
+ if(length(todo.inx) == 0) break;
+ }
+ }
+ dat <- cmpd.map[hit.inx, "kegg"];
+ }else{
+ if(q.type == "hmdb"){
+ hit.inx <- match(tolower(cmpd.vec), tolower(cmpd.map$hmdb));
+ }else if(q.type == "kegg"){
+ hit.inx <- match(tolower(cmpd.vec), tolower(cmpd.map$kegg));
+ }else if(q.type == "pubchem"){
+ hit.inx <- match(tolower(cmpd.vec), tolower(cmpd.map$pubchem));
+ }else if(q.type == "chebi"){
+ hit.inx <- match(tolower(cmpd.vec), tolower(cmpd.map$chebi));
+ }else if(q.type == "reactome"){
+ hit.inx <- match(tolower(cmpd.vec), tolower(cmpd.map$reactome));
+ }else{
+ print("No support is available for this compound database");
+ return(0);
+ }
+ dat <- cmpd.map[hit.inx, "kegg"];
+ }
+ return(dat);
+}
+
+#'Perform KEGG to compound name mapping
+#'@param kegg.vec Input vector of KEGG compounds
+#'@export
+doKEGG2NameMapping <- function(kegg.vec){
+ cmpd.map <- .get.my.lib("compound_db.qs");
+ hit.inx <- match(tolower(kegg.vec), tolower(cmpd.map$kegg));
+ nms <- cmpd.map[hit.inx, "name"];
+ return(nms);
+}
+
+##########Begin: Added by ZZY on 8/2/21#############
+id2NameMapping <- function(id.vec, org) {
+ names(id.vec) <- id.vec
+ id.vec <- strsplit(id.vec,":")
+ idType <- sapply(id.vec,"[",1)
+ idNumber <- sapply(id.vec,"[",2)
+ cpd=doKEGG2NameMapping(idNumber)
+ cpd[is.na(cpd)|idType!="cpd"] <- ""
+ gene=doGeneIDMapping1(idNumber, org, "entrez_to_symbol")
+ gene[is.na(gene)|idType=="cpd"] <- ""
+ feature <- paste0(cpd,gene)
+ id.vec[feature!=""] <- feature[feature!=""]
+ return(id.vec)
+}
+##########End: Added by ZZY on 8/2/21#############
+
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/general_data_utils.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/general_data_utils.R
new file mode 100755
index 0000000000000000000000000000000000000000..4a6647a3119375daee53373f7fd108bd3dc3719b
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/general_data_utils.R
@@ -0,0 +1,1009 @@
+# internal variables and functions not to be modified by users
+# This is only for web version
+.on.public.web <- FALSE; # only TRUE when on metaboanalyst web server
+
+# note, this is usually used at the end of a function
+# for local, return itself; for web, push to global environment
+.set.mSet <- function(mSetObj=NA){
+ if(.on.public.web){
+ mSet <<- mSetObj;
+ return (1);
+ }
+ return(mSetObj);
+}
+
+.get.mSet <- function(mSetObj=NA){
+ if(.on.public.web){
+ return(mSet)
+ }else{
+ return(mSetObj);
+ }
+}
+
+#'Constructs a dataSet object for storing data
+#'@description This functions handles the construction of a mSetObj object for storing data for further processing and analysis.
+#'It is necessary to utilize this function to specify to MetaboAnalystR the type of data and the type of analysis you will perform.
+#'@usage InitDataObjects(data.type, anal.type, paired=FALSE)
+#'@param data.type The type of data, either list (Compound lists), conc (Compound concentration data),
+#'specbin (Binned spectra data), pktable (Peak intensity table), nmrpeak (NMR peak lists), mspeak (MS peak lists),
+#'or msspec (MS spectra data)
+#'@param anal.type Indicate the analysis module to be performed: stat, pathora, pathqea, msetora, msetssp, msetqea, ts,
+#'cmpdmap, smpmap, or pathinteg
+#'@param paired Indicate if the data is paired or not. Logical, default set to FALSE
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'@import methods
+
+InitDataObjects1 <- function(data.type, anal.type, paired=FALSE){
+
+ if(!.on.public.web){
+ if(exists("mSet")){
+ mSetObj <- .get.mSet(mSet);
+ mSetObj$dataSet$type <- data.type;
+ mSetObj$dataSet$paired <- paired;
+ mSetObj$analSet$type <- anal.type;
+ return(.set.mSet(mSetObj));
+ }
+ }
+
+ dataSet <- list();
+ dataSet$type <- data.type;
+ dataSet$design.type <- "regular"; # one factor to two factor
+ dataSet$cls.type <- "disc"; # default until specified otherwise
+ dataSet$format <- "rowu";
+ dataSet$paired <- paired;
+ analSet <- list();
+ analSet$type <- anal.type;
+
+ mSetObj <- list();
+ mSetObj$dataSet <- dataSet;
+ mSetObj$analSet <- analSet;
+ mSetObj$imgSet <- list();
+ mSetObj$msgSet <- list(); # store various message during data processing
+ mSetObj$msgSet$msg.vec <- vector(mode="character"); # store error messages
+ mSetObj$cmdSet <- vector(mode="character"); # store R command
+
+ .init.global.vars(anal.type);
+ print("MetaboAnalyst R objects initialized ...");
+ return(.set.mSet(mSetObj));
+}
+
+# this is for switching module
+UpdateDataObjects <- function(data.type, anal.type, paired=FALSE){
+
+ mSetObj <- .get.mSet(NA);
+ mSetObj$dataSet$type <- data.type;
+ mSetObj$analSet$type <- anal.type;
+ .init.global.vars(anal.type);
+
+ # some specific setup
+ if(anal.type == "mummichog"){
+ .init.MummiMSet();
+ load("params.rda");
+ mSetObj <- UpdateInstrumentParameters(mSetObj, peakParams$ppm, peakParams$polarity, "yes", 0.02);
+ mSetObj <- .rt.included(mSetObj, "seconds");
+ mSetObj <- Read.TextData(mSetObj, "metaboanalyst_input.csv", "colu", "disc");
+ mSetObj <- .get.mSet(NA);
+ }
+ return(.set.mSet(mSetObj));
+}
+
+.init.MummiMSet <- function(mSetObj=NA) {
+ SetPeakFormat("pvalue");
+ TableFormatCoerce("metaboanalyst_input.csv", "OptiLCMS", "mummichog");
+ anal.type <<- "mummichog";
+ api.base <<- "http://api.xialab.ca";
+ err.vec <<- "";
+}
+
+.init.global.vars <- function(anal.type){
+ # other global variables
+ msg.vec <<- "";
+ err.vec <<- "";
+
+ # for network analysis
+ module.count <<- 0;
+ # counter for naming different json file (pathway viewer)
+ smpdbpw.count <<- 0;
+ # for mummichog
+ peakFormat <<- "mpt"
+
+ # raw data processing
+ rawfilenms.vec <<- vector();
+
+ # for meta-analysis
+ mdata.all <<- list();
+ mdata.siggenes <<- vector("list");
+ meta.selected <<- TRUE;
+ anal.type <<- anal.type;
+
+ if(.on.public.web){
+ # disable parallel prcessing for public server
+ library(BiocParallel);
+ register(SerialParam());
+ }else{
+ if("stat" %in% anal.type | "msetqea" %in% anal.type | "pathqea" %in% anal.type | "roc" %in% anal.type)
+ # start Rserve engine for Rpackage
+ load_Rserve();
+ }
+
+ # plotting required by all
+ Cairo::CairoFonts(regular="Arial:style=Regular",bold="Arial:style=Bold",italic="Arial:style=Italic",bolditalic = "Arial:style=Bold Italic",symbol = "Symbol")
+
+ # sqlite db path for gene annotation
+ if(file.exists("/home/glassfish/sqlite/")){ #.on.public.web
+ url.pre <<- "/home/glassfish/sqlite/";
+ }else if(file.exists("/home/jasmine/Downloads/sqlite/")){ #jasmine's local
+ url.pre <<- "/home/jasmine/Downloads/sqlite/";
+ api.base <<- "localhost:8987"
+ }else if(file.exists("/Users/soufanom/Documents/Projects/gene-id-mapping/")){ # soufan laptop
+ url.pre <<- "/Users/soufanom/Documents/Projects/gene-id-mapping/";
+ }else if(file.exists("~/Documents/Projects/gene-id-mapping/")){
+ url.pre <<- "~/Documents/Projects/gene-id-mapping/"
+ }else if(file.exists("/Users/xia/Dropbox/sqlite/")){ # xia local
+ url.pre <<- "/Users/xia/Dropbox/sqlite/";
+ }else if(file.exists("/media/zzggyy/disk/sqlite/")){
+ url.pre <<-"/media/zzggyy/disk/sqlite/"; #zgy local)
+ }else if(file.exists("/home/zgy/sqlite/")){
+ url.pre <<-"/home/zgy/sqlite/"; #zgy local)
+ } else if(file.exists("/home/le/sqlite/")){# le local
+ url.pre <<-"/home/le/sqlite/";
+ }else{
+ url.pre <<- paste0(dirname(system.file("database", "sqlite/GeneID_25Species_JE/ath_genes.sqlite", package="MetaboAnalystR")), "/")
+ api.base <<- "http://api.xialab.ca"
+ }
+}
+#'For two factor time series only
+#'@description For two factor time series only
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param design Input the design type
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+SetDesignType <-function(mSetObj=NA, design){
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$dataSet$design.type <- tolower(design);
+ return(.set.mSet(mSetObj));
+}
+
+#'Record R Commands
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param cmd Commands
+#'@export
+RecordRCommand <- function(mSetObj=NA, cmd){
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$cmdSet <- c(mSetObj$cmdSet, cmd);
+ return(.set.mSet(mSetObj));
+}
+
+SaveRCommands <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ cmds <- paste(mSetObj$cmdSet, collapse="\n");
+ write(cmds, file = "Rhistory.R", append = FALSE);
+}
+
+#'Export R Command History
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@export
+GetRCommandHistory <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$cmdSet);
+}
+
+#'Constructor to read uploaded CSV or TXT files into the dataSet object
+#'@description This function handles reading in CSV or TXT files and filling in the dataSet object
+#'created using "InitDataObjects".
+#'@usage Read.TextData(mSetObj=NA, filePath, format, lbl.type)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects).
+#'@param filePath Input the path name for the CSV/TXT files to read.
+#'@param format Specify if samples are paired and in rows (rowp), unpaired and in rows (rowu),
+#'in columns and paired (colp), or in columns and unpaired (colu).
+#'@param lbl.type Specify the data label type, either discrete (disc) or continuous (cont).
+#'@param nmdr Boolean. Default set to FALSE (data is uploaded by the user and not fetched
+#'through an API call to the Metabolomics Workbench).
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}, Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+Read.TextData1 <- function(mSetObj=NA, filePath, format="rowu",
+ lbl.type="disc", nmdr = FALSE){
+
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$dataSet$cls.type <- lbl.type;
+ mSetObj$dataSet$format <- format;
+
+ if(nmdr){
+ dat <- qs::qread("nmdr_study.qs")
+ }else{
+ dat <- .readDataTable(filePath);
+ }
+
+ if(class(dat) == "try-error" || ncol(dat) == 1){
+ AddErrMsg("Data format error. Failed to read in the data!");
+ AddErrMsg("Make sure the data table is saved as comma separated values (.csv) format!");
+ AddErrMsg("Please also check the followings: ");
+ AddErrMsg("Either sample or feature names must in UTF-8 encoding; Latin, Greek letters are not allowed.");
+ AddErrMsg("We recommend to use a combination of English letters, underscore, and numbers for naming purpose.");
+ AddErrMsg("Make sure sample names and feature (peak, compound) names are unique.");
+ AddErrMsg("Missing values should be blank or NA without quote.");
+ AddErrMsg("Make sure the file delimeters are commas.");
+ return(0);
+ }
+
+ msg <- NULL;
+
+ if(substring(format,4,5)=="ts"){
+ # two factor time series data
+ if(substring(format,1,3)=="row"){ # sample in row
+ msg<-c(msg, "Samples are in rows and features in columns");
+ smpl.nms <-dat[,1];
+ all.nms <- colnames(dat);
+ facA.lbl <- all.nms[2];
+ cls.lbl <- facA <- dat[,2]; # default assign facA to cls.lbl in order for one-factor analysis
+ facB.lbl <- all.nms[3];
+ facB <- dat[,3];
+ conc <- dat[,-c(1:3)];
+ var.nms <- colnames(conc);
+ }else{ # sample in col
+ msg<-c(msg, "Samples are in columns and features in rows.");
+ all.nms <- dat[,1];
+ facA.lbl <- all.nms[1];
+ cls.lbl <- facA <- dat[1,-1];
+ facB.lbl <- all.nms[2];
+ facB <- dat[2,-1];
+ var.nms <- dat[-c(1:2),1];
+ conc<-t(dat[-c(1:2),-1]);
+ smpl.nms <- rownames(conc);
+ }
+
+ if(mSetObj$dataSet$design.type =="time" | mSetObj$dataSet$design.type =="time0"){
+ # determine time factor
+ if(!(tolower(facA.lbl) == "time" | tolower(facB.lbl) == "time")){
+ AddErrMsg("No time points found in your data");
+ AddErrMsg("The time points group must be labeled as <b>Time</b>");
+ return(0);
+ }
+ }
+ }else{
+
+ if(substring(format,1,3)=="row"){ # sample in row
+ msg <- c(msg, "Samples are in rows and features in columns");
+ smpl.nms <-dat[,1];
+ dat[,1] <- NULL; #remove sample names
+ if(lbl.type == "qc"){
+ rownames(dat) <- smpl.nms;
+ #mSetObj$dataSet$orig <- dat;
+ qs::qsave(dat, file="data_orig.qs");
+ mSetObj$dataSet$cmpd <- colnames(dat);
+ return(1);
+ }
+ cls.lbl <- dat[,1];
+ conc <- dat[,-1, drop=FALSE];
+ var.nms <- colnames(conc);
+ if(lbl.type == "no"){ #no class label
+ cls.lbl <- rep(1, nrow(dat));
+ conc <- dat[,, drop=FALSE];
+ var.nms <- colnames(conc);
+ }
+ }else{ # sample in col
+ msg<-c(msg, "Samples are in columns and features in rows.");
+ if(lbl.type == "no"){
+ cls.lbl <- rep(1, ncol(dat));
+ conc <- t(dat[,-1]);
+ var.nms <- dat[,1];
+ smpl.nms <- colnames(dat[,-1]);
+ }else{
+ var.nms <- dat[-1,1];
+ dat[,1] <- NULL;
+ smpl.nms <- colnames(dat);
+ cls.lbl <- dat[1,];
+ conc <- t(dat[-1,]);
+ }
+ }
+ }
+
+ mSetObj$dataSet$type.cls.lbl <- class(cls.lbl);
+
+ msg <- c(msg, "The uploaded file is in comma separated values (.csv) format.");
+
+ # try to remove empty line if present
+ # identified if no sample names provided
+
+ empty.inx <- is.na(smpl.nms) | smpl.nms == ""
+ if(sum(empty.inx) > 0){
+ msg <- c(msg, paste("<font color=\"red\">", sum(empty.inx), "empty rows</font> were detected and excluded from your data."));
+ smpl.nms <- smpl.nms[!empty.inx];
+ cls.lbl <- cls.lbl[!empty.inx];
+ conc <- conc[!empty.inx, ];
+ }
+
+ # try to check & remove empty lines if class label is empty
+ # Added by B. Han
+ empty.inx <- is.na(cls.lbl) | cls.lbl == ""
+ if(sum(empty.inx) > 0){
+ if(mSetObj$analSet$type != "roc"){
+ msg <- c(msg, paste("<font color=\"red\">", sum(empty.inx), "empty labels</font> were detected and excluded from your data."));
+ smpl.nms <- smpl.nms[!empty.inx];
+ cls.lbl <- cls.lbl[!empty.inx];
+ conc <- conc[!empty.inx, ];
+ }else{
+ # force all NA to empty string, otherwise NA will become "NA" class label
+ cls.lbl[is.na(cls.lbl)] <- "";
+ msg <- c(msg, paste("<font color=\"orange\">", sum(empty.inx), "new samples</font> were detected from your data."));
+ }
+ }
+
+ if(anal.type == "roc"){
+ if(length(unique(cls.lbl[!empty.inx])) > 2){
+ AddErrMsg("ROC analysis is only defined for two-group comparisions!");
+ return(0);
+ }
+ }
+
+ # check for uniqueness of dimension name
+ if(length(unique(smpl.nms))!=length(smpl.nms)){
+ dup.nm <- paste(smpl.nms[duplicated(smpl.nms)], collapse=" ");
+ AddErrMsg("Duplicate sample names are not allowed!");
+ AddErrMsg(dup.nm);
+ return(0);
+ }
+
+ # try to remove check & remove empty line if feature name is empty
+ empty.inx <- is.na(var.nms) | var.nms == "";
+ if(sum(empty.inx) > 0){
+ msg <- c(msg, paste("<font color=\"red\">", sum(empty.inx), "empty features</font> were detected and excluded from your data."));
+ var.nms <- var.nms[!empty.inx];
+ conc <- conc[,!empty.inx];
+ }
+
+ if(length(unique(var.nms))!=length(var.nms)){
+ dup.nm <- paste(var.nms[duplicated(var.nms)], collapse=" ");
+ AddErrMsg("Duplicate feature names are not allowed!");
+ AddErrMsg(dup.nm);
+ return(0);
+ }
+
+ if(anal.type == "mummichog"){
+ if(!is.rt){
+ mzs <- as.numeric(var.nms);
+ if(sum(is.na(mzs) > 0)){
+ AddErrMsg("Make sure that feature names are numeric values (mass or m/z)!");
+ return(0);
+ }
+ }
+ }
+
+ # now check for special characters in the data labels
+ if(sum(is.na(iconv(smpl.nms)))>0){
+ na.inx <- is.na(iconv(smpl.nms));
+ nms <- paste(smpl.nms[na.inx], collapse="; ");
+ AddErrMsg(paste("No special letters (i.e. Latin, Greek) are allowed in sample names!", nms, collapse=" "));
+ return(0);
+ }
+
+ if(sum(is.na(iconv(var.nms)))>0){
+ na.inx <- is.na(iconv(var.nms));
+ nms <- paste(var.nms[na.inx], collapse="; ");
+ AddErrMsg(paste("No special letters (i.e. Latin, Greek) are allowed in feature names!", nms, collapse=" "));
+ return(0);
+ }
+
+ # only keep alphabets, numbers, ",", "." "_", "-" "/"
+ orig.smp.nms <- smpl.nms;
+ smpl.nms <- CleanNames(smpl.nms, "sample_name");
+ names(orig.smp.nms) <- smpl.nms;
+
+ # keep a copy of original names for saving tables
+ orig.var.nms <- var.nms;
+ var.nms <- CleanNames(var.nms, "var_name"); # allow space, comma and period
+ names(orig.var.nms) <- var.nms;
+
+ cls.lbl <- ClearStrings(as.vector(cls.lbl));
+
+ # now assgin the dimension names
+ rownames(conc) <- smpl.nms;
+ colnames(conc) <- var.nms;
+
+ # check if paired or not
+ if(mSetObj$dataSet$paired){
+ # save as it is and process in sanity check step
+ mSetObj$dataSet$orig.cls <- mSetObj$dataSet$pairs <- cls.lbl;
+ } else {
+ if(lbl.type == "disc"){
+ # check for class labels at least two replicates per class
+ #if(min(table(cls.lbl)) < 3){
+ # AddErrMsg(paste ("A total of", length(levels(as.factor(cls.lbl))), "groups found with", length(smpl.nms), "samples."));
+ # AddErrMsg("At least three replicates are required in each group!");
+ # AddErrMsg("Or maybe you forgot to specify the data format?");
+ # return(0);
+ #}
+
+ mSetObj$dataSet$orig.cls <- mSetObj$dataSet$cls <- as.factor(as.character(cls.lbl));
+
+ if(substring(format,4,5)=="ts"){
+
+ mSetObj$dataSet$facA.type <- is.numeric(facA);
+ mSetObj$dataSet$orig.facA <- mSetObj$dataSet$facA <- as.factor(as.character(facA));
+ mSetObj$dataSet$facA.lbl <- facA.lbl;
+
+ mSetObj$dataSet$facB.type <- is.numeric(facB);
+ mSetObj$dataSet$orig.facB <- mSetObj$dataSet$facB <- as.factor(as.character(facB));
+ mSetObj$dataSet$facB.lbl <- facB.lbl;
+ }
+
+ }else{ # continuous
+
+ mSetObj$dataSet$orig.cls <- mSetObj$dataSet$cls <- tryCatch({
+ as.numeric(cls.lbl);
+ },warning=function(na) {
+ print("Class labels must be numeric and continuous!");
+ return(0);
+ })
+
+ if(mSetObj$dataSet$cls == 0){
+ AddErrMsg("Class labels must be numeric and continuous!");
+ return(0)
+ }
+ }
+ }
+
+ # for the current being to support MSEA and MetPA
+ if(mSetObj$dataSet$type == "conc"){
+ mSetObj$dataSet$cmpd <- var.nms;
+ }
+
+ mSetObj$dataSet$mumType <- "table";
+ mSetObj$dataSet$orig.var.nms <- orig.var.nms;
+ mSetObj$dataSet$orig.smp.nms <- orig.smp.nms;
+ #mSetObj$dataSet$orig <- conc; # copy to be processed in the downstream
+ qs::qsave(conc, file="data_orig.qs");
+ mSetObj$msgSet$read.msg <- c(msg, paste("The uploaded data file contains ", nrow(conc),
+ " (samples) by ", ncol(conc), " (", tolower(GetVariableLabel(mSetObj$dataSet$type)), ") data matrix.", sep=""));
+
+ return(.set.mSet(mSetObj));
+}
+
+#'Read paired peak or spectra files
+#'@description This function reads paired peak lists or spectra files. The pair information
+#'is stored in a file where each line is a pair and names are separated by ":".
+#'@param filePath Set file path
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+ReadPairFile <- function(filePath="pairs.txt"){
+ all.pairs <- scan(filePath, what='character', strip.white = T);
+ labels <- as.vector(rbind(1:length(all.pairs), -(1:length(all.pairs))));
+ all.names <- NULL;
+ for(i in 1:length(all.pairs)){
+ all.names=c(all.names, unlist(strsplit(all.pairs[i],":", fixed=TRUE), use.names=FALSE));
+ }
+ names(labels) <- all.names;
+ return(labels);
+}
+
+#'Save the processed data with class names
+#'@description This function saves the processed data with class names as CSV files.
+#'Several files may be generated, the original data, processed data, peak normalized, and/or normalized data.
+#'@param mSetObj Input name of the created mSet Object
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+SaveTransformedData <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+ data.type <- mSetObj$dataSet$type
+
+ # mummichog data is not processed, so just mSet$orig and mSet$proc
+
+ if(anal.type=="mummichog"){
+ fast.write.csv(mSetObj$dataSet$mummi.orig, file="data_original.csv", row.names = FALSE);
+ fast.write.csv(mSetObj$dataSet$mummi.proc, file="data_processed.csv", row.names = FALSE);
+ }else{
+ if(file.exists("data_orig.qs")){
+ lbls <- NULL;
+ tsFormat <- substring(mSetObj$dataSet$format,4,5)=="ts";
+ if(tsFormat){
+ lbls <- cbind(as.character(mSetObj$dataSet$orig.facA),as.character(mSetObj$dataSet$orig.facB));
+ colnames(lbls) <- c(mSetObj$dataSet$facA.lbl, mSetObj$dataSet$facB.lbl);
+ }else{
+ lbls <- cbind("Label"= as.character(mSetObj$dataSet$orig.cls));
+ }
+
+ orig.var.nms <- mSetObj$dataSet$orig.var.nms;
+ orig.data<- qs::qread("data_orig.qs");
+
+ # convert back to original names
+ if(!data.type %in% c("nmrpeak", "mspeak", "msspec")){
+ colnames(orig.data) <- orig.var.nms[colnames(orig.data)];
+ }
+ orig.data<-cbind(lbls, orig.data);
+
+ if(dim(orig.data)[2]>200){
+ orig.data<-t(orig.data);
+ }
+
+ fast.write.csv(orig.data, file="data_original.csv");
+
+ if(!is.null(mSetObj$dataSet[["proc"]])){
+
+ if(!is.null(mSetObj$dataSet[["filt"]])){
+ if(tsFormat){
+ lbls <- cbind(as.character(mSetObj$dataSet$filt.facA),as.character(mSetObj$dataSet$filt.facB));
+ colnames(lbls) <- c(mSetObj$dataSet$facA.lbl, mSetObj$dataSet$facB.lbl);
+ }else{
+ lbls <- cbind("Label"= as.character(mSetObj$dataSet$filt.cls));
+ }
+ proc.data<-mSetObj$dataSet$filt;
+ }else{
+ if(tsFormat){
+ lbls <- cbind(as.character(mSetObj$dataSet$proc.facA),as.character(mSetObj$dataSet$proc.facB));
+ colnames(lbls) <- c(mSetObj$dataSet$facA.lbl, mSetObj$dataSet$facB.lbl);
+ }else{
+ lbls <- cbind("Label"= as.character(mSetObj$dataSet$proc.cls));
+ }
+ proc.data<-mSetObj$dataSet$proc;
+ }
+
+ # convert back to original names
+ if(!data.type %in% c("nmrpeak", "mspeak", "msspec")){
+ colnames(proc.data) <- orig.var.nms[colnames(proc.data)];
+ }
+ proc.data<-cbind(lbls, proc.data);
+
+ if(dim(proc.data)[2]>200){
+ proc.data<-t(proc.data);
+ }
+ fast.write.csv(proc.data, file="data_processed.csv");
+
+ if(!is.null(mSetObj$dataSet[["norm"]])){
+ if(tsFormat){
+ lbls <- cbind(as.character(mSetObj$dataSet$facA),as.character(mSetObj$dataSet$facB));
+ colnames(lbls) <- c(mSetObj$dataSet$facA.lbl, mSetObj$dataSet$facB.lbl);
+ }else{
+ lbls <- cbind("Label"= as.character(mSetObj$dataSet$cls));
+ }
+
+ norm.data <- mSetObj$dataSet$norm;
+
+ # for ms peaks with rt and ms, insert two columns, without labels
+ # note in memory, features in columns
+ if(!is.null(mSetObj$dataSet$three.col)){
+ ids <- matrix(unlist(strsplit(colnames(norm.data), "/", fixed=TRUE)),ncol=2, byrow=T);
+ colnames(ids) <- c("mz", "rt");
+ new.data <- data.frame(ids, t(norm.data));
+ fast.write.csv(new.data, file="peak_normalized_rt_mz.csv");
+ }else{
+ # convert back to original names
+ if(!data.type %in% c("nmrpeak", "mspeak", "msspec")){
+ colnames(norm.data) <- orig.var.nms[colnames(norm.data)];
+ }
+ norm.data<-cbind(lbls, norm.data);
+ if(dim(norm.data)[2]>200){
+ norm.data<-t(norm.data);
+ }
+ fast.write.csv(norm.data, file="data_normalized.csv");
+ }
+ }
+ }
+ }
+ }
+ return(.set.mSet(mSetObj));
+}
+
+#' Adds an error message
+#'@description The error message will be printed in all cases.
+#'Used in higher functions.
+#'@param msg Error message to print
+#'@export
+AddErrMsg <- function(msg){
+ err.vec <<- c(err.vec, msg);
+ print(msg);
+}
+
+# general message only print when running local
+AddMsg <- function(msg){
+ msg.vec <<- c(msg.vec, msg);
+ if(!.on.public.web){
+ print(msg);
+ }
+}
+
+# return the latest message
+GetCurrentMsg <- function(){
+ return(msg.vec[length(msg.vec)]);
+}
+
+GetMetaCheckMsg <- function(mSetObj=NA){
+ return(current.msg);
+}
+
+#'Plot compound summary
+#'change to use dataSet$proc instead of dataSet$orig in
+#'case of too many NAs
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param cmpdNm Input the name of the compound to plot
+#'@param format Input the format of the image to create
+#'@param dpi Input the dpi of the image to create
+#'@param width Input the width of the image to create
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotCmpdSummary <- function(mSetObj=NA, cmpdNm, version, format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(.on.public.web){
+ load_ggplot()
+ load_grid()
+ }
+
+ imgName <- gsub("\\/", "_", cmpdNm);
+ imgName <- paste(imgName, "_", version, "_summary_dpi", dpi, ".", format, sep="");
+
+ if(is.na(width)){
+ w <- 7.5;
+ }else{
+ w <- width;
+ }
+
+ if(substring(mSetObj$dataSet$format,4,5)!="ts"){
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height= w*0.65, type=format, bg="white");
+
+ # need to consider norm data were edited, different from proc
+ smpl.nms <- rownames(mSetObj$dataSet$norm);
+
+ mns <- by(as.numeric(mSetObj$dataSet$proc[smpl.nms, cmpdNm]), mSetObj$dataSet$cls, mean, na.rm=T);
+ sds <- by(as.numeric(mSetObj$dataSet$proc[smpl.nms, cmpdNm]), mSetObj$dataSet$cls, sd, na.rm=T);
+
+ ups <- mns + sds;
+ dns <- mns - sds;
+
+ # all concentration need start from 0
+ y <- c(0, dns, mns, ups);
+
+ rg <- range(y) + 0.05 * diff(range(y)) * c(-1, 1)
+ pt <- pretty(y)
+
+ axp=c(min(pt), max(pt[pt <= max(rg)]),length(pt[pt <= max(rg)]) - 1);
+
+ # ggplot alternative
+ col <- unique(GetColorSchema(mSetObj$dataSet$cls));
+
+ df.orig <- data.frame(value = as.vector(mns), name = levels(mSetObj$dataSet$cls), up = as.vector(ups), down = as.vector(dns))
+ p.orig <- ggplot(df.orig, aes(x = name, y = value, fill = name)) + geom_bar(stat = "identity", colour = "black") + theme_bw()
+ p.orig <- p.orig + scale_y_continuous(breaks=pt, limits = range(pt)) + ggtitle("Original Conc.")
+ p.orig <- p.orig + theme(plot.title = element_text(size = 11, hjust=0.5)) + theme(axis.text.x = element_text(angle=90, hjust=1))
+ p.orig <- p.orig + theme(axis.title.x = element_blank(), axis.title.y = element_blank(), legend.position = "none")
+ p.orig <- p.orig + theme(panel.grid.minor = element_blank(), panel.grid.major = element_blank()) # remove gridlines
+ p.orig <- p.orig + geom_segment(aes(xend=name, y=up, yend=dns)) + scale_fill_manual(values=col)
+ p.orig <- p.orig + theme(plot.margin = margin(t=0.35, r=0.5, b=0.15, l=0.15, "cm"), axis.text = element_text(size=10))
+
+ df.norm <- data.frame(value=mSetObj$dataSet$norm[, cmpdNm], name = mSetObj$dataSet$cls)
+ p.norm <- ggplot2::ggplot(df.norm, aes(x=name, y=value, fill=name)) + geom_boxplot(notch=FALSE, outlier.shape = NA, outlier.colour=NA) + theme_bw() + geom_jitter(size=1)
+ p.norm <- p.norm + theme(axis.title.x = element_blank(), axis.title.y = element_blank(), legend.position = "none")
+ p.norm <- p.norm + stat_summary(fun.y=mean, colour="yellow", geom="point", shape=18, size=3, show.legend = FALSE)
+ p.norm <- p.norm + scale_fill_manual(values=col) + ggtitle(cmpdNm) + theme(axis.text.x = element_text(angle=90, hjust=1))
+ p.norm <- p.norm + ggtitle("Normalized Conc.") + theme(plot.title = element_text(size = 11, hjust=0.5))
+ p.norm <- p.norm + theme(panel.grid.minor = element_blank(), panel.grid.major = element_blank()) # remove gridlines
+ p.norm <- p.norm + theme(plot.margin = margin(t=0.35, r=0.25, b=0.15, l=0.5, "cm"), axis.text = element_text(size=10))
+
+ gridExtra::grid.arrange(p.orig, p.norm, ncol=2, top = grid::textGrob(paste(cmpdNm), gp=grid::gpar(fontsize=14, fontface="bold")))
+
+ dev.off();
+
+ }else if(mSetObj$dataSet$design.type =="time0"){
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=8, height= 6, type=format, bg="white");
+ plotProfile(mSetObj, cmpdNm);
+ dev.off();
+
+ }else{
+ if(mSetObj$dataSet$design.type =="time"){ # time trend within phenotype
+ out.fac <- mSetObj$dataSet$exp.fac;
+ in.fac <- mSetObj$dataSet$time.fac;
+ xlab = "Time";
+ }else{ # factor a split within factor b
+ out.fac <- mSetObj$dataSet$facB;
+ in.fac <- mSetObj$dataSet$facA;
+ xlab = mSetObj$dataSet$facA.lbl;
+ }
+
+ # two images per row
+ img.num <- length(levels(out.fac));
+ row.num <- ceiling(img.num/2)
+
+ if(row.num == 1){
+ h <- w*5/9;
+ }else{
+ h <- w*0.5*row.num;
+ }
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+
+ col <- unique(GetColorSchema(in.fac));
+
+ p_all <- list()
+
+ for(lv in levels(out.fac)){
+ inx <- out.fac == lv;
+ df.orig <- data.frame(facA = lv, value = mSetObj$dataSet$norm[inx, cmpdNm], name = in.fac[inx])
+ p_all[[lv]] <- df.orig
+ }
+
+ alldata <- do.call(rbind, p_all)
+
+ p.time <- ggplot2::ggplot(alldata, aes(x=name, y=value, fill=name)) + geom_boxplot(outlier.shape = NA, outlier.colour=NA) + theme_bw() + geom_jitter(size=1)
+ p.time <- p.time + facet_wrap(~facA, nrow = row.num) + theme(axis.title.x = element_blank(), legend.position = "none")
+ p.time <- p.time + scale_fill_manual(values=col) + theme(axis.text.x = element_text(angle=90, hjust=1))
+ p.time <- p.time + ggtitle(cmpdNm) + theme(plot.title = element_text(size = 11, hjust=0.5, face = "bold")) + ylab("Abundance")
+ p.time <- p.time + theme(panel.grid.minor = element_blank(), panel.grid.major = element_blank()) # remove gridlines
+ p.time <- p.time + theme(plot.margin = margin(t=0.15, r=0.25, b=0.15, l=0.25, "cm"), axis.text = element_text(size=10))
+
+ print(p.time)
+ dev.off()
+ }
+
+ if(.on.public.web){
+ return(imgName);
+ }else{
+ return(.set.mSet(mSetObj));
+ }
+}
+
+
+##############################################
+##############################################
+########## Utilities for web-server ##########
+##############################################
+##############################################
+
+GetErrMsg<-function(){
+ return(err.vec);
+}
+
+#'Save compound name for mapping
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param qvec Input the vector to query
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+Setup.MapData1 <- function(mSetObj=NA, qvec){
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$dataSet$cmpd <- qvec;
+ return(.set.mSet(mSetObj));
+}
+
+GetMetaInfo <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ if(mSetObj$dataSet$design.type == "regular"){
+ return("Group");
+ }else{
+ return(c(mSetObj$dataSet$facA.lbl, mSetObj$dataSet$facB.lbl));
+ }
+}
+
+# all groups
+GetGroupNames <- function(mSetObj=NA, exp.fac=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ if(mSetObj$dataSet$design.type == "regular"){
+ cls.lbl <- mSetObj$dataSet$prenorm.cls;
+ if(mSetObj$analSet$type=="roc"){
+ empty.inx <- is.na(cls.lbl) | cls.lbl == "";
+ # make sure re-factor to drop level
+ my.cls <- factor(cls.lbl[!empty.inx]);
+ }else{
+ my.cls <- cls.lbl;
+ }
+ }else{
+ if(exp.fac == mSetObj$dataSet$facA.lbl){
+ my.cls <- mSetObj$dataSet$facA;
+ }else{
+ my.cls <- mSetObj$dataSet$facB;
+ }
+ my.fac <- exp.fac;
+ }
+ current.cls <<- my.cls;
+ return(levels(my.cls));
+}
+
+# groups entering analysis
+GetNormGroupNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ levels(mSetObj$dataSet$cls);
+}
+
+GetLiteralGroupNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ as.character(mSetObj$dataSet$prenorm.cls);
+}
+
+GetFilesToBeSaved <-function(naviString){
+ partialToBeSaved <- c("Rload.RData");
+ return(unique(partialToBeSaved));
+}
+
+GetExampleDataPath<-function(naviString){
+ return(url.pre);
+}
+
+Read.TextDataMumMixed <- function(mSetObj=NA, filePath,filePath2, format="rowu", lbl.type="disc", order=NULL){
+
+ temp_mSet1 <- Read.TextData(NA, filePath, format, lbl.type)
+ temp_mSet1 <- .get.mSet(mSetObj);
+ qs::qsave(temp_mSet1, file="data_orig_temp1.qs");
+
+ temp_mSet1 <- qs::qread("data_orig_temp1.qs");
+ orig1 <- qs::qread("data_orig.qs");
+
+ temp_mSet2 <- Read.TextData(NA, filePath2, format, lbl.type)
+ temp_mSet2 <-.get.mSet(mSetObj);
+ orig2 <- qs::qread("data_orig.qs");
+ mSetObj <- temp_mSet1
+ mSetObj$dataSet$mumType <- "table";
+ mSetObj$dataSet$orig.var.nms <- c(mSetObj$dataSet$orig.var.nms, temp_mSet2$dataSet$orig.var.nms);
+ mSetObj$dataSet$mode <- "mixed"
+ orig <- cbind(orig1, orig2);
+ mSetObj$dataSet$pos_inx <- c(rep(TRUE, ncol(orig1)), rep(FALSE, ncol(orig2)))
+ qs::qsave(orig, file="data_orig.qs");
+ .set.mSet(mSetObj)
+
+ return(1);
+}
+
+
+TableFormatCoerce <- function(oriFile = NULL, oriFormat = "Unknown", targetModule = "mummichog", sampleIn = "col"){
+
+ df <- read.csv(oriFile);
+ df[is.na(df)] <- df[df == ""] <- 0;
+
+ if (targetModule == "mummichog") {
+ ## This is used to convert the data format from Spectral Processing to Mummichog
+ if (oriFormat == "OptiLCMS") {
+ if (sampleIn == "col") {
+ newFea <- strsplit(df[, 1], "@")
+
+ newFea <- lapply(newFea, function(x) {
+ return(paste0(x[1], "__", x[2]))
+ })
+ } else {
+ # cannot be in row for OptiLCMS source
+ }
+
+ df[, 1] <- unlist(newFea)
+ df[1, 1] <- "Label"
+ }
+ }
+
+ write.csv(df, file = oriFile, quote = FALSE, row.names = FALSE)
+
+}
+
+################################################################################################
+################# First create table of all studies with named metabolites #####################
+################################################################################################
+
+#'Function to retrieve all available datasets from the Metabolomics Workbench.
+#'@description This function uses the httr R package to make an API
+#'call to the Metabolomics Workbench to retrieve a table of
+#'all compatible datasets.
+#'@usage ListNMDRStudies(mSetObj=NA)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects).
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}, Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+ListNMDRStudies <- function(mSetObj=NA){
+
+ # The Metabolomics Workbench API url
+ call <- "https://www.metabolomicsworkbench.org/rest/study/study_id/ST/named_metabolites"
+
+ # Use httr::GET to send the request to the Metabolomics Workbench API
+ # The response will be saved in query_results
+ query_results <- httr::GET(call, encode = "json")
+
+ # Check if response is ok
+ # 200 is ok! 401 means an error has occured on the user's end.
+ if(query_results$status_code!=200){
+ AddErrMsg("REST url to Metabolomics Workbench failed!")
+ return(0)
+ }
+
+ # Parse the response into a table
+ query_results_text <- content(query_results, "text", encoding = "UTF-8")
+ query_results_json <- RJSONIO::fromJSON(query_results_text, flatten = TRUE)
+ query_results_table <- t(rbind.data.frame(query_results_json))
+ rownames(query_results_table) <- query_results_table[,1]
+
+ # Keep studies with > 10 metabolites
+ num_metabolites <- as.numeric(query_results_table[,"num_metabolites"])
+ keep.inx <- num_metabolites > 10
+ query_results_table_keep <- query_results_table[keep.inx, ]
+ query_results_table_keep <- subset(query_results_table_keep, select = - c(analysis_id, analysis_type,
+ num_metabolites,
+ ms_type, units))
+
+ query_results_table_keep <- data.frame(query_results_table_keep)
+
+ load_stringr()
+ query_results_table_keep$lipid <- stringr::str_detect(query_results_table_keep$study_title, fixed("lipid", ignore_case=TRUE))
+
+ mSetObj$dataSet$NMDR_studies <- query_results_table_keep
+
+ if(!.on.public.web){
+ fast.write.csv(query_results_table_keep, "all_metabolomics_workbench_studies.csv")
+ }else{
+ qs::qsave(query_results_table_keep, "metabolomics_workbench_studies.qs")
+ }
+
+ return(.set.mSet(mSetObj));
+}
+
+##################################################################################################
+################# Now using the StudyID download the study dataset as matrix #####################
+##################################################################################################
+
+#'Function to retrieve dataset from the Metabolomics Workbench.
+#'@description This function uses the httr R package to make an API
+#'call to the Metabolomics Workbench to download and save a dataset
+#'based on the Study ID into the current working directory.
+#'@usage GetNMDRStudy(mSetObj=NA, StudyID)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects).
+#'@param StudyID Input the StudyID of the study from the Metabolomics Workbench.
+#'Use the ListNMDRStudies function to obtain a list of all available studies
+#'from the Metabolomics Workbench.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}, Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+GetNMDRStudy <- function(mSetObj=NA, StudyID){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ check.inx <- nchar(StudyID) == 8 & grep("ST", StudyID)
+
+ if(!check.inx){
+ AddErrMsg("Error! Invalid Study ID selected!")
+ return(0)
+ }
+
+ mSetObj$dataSet$NMDR_id <- StudyID
+
+ load_httr()
+ call <- paste0("https://www.metabolomicsworkbench.org/rest/study/study_id/", StudyID, "/metaboanalyst")
+
+ # set timeout to 45 seconds
+ query_results <- httr::GET(call, encode = "json", timeout = 45)
+
+ if(query_results$status_code!=200){
+ AddErrMsg("Error! REST url to Metabolomics Workbench failed!")
+ return(0)
+ }
+
+ # Parse the response into a table
+ query_results_text <- content(query_results, "text", encoding = "UTF-8")
+ query_study_dataset <- read.delim(text = query_results_text, header = T, check.names = F)
+
+ if(nrow(query_study_dataset) < 3){
+ AddErrMsg("Error! Selected study does not have enough samples for downstream statistical analyses!")
+ return(0)
+ }
+
+ if(ncol(query_study_dataset) < 3){
+ AddErrMsg("Error! Selected study does not have enough features for downstream statistical analyses!")
+ return(0)
+ }
+
+ qs::qsave(query_study_dataset, "nmdr_study.qs")
+
+ return(.set.mSet(mSetObj));
+}
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/general_lib_utils.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/general_lib_utils.R
new file mode 100755
index 0000000000000000000000000000000000000000..d3dd4316c723eaf4a975de4a6fd3d6f7061fcd83
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/general_lib_utils.R
@@ -0,0 +1,223 @@
+library(qs)
+library(Rcpp)
+library(RcppParallel)
+#The above two lines were added by ZZY on 3/5/2021.
+
+#Read RDS files from the internet
+#' @description Function downloads the required file and reads it only if not already in working directory.
+#' Need to specify the file URL and the destfile.
+#' @param filenm Input the name of the file to download
+
+# read binary qs files
+# sub.dir is sub folder, leave NULL is under main lib folder
+.get.my.lib <- function(filenm, sub.dir=NULL){
+
+ if(!is.null(sub.dir)){
+ sub.dir <- paste0(sub.dir, "/");
+ }
+ if(.on.public.web){
+ lib.path <- paste0("../../libs/", sub.dir, filenm);
+ print(paste("loading library:", lib.path));
+ return(qs::qread(lib.path));
+ }
+
+ lib.download <- FALSE;
+ if(!file.exists(filenm)){
+ lib.download <- TRUE;
+ }else{
+ time <- file.info(filenm)
+ diff_time <- difftime(Sys.time(), time[,"mtime"], unit="days")
+ if(diff_time>30){
+ lib.download <- TRUE;
+ }
+ }
+
+ lib.url <- paste0("https://www.metaboanalyst.ca/resources/libs/", sub.dir, filenm);
+ # Deal with curl issues
+ if(lib.download){
+ tryCatch(
+ {
+ download.file(lib.url, destfile=filenm, method="curl")
+ }, warning = function(w){ print() },
+ error = function(e) {
+ print("Download unsucceful. Ensure that curl is downloaded on your computer.")
+ print("Attempting to re-try download using libcurl...")
+ download.file(lib.url, destfile=filenm, method="libcurl")
+ }
+ )
+ }
+ lib.path <- filenm;
+
+
+ # Deal w. corrupt downloaded files
+ tryCatch({
+ my.lib <- qs::qread(lib.path); # this is a returned value, my.lib never called outside this function, should not be in global env.
+# print("Loaded files from MetaboAnalyst web-server.") #Disabled by ZZY on 7/30/21.
+ },
+ warning = function(w) { print() },
+ error = function(err) {
+ print("Reading data unsuccessful, attempting to re-download file...")
+ tryCatch({
+ download.file(lib.url, destfile=filenm, method="curl")
+ my.lib <- qs::qread(lib.path);
+ print("Loaded necessary files.")
+ },
+ warning = function(w) { print() },
+ error = function(err) {
+ print("Loading files from server unsuccessful. Ensure curl is downloaded on your computer.")
+ }
+ )
+ })
+ return(my.lib);
+}
+
+.getDynLoadPath <- function() {
+ if(file.exists("/home/glassfish/payara5/glassfish/domains/domain1/applications/MetaboAnalyst/resources/rscripts/metaboanalystr/src/MetaboAnalyst.so")){
+ path = "/home/glassfish/payara5/glassfish/domains/domain1/applications/MetaboAnalyst/resources/rscripts/metaboanalystr/src/MetaboAnalyst.so";
+ }else if(dir.exists("/media/zzggyy/disk")){
+ path <- "/media/zzggyy/disk/MetaboAnalyst/target/MetaboAnalyst-5.18/resources/rscripts/metaboanalystr/src/MetaboAnalyst.so"
+ }else if(.on.public.web){
+ path = "../../rscripts/metaboanalystr/src/MetaboAnalyst.so";
+ }
+ return(path)
+}
+
+# Load lattice, necessary for power analysis
+load_lattice <- function(){
+ suppressMessages(library(lattice))
+}
+
+# Load igraph, necessary for network analysis
+load_igraph <- function(){
+ suppressMessages(library(igraph))
+}
+
+# Load reshape, necessary for graphics
+load_reshape <- function(){
+ suppressMessages(library(reshape))
+}
+
+# Load gplots, necessary for heatmap
+load_gplots <- function(){
+ suppressMessages(library(gplots))
+}
+
+# Load R color brewer, necessary for heatmap
+load_rcolorbrewer <- function(){
+ suppressMessages(library(RColorBrewer))
+}
+
+# Load RSQLite, necessary for network analysis
+load_rsqlite <- function(){
+ suppressMessages(library(RSQLite))
+}
+
+# Load caret, necessary for stats module
+load_caret <- function(){
+ suppressMessages(library(caret))
+}
+
+# Load pls, necessary for stats module
+load_pls <- function(){
+ suppressMessages(library(pls))
+}
+
+# Load KEGGgraph
+load_kegggraph <- function(){
+ suppressMessages(library(KEGGgraph))
+}
+
+# Load RGraphviz
+load_rgraphwiz <- function(){
+ suppressMessages(library(Rgraphviz))
+}
+
+# Load data.table
+load_data.table <- function(){
+ suppressMessages(library(data.table))
+}
+
+# Load Biobase
+load_biobase <- function(){
+ suppressMessages(library(Biobase))
+}
+
+# Load MSnbase
+load_msnbase <- function(){
+ suppressMessages(library(MSnbase))
+}
+
+# Load progress
+load_progress <- function(){
+ suppressMessages(library(progress))
+}
+
+# Load graph
+load_graph <- function(){
+ suppressMessages(library(graph))
+}
+
+# Load RBGL
+load_RBGL <- function(){
+ suppressMessages(library(RBGL))
+}
+
+# Load ggplot2
+load_ggplot <- function(){
+ suppressMessages(library(ggplot2))
+}
+
+# Load gridExtra
+load_grid <- function(){
+ suppressMessages(library(gridExtra))
+ suppressMessages(library(grid))
+}
+
+# Load camera
+load_camera <- function(){
+ suppressMessages(library(CAMERA))
+}
+
+# Load stringr
+load_stringr <- function(){
+ suppressMessages(library(stringr))
+}
+
+# Load httr
+load_httr <- function(){
+ suppressMessages(library(httr))
+}
+
+# Load BiocParallel
+load_biocparallel <- function(){
+ suppressMessages(library(BiocParallel))
+}
+
+# Load RSclient
+load_RSclient <- function(){
+ installed <- c("RSclient") %in% rownames(installed.packages())
+ if(installed){
+ suppressMessages(library(RSclient))
+ }else{
+ print("Please install RSclient R package!")
+ }
+}
+
+# Load Rserve - need to open only 1 instance for R package users
+load_Rserve <- function(){
+
+ installed <- c("Rserve") %in% rownames(installed.packages())
+
+ if(installed){
+ # first need to start up an Rserve instance
+ suppressMessages(library(Rserve))
+ Rserve::Rserve(args = "--no-save")
+ }else{
+ print("Please install Rserve R package!")
+ }
+}
+
+# load mzR
+load_mzR <- function(){
+ library(mzR);
+}
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/general_load_libs.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/general_load_libs.R
new file mode 100755
index 0000000000000000000000000000000000000000..a7d50502a869b1c5fbe42fcdb96617c12511bc7c
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/general_load_libs.R
@@ -0,0 +1,105 @@
+# Load lattice, necessary for power analysis
+load_lattice <- function(){
+ suppressMessages(library(lattice))
+}
+
+# Load igraph, necessary for network analysis
+load_igraph <- function(){
+ suppressMessages(library(igraph))
+}
+
+# Load reshape, necessary for graphics
+load_reshape <- function(){
+ suppressMessages(library(reshape))
+}
+
+# Load gplots, necessary for heatmap
+load_gplots <- function(){
+ suppressMessages(library(gplots))
+}
+
+# Load R color brewer, necessary for heatmap
+load_rcolorbrewer <- function(){
+ suppressMessages(library(RColorBrewer))
+}
+
+# Load RSQLite, necessary for network analysis
+load_rsqlite <- function(){
+ suppressMessages(library(RSQLite))
+}
+
+# Load caret, necessary for stats module
+load_caret <- function(){
+ suppressMessages(library(caret))
+}
+
+# Load pls, necessary for stats module
+load_pls <- function(){
+ suppressMessages(library(pls))
+}
+
+# Load KEGGgraph
+load_kegggraph <- function(){
+ suppressMessages(library(KEGGgraph))
+}
+
+# Load RGraphviz
+load_rgraphwiz <- function(){
+ suppressMessages(library(Rgraphviz))
+}
+
+
+# Load data.table
+load_data.table <- function(){
+ suppressMessages(library(data.table))
+}
+
+# Load ggplot2
+load_ggplot <- function(){
+ suppressMessages(library(ggplot2))
+}
+
+# Load gridExtra
+load_grid <- function(){
+ suppressMessages(library(gridExtra))
+ suppressMessages(library(grid))
+}
+
+# Load camera
+load_camera <- function(){
+ suppressMessages(library(CAMERA))
+}
+
+# Load stringr
+load_stringr <- function(){
+ suppressMessages(library(stringr))
+}
+
+# Load httr
+load_httr <- function(){
+ suppressMessages(library(httr))
+}
+
+# Load RSclient
+load_RSclient <- function(){
+ installed <- c("RSclient") %in% rownames(installed.packages())
+ if(installed){
+ suppressMessages(library(RSclient))
+ }else{
+ print("Please install RSclient R package!")
+ }
+}
+
+# Load Rserve - need to open only 1 instance for R package users
+load_Rserve <- function(){
+
+ installed <- c("Rserve") %in% rownames(installed.packages())
+
+ if(installed){
+ # first need to start up an Rserve instance
+ suppressMessages(library(Rserve))
+ Rserve::Rserve(args = "--no-save")
+ }else{
+ print("Please install Rserve R package!")
+ }
+}
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/general_misc_utils.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/general_misc_utils.R
new file mode 100755
index 0000000000000000000000000000000000000000..4b3109e2d328621152cf38d39c4addfbe2d32b46
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/general_misc_utils.R
@@ -0,0 +1,1086 @@
+### Perform miscellaneous tasks
+### Perform misc tasks
+### Jeff Xia\email{jeff.xia@mcgill.ca}
+### McGill University, Canada
+###License: GNU GPL (>= 2)
+
+# Limit of detection (1/5 of min for each var)
+.replace.by.lod <- function(x){
+ lod <- min(x[x>0], na.rm=T)/5;
+ x[x==0|is.na(x)] <- lod;
+ return(x);
+}
+
+ReplaceMissingByLoD <- function(int.mat){
+ int.mat <- as.matrix(int.mat);
+ rowNms <- rownames(int.mat);
+ colNms <- colnames(int.mat);
+ int.mat <- apply(int.mat, 2, .replace.by.lod);
+ rownames(int.mat) <- rowNms;
+ colnames(int.mat) <- colNms;
+ return (int.mat);
+}
+
+#'Given a data with duplicates, remove duplicates
+#'@description Dups is the one with duplicates
+#'@param data Input data to remove duplicates
+#'@param lvlOpt Set options, default is mean
+#'@param quiet Set to quiet, logical, default is T
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+RemoveDuplicates <- function(data, lvlOpt="mean", quiet=T){
+
+ all.nms <- rownames(data);
+ colnms <- colnames(data);
+ dup.inx <- duplicated(all.nms);
+ dim.orig <- dim(data);
+ data <- apply(data, 2, as.numeric); # force to be all numeric
+ dim(data) <- dim.orig; # keep dimension (will lost when only one item)
+ rownames(data) <- all.nms;
+ colnames(data) <- colnms;
+ if(sum(dup.inx) > 0){
+ uniq.nms <- all.nms[!dup.inx];
+ uniq.data <- data[!dup.inx,,drop=F];
+
+ dup.nms <- all.nms[dup.inx];
+ uniq.dupnms <- unique(dup.nms);
+ uniq.duplen <- length(uniq.dupnms);
+
+ for(i in 1:uniq.duplen){
+ nm <- uniq.dupnms[i];
+ hit.inx.all <- which(all.nms == nm);
+ hit.inx.uniq <- which(uniq.nms == nm);
+
+ # average the whole sub matrix
+ if(lvlOpt == "mean"){
+ uniq.data[hit.inx.uniq, ]<- apply(data[hit.inx.all,,drop=F], 2, mean, na.rm=T);
+ }else if(lvlOpt == "median"){
+ uniq.data[hit.inx.uniq, ]<- apply(data[hit.inx.all,,drop=F], 2, median, na.rm=T);
+ }else if(lvlOpt == "max"){
+ uniq.data[hit.inx.uniq, ]<- apply(data[hit.inx.all,,drop=F], 2, max, na.rm=T);
+ }else{ # sum
+ uniq.data[hit.inx.uniq, ]<- apply(data[hit.inx.all,,drop=F], 2, sum, na.rm=T);
+ }
+ }
+ AddMsg(paste("A total of ", sum(dup.inx), " of duplicates were replaced by their ", lvlOpt, ".", sep=""));
+ return(uniq.data);
+ }else{
+ AddMsg("All IDs are unique.");
+ return(data);
+ }
+}
+
+# in public web, this is done by microservice
+.perform.computing <- function(){
+ dat.in <- qs::qread("dat.in.qs");
+ dat.in$my.res <- dat.in$my.fun();
+ qs::qsave(dat.in, file="dat.in.qs");
+}
+
+#'Read data table
+#'@description Function to read in a data table. First, it will try to use fread, however, it has issues with
+#'some windows 10 files. In such case, use the slower read.table method.
+#'@param fileName Input filename
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+.readDataTable <- function(fileName){
+
+ dat <- tryCatch(
+ {
+ data.table::fread(fileName, header=TRUE, check.names=FALSE, blank.lines.skip=TRUE, data.table=FALSE);
+ }, error=function(e){
+ print(e);
+ return(.my.slowreaders(fileName));
+ }, warning=function(w){
+ print(w);
+ return(.my.slowreaders(fileName));
+ });
+
+ if(any(dim(dat) == 0)){
+ dat <- .my.slowreaders(fileName);
+ }
+ return(dat);
+}
+
+.my.slowreaders <- function(fileName){
+ print("Using slower file reader ...");
+ formatStr <- substr(fileName, nchar(fileName)-2, nchar(fileName))
+ if(formatStr == "txt"){
+ dat <- try(read.table(fileName, header=TRUE, comment.char = "", check.names=F, as.is=T));
+ }else{ # note, read.csv is more than read.table with sep=","
+ dat <- try(read.csv(fileName, header=TRUE, comment.char = "", check.names=F, as.is=T));
+ }
+ return(dat);
+}
+
+.get.sqlite.con <- function(sqlite.path){
+ load_rsqlite();
+ return(dbConnect(SQLite(), sqlite.path));
+}
+
+#'Permutation
+#'@description Perform permutation, options to change number of cores used
+#'@param perm.num Numeric, input the number of permutations to perform
+#'@param fun Dummy function
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@usage Perform.permutation(perm.num, fun)
+#'@export
+#'
+Perform.permutation <- function(perm.num, fun){
+
+ # for public server, perm.num is not always followed to make sure loop will not continue for very long time
+ # before the adventure, see how long it takes for 10 permutations
+ # if it is extremely slow (>60 sec) => max 20 (<0.05)
+ # if it is very slow (30-60 sec) => max 100 (<0.01)
+
+ start.num <- 1;
+ perm.res <- NULL;
+ if(.on.public.web & perm.num > 20){
+ start.time <- Sys.time();
+ perm.res <- lapply(1:10, fun);
+ end.time <- Sys.time();
+
+ time.taken <- end.time - start.time;
+ print(paste("time taken for 10 permutations: ", time.taken));
+
+ if(time.taken > 60){
+ perm.num <- 20;
+ }else if(time.taken > 30){
+ perm.num <- 100;
+ }
+ start.num <- 11;
+ }
+ print(paste("performing", perm.num, "permutations ..."));
+ perm.res <- c(perm.res, lapply(start.num:perm.num, fun));
+ return(list(perm.res=perm.res, perm.num = perm.num));
+}
+
+#'Unzip .zip files
+#'@description Unzips uploaded .zip files, removes the uploaded file, checks for success
+#'@param inPath Input the path of the zipped files
+#'@param outPath Input the path to directory where the unzipped files will be deposited
+#'@param rmFile Logical, input whether or not to remove files. Default set to T
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+UnzipUploadedFile<-function(inPath, outPath, rmFile=T){
+ sys.cmd <- paste("unzip", "-o", inPath, "-d", outPath);
+ #print(sys.cmd);
+ sys.res <- try(system(sys.cmd));
+ if(sys.res == 0){ # success code for system call
+ return (1);
+ }else{ # success code for system call
+ print(sys.res);
+ r.res <- unzip(inPath, exdir=outPath);
+ return(length(r.res)>0);
+ }
+}
+
+#'Perform data cleaning
+#'@description Cleans data and removes -Inf, Inf, NA, negative and 0s.
+#'@param bdata Input data to clean
+#'@param removeNA Logical, T to remove NAs, F to not.
+#'@param removeNeg Logical, T to remove negative numbers, F to not.
+#'@param removeConst Logical, T to remove samples/features with 0s, F to not.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'
+
+CleanData <-function(bdata, removeNA=T, removeNeg=T, removeConst=T){
+
+ if(sum(bdata==Inf, na.rm=TRUE)>0){
+ inx <- bdata == Inf;
+ bdata[inx] <- NA;
+ bdata[inx] <- max(bdata, na.rm=T)*2
+ }
+ if(sum(bdata==-Inf, na.rm=TRUE)>0){
+ inx <- bdata == -Inf;
+ bdata[inx] <- NA;
+ bdata[inx] <- min(bdata, na.rm=T)/2
+ }
+ if(removeNA){
+ if(sum(is.na(bdata))>0){
+ bdata[is.na(bdata)] <- min(bdata, na.rm=T)/2
+ }
+ }
+ if(removeNeg){
+ if(sum(as.numeric(bdata<=0)) > 0){
+ inx <- bdata <= 0;
+ bdata[inx] <- NA;
+ bdata[inx] <- min(bdata, na.rm=T)/2
+ }
+ }
+ if(removeConst){
+ varCol <- apply(data.frame(bdata), 2, var, na.rm=T); # getting an error of dim(X) must have a positive length, fixed by data.frame
+ constCol <- (varCol == 0 | is.na(varCol));
+ constNum <- sum(constCol, na.rm=T);
+ if(constNum > 0){
+ bdata <- data.frame(bdata[,!constCol, drop=FALSE], check.names = F); # got an error of incorrect number of dimensions, added drop=FALSE to avoid vector conversion
+ }
+ }
+ bdata;
+}
+
+#'Replace infinite numbers
+#'@description Replace -Inf, Inf to 99999 and -99999
+#'@param bdata Input matrix to clean numbers
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'
+CleanNumber <-function(bdata){
+ if(sum(bdata==Inf)>0){
+ inx <- bdata == Inf;
+ bdata[inx] <- NA;
+ bdata[inx] <- 999999;
+ }
+ if(sum(bdata==-Inf)>0){
+ inx <- bdata == -Inf;
+ bdata[inx] <- NA;
+ bdata[inx] <- -999999;
+ }
+ bdata;
+}
+
+# only keep alphabets, numbers, ",", "." "_", "-" "/"
+# note, this may leads to duplicate names
+CleanNames <- function(query, type){
+
+ if(type=="sample_name"){
+ query <- gsub("[^[:alnum:]./_-]", "", query);
+ }else{
+ query <- gsub("[^[:alnum:][:space:],'./_./@-]", "", query)
+ }
+ return(make.unique(query));
+}
+
+#'Remove spaces
+#'@description Remove from, within, leading and trailing spaces
+#'@param query Input the query to clear
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+ClearStrings<-function(query){
+ # kill multiple white space
+ query <- gsub(" +"," ",query);
+ # remove leading and trailing space
+ query<- sub("^[[:space:]]*(.*?)[[:space:]]*$", "\\1", query, perl=TRUE);
+ return(query);
+}
+
+# Remove HTML tag
+PrepareLatex <- function(stringVec){
+ stringVec <- gsub("<(.|\n)*?>","",stringVec);
+ stringVec <- gsub("%", "\\\\%", stringVec);
+ stringVec;
+}
+
+#'Determine value label for plotting
+#'@description Concentration or intensity data type
+#'@param data.type Input concentration or intensity data
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+GetAbundanceLabel<-function(data.type){
+ if(data.type=="conc"){
+ return("Concentration");
+ }else {
+ return("Intensity");
+ }
+}
+
+#'Determine variable label for plotting
+#'@description Determine data type, binned spectra, nmr peak, or ms peak
+#'@param data.type Input the data type
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+GetVariableLabel<-function(data.type){
+ if(data.type=="conc"){
+ return("Compounds");
+ }else if(data.type=="specbin"){
+ return("Spectra Bins");
+ }else if(data.type=="nmrpeak"){
+ return("Peaks (ppm)");
+ }else if(data.type=="mspeak"){
+ return("Peaks (mass)");
+ }else{
+ return("Peaks(mz/rt)");
+ }
+}
+
+#'Create Latex table
+#'@description generate Latex table
+#'@param mat Input matrix
+#'@param method Input method to create table
+#'@param data.type Input the data type
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+GetSigTable<-function(mat, method, data.type){
+ if(!isEmptyMatrix(mat)){ # test if empty
+ cap<-"Important features identified by";
+ if(nrow(mat)>50){
+ smat<-as.matrix(mat[1:50,]); # only print top 50 if too many
+ colnames(smat)<-colnames(mat); # make sure column names are also copied
+ mat<-smat;
+ cap<-"Top 50 features identified by";
+ }
+ # change the rowname to first column
+ col1<-rownames(mat);
+ cname<-colnames(mat);
+ cname<-c(GetVariableLabel(data.type), cname);
+ mat<-cbind(col1, mat);
+ rownames(mat)<-NULL;
+ colnames(mat)<-cname;
+ print(xtable::xtable(mat, caption=paste(cap, method)), caption.placement="top", size="\\scriptsize");
+ }else{
+ print(paste("No significant features were found using the given threshold for", method));
+ }
+}
+
+#'Sig table matrix is empty
+#'@description Test if a sig table matrix is empty
+#'@param mat Matrix to test if empty
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+isEmptyMatrix <- function(mat){
+ if(is.null(mat) | length(mat)==0){
+ return(TRUE);
+ }
+ if(nrow(mat)==0 | ncol(mat)==0){
+ return(TRUE);
+ }
+ if(is.na(mat[1,1])){
+ return(TRUE);
+ }
+ return(FALSE);
+}
+
+# from color names or code 1, 2, 3 the rbg strings
+my.col2rgb <- function(cols){
+ rgbcols <- col2rgb(cols);
+ return(apply(rgbcols, 2, function(x){paste("rgb(", paste(x, collapse=","), ")", sep="")}));
+}
+
+# #FFFFFF to rgb(1, 0, 0)
+hex2rgba <- function(cols, alpha=0.8){
+ return(apply(sapply(cols, col2rgb), 2, function(x){paste("rgba(", x[1], ",", x[2], ",", x[3], ",", alpha, ")", sep="")}));
+}
+
+hex2rgb <- function(cols){
+ return(apply(sapply(cols, col2rgb), 2, function(x){paste("rgb(", x[1], ",", x[2], ",", x[3], ")", sep="")}));
+}
+
+# List of objects
+# Improved list of objects
+# Jeff Xia\email{jeff.xia@mcgill.ca}
+# McGill University, Canada
+# License: GNU GPL (>= 2)
+
+.ls.objects <- function (pos = 1, pattern, order.by,
+ decreasing=FALSE, head=FALSE, n=5) {
+ napply <- function(names, fn) sapply(names, function(x)
+ fn(get(x, pos = pos)))
+ names <- ls(pos = pos, pattern = pattern)
+ obj.class <- napply(names, function(x) as.character(class(x))[1])
+ obj.mode <- napply(names, mode)
+ obj.type <- ifelse(is.na(obj.class), obj.mode, obj.class)
+ obj.prettysize <- napply(names, function(x) {
+ capture.output(format(utils::object.size(x), units = "auto")) })
+ obj.size <- napply(names, object.size)
+ obj.dim <- t(napply(names, function(x)
+ as.numeric(dim(x))[1:2]))
+ vec <- is.na(obj.dim)[, 1] & (obj.type != "function")
+ obj.dim[vec, 1] <- napply(names, length)[vec]
+ mSetObj <- .get.mSet(mSetObj);
+ print(lapply(mSetObj$dataSet, object.size));
+ out <- data.frame(obj.type, obj.size, obj.prettysize, obj.dim)
+ names(out) <- c("Type", "Size", "PrettySize", "Rows", "Columns")
+ if (!missing(order.by))
+ out <- out[order(out[[order.by]], decreasing=decreasing), ]
+ if (head)
+ out <- head(out, n)
+ out
+}
+
+#'Extend axis
+#'@description Extends the axis range to both ends
+#'vec is the values for that axis
+#'unit is the width to extend, 10 will increase by 1/10 of the range
+#'@param vec Input the vector
+#'@param unit Numeric
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+GetExtendRange<-function(vec, unit=10){
+ var.max <- max(vec, na.rm=T);
+ var.min <- min(vec, na.rm=T);
+ exts <- (var.max - var.min)/unit;
+ c(var.min-exts, var.max+exts);
+}
+
+getVennCounts <- function(x, include="both") {
+ x <- as.matrix(x)
+ include <- match.arg(include,c("both","up","down"))
+ x <- sign(switch(include,
+ both = abs(x),
+ up = x > 0,
+ down = x < 0
+ ))
+ nprobes <- nrow(x)
+ ncontrasts <- ncol(x)
+ names <- colnames(x)
+ if(is.null(names)) names <- paste("Group",1:ncontrasts)
+ noutcomes <- 2^ncontrasts
+ outcomes <- matrix(0,noutcomes,ncontrasts)
+ colnames(outcomes) <- names
+ for (j in 1:ncontrasts)
+ outcomes[,j] <- rep(0:1,times=2^(j-1),each=2^(ncontrasts-j))
+ xlist <- list()
+ for (i in 1:ncontrasts) xlist[[i]] <- factor(x[,ncontrasts-i+1],levels=c(0,1))
+ counts <- as.vector(table(xlist))
+ structure(cbind(outcomes,Counts=counts),class="VennCounts")
+}
+
+# Perform utilities for MetPa
+# borrowed from Hmisc
+# Jeff Xia\email{jeff.xia@mcgill.ca}
+# McGill University, Canada
+# License: GNU GPL (>= 2)
+all.numeric <- function (x, what = c("test", "vector"), extras = c(".", "NA")){
+ what <- match.arg(what)
+ old <- options(warn = -1)
+ on.exit(options(old));
+ x <- sub("[[:space:]]+$", "", x);
+ x <- sub("^[[:space:]]+", "", x);
+ inx <- x %in% c("", extras);
+ xs <- x[!inx];
+ isnum <- !any(is.na(as.numeric(xs)))
+ if (what == "test")
+ isnum
+ else if (isnum)
+ as.numeric(x)
+ else x
+}
+
+ClearNumerics <-function(dat.mat){
+ dat.mat[is.na(dat.mat)] <- -777;
+ dat.mat[dat.mat == Inf] <- -999;
+ dat.mat[dat.mat == -Inf] <- -111;
+ dat.mat;
+}
+
+#'Calculate Pairwise Differences
+#'@description Mat are log normalized, diff will be ratio. Used in higher functions.
+#'@param mat Input matrix of data to calculate pair-wise differences.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'
+CalculatePairwiseDiff <- function(mat){
+ f <- function(i, mat) {
+ z <- mat[, i-1] - mat[, i:ncol(mat), drop = FALSE]
+ colnames(z) <- paste(colnames(mat)[i-1], colnames(z), sep = "/")
+ z
+ }
+ res <- do.call("cbind", sapply(2:ncol(mat), f, mat));
+ round(res,5);
+}
+
+##############################################
+##############################################
+########## Utilities for web-server ##########
+##############################################
+##############################################
+
+#'Update graph settings
+#'@description Function to update the graph settings.
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@export
+# col.vec should already been created
+UpdateGraphSettings <- function(mSetObj=NA, colVec, shapeVec){
+ mSetObj <- .get.mSet(mSetObj);
+ grpnms <- levels(current.cls);
+
+ # default styles
+ grp.num <- length(grpnms);
+ if(grp.num <= 18){
+ cols <- pal_18[1:grp.num];
+ }else{
+ cols <- colorRampPalette(pal_18)(grp.num);
+ }
+
+ # make sure the NA
+ na.inx <- colVec == "#NA";
+ colVec[na.inx] <- cols[na.inx];
+ shapeVec[shapeVec == 0] <- 21;
+
+ names(colVec) <- grpnms;
+ names(shapeVec) <- grpnms;
+
+ colVec <<- colVec;
+ shapeVec <<- shapeVec;
+}
+
+GetShapeSchema <- function(mSetObj=NA, show.name, grey.scale){
+ mSetObj <- .get.mSet(mSetObj);
+ if(exists("shapeVec") && all(shapeVec >= 0)){
+ sps <- rep(0, length=length(mSetObj$dataSet$cls));
+ clsVec <- as.character(mSetObj$dataSet$cls)
+ grpnms <- names(shapeVec);
+ for(i in 1:length(grpnms)){
+ sps[clsVec == grpnms[i]] <- shapeVec[i];
+ }
+ shapes <- sps;
+ }else{
+ if(show.name | grey.scale){
+ shapes <- as.numeric(mSetObj$dataSet$cls)+1;
+ }else{
+ shapes <- rep(21, length(mSetObj$dataSet$cls));
+ }
+ }
+ return(shapes);
+}
+
+pal_18 <- c("#e6194B", "#3cb44b", "#4363d8", "#42d4f4", "#f032e6", "#ffe119", "#911eb4", "#f58231", "#bfef45",
+ "#fabebe", "#469990", "#e6beff", "#9A6324", "#800000", "#aaffc3", "#808000", "#ffd8b1", "#000075");
+cb_pal_18 <- c("#E69F00", "#b12c6f", "#56B4E9", "#009E73", "#F0E442", "#004488",
+ "#D55E00", "#EE6677", "#CCBB44", "#A95AA1", "#DCB69F", "#661100",
+ "#63ACBE", "#332288", "#EE7733", "#EE3377", "#0072B2", "#999933");
+
+GetColorSchema <- function(my.cls, grayscale=F){
+
+ lvs <- levels(my.cls);
+ grp.num <- length(lvs);
+ if(grayscale){
+ dist.cols <- colorRampPalette(c("grey90", "grey30"))(grp.num);
+ }else if(exists("colVec") && !any(colVec =="#NA") && length(colVec) == length(levels(my.cls))){
+ dist.cols <- colVec;
+ }else{
+ if(grp.num <= 18){ # update color and respect default
+ dist.cols <- pal_18[1:grp.num];
+ }else{
+ dist.cols <- colorRampPalette(pal_18)(grp.num);
+ }
+ }
+
+ colors <- vector(mode="character", length=length(my.cls));
+ for(i in 1:length(lvs)){
+ colors[my.cls == lvs[i]] <- dist.cols[i];
+ }
+ return (colors);
+}
+
+#'Remove folder
+#'@description Remove folder
+#'@param folderName Input name of folder to remove
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'
+RemoveFolder<-function(folderName){
+ a<-system(paste("rm", "-r", folderName), intern=T);
+ if(!length(a)>0){
+ AddErrMsg(paste("Could not remove file -", folderName));
+ return (0);
+ }
+ return(1);
+}
+
+#'Remove file
+#'@description Remove file
+#'@param fileName Input name of file to remove
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+RemoveFile<-function(fileName){
+ if(file.exists(fileName)){
+ file.remove(fileName);
+ }
+}
+
+# do memory cleaning after removing many objects
+cleanMem <- function(n=10) { for (i in 1:n) gc() }
+
+#'Retrieve last command from the Rhistory.R file
+#'@description Fetches the last command from the Rhistory.R file
+#'@param regexp Retrieve last command from Rhistory file
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+GetCMD<-function(regexp){
+ # store all lines into a list object
+ all.lines<-readLines("Rhistory.R");
+
+ all.matches<-grep(regexp, all.lines, value=T);
+ if(length(all.matches)==0){
+ return(NULL);
+ }else{
+ # only return the last command
+ return(all.matches[length(all.matches)]);
+ }
+}
+
+# Memory functions
+ShowMemoryUse <- function(..., n=20) {
+ library(pryr);
+ sink(); # make sure print to screen
+ print(mem_used());
+ print(sessionInfo());
+ print(.ls.objects(..., order.by="Size", decreasing=TRUE, head=TRUE, n=n));
+ print(warnings());
+}
+
+#'Perform utilities for cropping images
+#'@description Obtain the full path to convert (from imagemagik)
+#'for cropping images
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+GetConvertFullPath<-function(){
+ path <- system("which convert", intern=TRUE);
+ if((length(path) == 0) && (typeof(path) == "character")){
+ print("Could not find convert in the PATH!");
+ return("NA");
+ }
+ return(path);
+}
+
+# need to obtain the full path to convert (from imagemagik) for cropping images
+GetBashFullPath<-function(){
+ path <- system("which bash", intern=TRUE);
+ if((length(path) == 0) && (typeof(path) == "character")){
+ print("Could not find bash in the PATH!");
+ return("NA");
+ }
+ return(path);
+}
+
+#'Converts xset object from XCMS to mSet object for MetaboAnalyst
+#'@description This function converts processed raw LC/MS data from XCMS
+#'to a usable data object (mSet) for MetaboAnalyst. The immediate next step following using this
+#'function is to perform a SanityCheck, and then further data processing and analysis can continue.
+#'@param xset The name of the xcmsSet object created.
+#'@param dataType The type of data, either list (Compound lists), conc (Compound concentration data),
+#'specbin (Binned spectra data), pktable (Peak intensity table), nmrpeak (NMR peak lists), mspeak (MS peak lists),
+#'or msspec (MS spectra data).
+#'@param analType Indicate the analysis module to be performed: stat, pathora, pathqea, msetora, msetssp, msetqea, ts,
+#'cmpdmap, smpmap, or pathinteg.
+#'@param paired Logical, is data paired (T) or not (F).
+#'@param format Specify if samples are paired and in rows (rowp), unpaired and in rows (rowu),
+#'in columns and paired (colp), or in columns and unpaired (colu).
+#'@param lbl.type Specify the data label type, either discrete (disc) or continuous (cont).
+#'@export
+
+XSet2MSet <- function(xset, dataType, analType, paired=F, format, lbl.type){
+
+ data <- xcms::groupval(xset, "medret", "into");
+ data2 <- rbind(class= as.character(phenoData(xset)$class), data);
+ rownames(data2) <- c("group", paste(round(groups(xset)[,"mzmed"], 3), round(groups(xset)[,"rtmed"]/60, 1), sep="/"));
+ fast.write.csv(data2, file="PeakTable.csv");
+ mSet <- InitDataObjects("dataType", "analType", paired)
+ mSet <- Read.TextData(mSet, "PeakTable.csv", "format", "lbl.type")
+ print("mSet successfully created...")
+ return(.set.mSet(mSetObj));
+}
+
+#'Get fisher p-values
+#'@param numSigMembers Number of significant members
+#'@param numSigAll Number of all significant features
+#'@param numMembers Number of members
+#'@param numAllMembers Number of all members
+#'@export
+GetFisherPvalue <- function(numSigMembers, numSigAll, numMembers, numAllMembers){
+ z <- cbind(numSigMembers, numSigAll-numSigMembers, numMembers-numSigMembers, numAllMembers-numMembers-numSigAll+numSigMembers);
+ z <- lapply(split(z, 1:nrow(z)), matrix, ncol=2);
+ z <- lapply(z, fisher.test, alternative = 'greater');
+ p.values <- as.numeric(unlist(lapply(z, "[[", "p.value"), use.names=FALSE));
+ return(p.values);
+}
+
+saveNetworkInSIF <- function(network, name){
+ edges <- .graph.sif(network=network, file=name);
+ sif.nm <- paste(name, ".sif", sep="");
+ if(length(list.edge.attributes(network))!=0){
+ edge.nms <- .graph.eda(network=network, file=name, edgelist.names=edges);
+ sif.nm <- c(sif.nm, edge.nms);
+ }
+ if(length(list.vertex.attributes(network))!=0){
+ node.nms <- .graph.noa(network=network, file=name);
+ sif.nm <- c(sif.nm, node.nms);
+ }
+ # need to save all sif and associated attribute files into a zip file for download
+ zip(paste(name,"_sif",".zip", sep=""), sif.nm);
+}
+
+.graph.sif <- function(network, file){
+ edgelist.names <- igraph::get.edgelist(network, names=TRUE)
+ edgelist.names <- cbind(edgelist.names[,1], rep("pp", length(E(network))), edgelist.names[,2]);
+ write.table(edgelist.names, row.names=FALSE, col.names=FALSE, file=paste(file, ".sif", sep=""), sep="\t", quote=FALSE)
+ return(edgelist.names)
+}
+
+# internal method to write cytoscape node attribute files
+.graph.noa <- function(network, file){
+ all.nms <- c();
+ attrib <- list.vertex.attributes(network)
+ for(i in 1:length(attrib)){
+ if(is(get.vertex.attribute(network, attrib[i]))[1] == "character")
+ {
+ type <- "String"
+ }
+ if(is(get.vertex.attribute(network, attrib[i]))[1] == "integer")
+ {
+ type <- "Integer"
+ }
+ if(is(get.vertex.attribute(network, attrib[i]))[1] == "numeric")
+ {
+ type <- "Double"
+ }
+ noa <- cbind(V(network)$name, rep("=", length(V(network))), get.vertex.attribute(network, attrib[i]))
+ first.line <- paste(attrib[i], " (class=java.lang.", type, ")", sep="")
+ file.nm <- paste(file, "_", attrib[i], ".NA", sep="");
+ write(first.line, file=file.nm, ncolumns = 1, append=FALSE, sep=" ")
+ write.table(noa, row.names = FALSE, col.names = FALSE, file=file.nm, sep=" ", append=TRUE, quote=FALSE);
+ all.nms <- c(all.nms, file.nm);
+ }
+ return(all.nms);
+}
+
+# internal method to write cytoscape edge attribute files
+.graph.eda <- function(network, file, edgelist.names){
+ all.nms <- c();
+ attrib <- list.edge.attributes(network)
+ for(i in 1:length(attrib)){
+ if(is(get.edge.attribute(network, attrib[i]))[1] == "character")
+ {
+ type <- "String"
+ }
+ if(is(get.edge.attribute(network, attrib[i]))[1] == "integer")
+ {
+ type <- "Integer"
+ }
+ if(is(get.edge.attribute(network, attrib[i]))[1] == "numeric")
+ {
+ type <- "Double"
+ }
+ eda <- cbind(cbind(edgelist.names[,1], rep("(pp)", length(E(network))), edgelist.names[,3]), rep("=", length(E(network))), get.edge.attribute(network, attrib[i]))
+ first.line <- paste(attrib[i], " (class=java.lang.", type, ")", sep="");
+ file.nm <- paste(file, "_", attrib[i], ".EA", sep="");
+ write(first.line, file=file.nm, ncolumns=1, append=FALSE, sep =" ")
+ write.table(eda, row.names = FALSE, col.names = FALSE, file=file.nm, sep=" ", append=TRUE, quote=FALSE);
+ all.nms <- c(all.nms, file.nm);
+ }
+ return(all.nms);
+}
+
+PlotLoadBoxplot <- function(mSetObj=NA, cmpd){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(.on.public.web){
+ load_ggplot()
+ }
+
+ cls.lbls <- mSetObj$dataSet$cls;
+ y.label <- GetAbundanceLabel(mSetObj$dataSet$type);
+ cmpd.name = paste0("Met_", cmpd, ".png")
+
+ Cairo::Cairo(file=cmpd.name, width=240, height=400, bg = "transparent", type="png");
+
+ col <- unique(GetColorSchema(cls.lbls))
+ df <- data.frame(conc = mSetObj$dataSet$norm[, cmpd], class = cls.lbls)
+ p <- ggplot2::ggplot(df, aes(x=class, y=conc, fill=class)) + geom_boxplot(notch=FALSE, outlier.shape = NA, outlier.colour=NA) + theme_bw() + geom_jitter(size=1)
+ p <- p + theme(axis.title.x = element_blank(), axis.title.y = element_blank(), legend.position = "none")
+ p <- p + stat_summary(fun.y=mean, colour="yellow", geom="point", shape=18, size=3, show.legend = FALSE)
+ p <- p + theme(text = element_text(size=15), plot.margin = margin(t=0.45, r=0.25, b=1.5, l=0.25, "cm"))
+ p <- p + scale_fill_manual(values=col) + ggtitle(cmpd) + theme(axis.text.x = element_text(angle=90, hjust=1), axis.text = element_text(size=10))
+ p <- p + theme(plot.title = element_text(size = 14, hjust=0.5, face="bold", vjust=2))
+ print(p)
+
+ dev.off()
+}
+
+#'Compute within group and between group sum of squares
+#'(BSS/WSS) for each row of a matrix which may have NA
+#'@description Columns have labels, x is a numeric vector,
+#'cl is consecutive integers
+#'@param x Numeric vector
+#'@param cl Columns
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+Get.bwss<-function(x, cl){
+ K <- max(cl) - min(cl) + 1
+ tvar <- var.na(x);
+ tn <- sum(!is.na(x));
+ wvar <- wn <- numeric(K);
+
+ for(i in (1:K)) {
+ if(sum(cl == (i + min(cl) - 1)) == 1){
+ wvar[i] <- 0;
+ wn[i] <- 1;
+ }
+
+ if(sum(cl == (i + min(cl) - 1)) > 1) {
+ wvar[i] <- var.na(x[cl == (i + min(cl) - 1)]);
+ wn[i] <- sum(!is.na(x[cl == (i + min(cl) - 1)]));
+ }
+ }
+
+ WSS <- sum.na(wvar * (wn - 1));
+ TSS <- tvar * (tn - 1)
+ (TSS - WSS)/WSS;
+}
+
+sum.na <- function(x,...){
+ res <- NA
+ tmp <- !(is.na(x) | is.infinite(x))
+ if(sum(tmp) > 0)
+ res <- sum(x[tmp])
+ res
+}
+
+var.na <- function(x){
+ res <- NA
+ tmp <- !(is.na(x) | is.infinite(x))
+ if(sum(tmp) > 1){
+ res <- var(as.numeric(x[tmp]))
+ }
+ res
+}
+
+end.with <- function(bigTxt, endTxt){
+ return(substr(bigTxt, nchar(bigTxt)-nchar(endTxt)+1, nchar(bigTxt)) == endTxt);
+}
+
+## fast T-tests/F-tests using genefilter
+PerformFastUnivTests <- function(data, cls, var.equal=TRUE){
+ print("Performing fast univariate tests ....");
+
+ # note, feature in rows for gene expression
+ data <- t(as.matrix(data));
+ if(length(levels(cls)) > 2){
+ res <- try(rowcolFt(data, cls, var.equal = var.equal));
+ }else{
+ res <- try(rowcoltt(data, cls, FALSE, 1L, FALSE));
+ }
+
+ if(class(res) == "try-error") {
+ res <- cbind(NA, NA);
+ }else{
+ # res <- cbind(res$statistic, res$p.value);
+ # make sure row names are kept
+ res <- res[, c("statistic", "p.value")];
+ }
+
+ return(res);
+}
+
+GetCurrentPathForScheduler <- function(){
+ path <-getwd();
+ path <- gsub(basename(path), "", path)
+ return(path)
+}
+
+fast.write.csv <- function(dat, file, row.names=TRUE){
+ tryCatch(
+ {
+ if(is.data.frame(dat)){
+ # there is a rare bug in data.table (R 3.6) which kill the R process in some cases
+ data.table::fwrite(dat, file, row.names=row.names);
+ }else{
+ write.csv(dat, file, row.names=row.names);
+ }
+ }, error=function(e){
+ print(e);
+ write.csv(dat, file, row.names=row.names);
+ }, warning=function(w){
+ print(w);
+ write.csv(dat, file, row.names=row.names);
+ });
+}
+
+rowcolFt = function(x, fac, var.equal, which = 1L) {
+
+ if(!(which %in% c(1L, 2L)))
+ stop(sQuote("which"), " must be 1L or 2L.")
+
+ if(which==2L)
+ x = t(x)
+
+ if (typeof(x) == "integer")
+ x[] <- as.numeric(x)
+
+ sqr = function(x) x*x
+
+ stopifnot(length(fac)==ncol(x), is.factor(fac), is.matrix(x))
+ x <- x[,!is.na(fac), drop=FALSE]
+ fac <- fac[!is.na(fac)]
+
+ ## Number of levels (groups)
+ k <- nlevels(fac)
+
+ ## xm: a nrow(x) x nlevels(fac) matrix with the means of each factor
+ ## level
+ xm <- matrix(
+ sapply(levels(fac), function(fl) rowMeans(x[,which(fac==fl), drop=FALSE])),
+ nrow = nrow(x),
+ ncol = nlevels(fac))
+
+ ## x1: a matrix of group means, with as many rows as x, columns correspond to groups
+ x1 <- xm[,fac, drop=FALSE]
+
+ ## degree of freedom 1
+ dff <- k - 1
+
+ if(var.equal){
+ ## x0: a matrix of same size as x with overall means
+ x0 <- matrix(rowMeans(x), ncol=ncol(x), nrow=nrow(x))
+
+ ## degree of freedom 2
+ dfr <- ncol(x) - dff - 1
+
+ ## mean sum of squares
+ mssf <- rowSums(sqr(x1 - x0)) / dff
+ mssr <- rowSums(sqr( x - x1)) / dfr
+
+ ## F statistic
+ fstat <- mssf/mssr
+
+ } else{
+
+ ## a nrow(x) x nlevels(fac) matrix with the group size of each factor
+ ## level
+ ni <- t(matrix(tapply(fac,fac,length),ncol=nrow(x),nrow=k))
+
+ ## wi: a nrow(x) x nlevels(fac) matrix with the variance * group size of each factor
+ ## level
+ sss <- sqr(x-x1)
+ x5 <- matrix(
+ sapply(levels(fac), function(fl) rowSums(sss[,which(fac==fl), drop=FALSE])),
+ nrow = nrow(sss),
+ ncol = nlevels(fac))
+ wi <- ni*(ni-1) /x5
+
+ ## u : Sum of wi
+ u <- rowSums(wi)
+
+ ## F statistic
+ MR <- rowSums(sqr((1 - wi/u)) * 1/(ni-1))*1/(sqr(k)-1)
+ fsno <- 1/dff * rowSums(sqr(xm - rowSums(wi*xm)/u) * wi)
+ fsdeno <- 1+ 2* (k-2)*MR
+ fstat <- fsno/fsdeno
+
+ ## degree of freedom 2: Vector with length nrow(x)
+ dfr <- 1/(3 * MR)
+
+ }
+
+ res = data.frame(statistic = fstat,
+ p.value = pf(fstat, dff, dfr, lower.tail=FALSE),
+ row.names = rownames(x))
+
+ attr(res, "df") = c(dff=dff, dfr=dfr)
+ return(res)
+}
+
+rowcoltt = function(x, fac, tstatOnly, which, na.rm) {
+
+ #if(.on.public.web){
+ # dyn.load(.getDynLoadPath());
+ #}
+
+ if (!missing(tstatOnly) && (!is.logical(tstatOnly) || is.na(tstatOnly)))
+ stop(sQuote("tstatOnly"), " must be TRUE or FALSE.")
+
+ f = checkfac(fac)
+ if ((f$nrgrp > 2) || (f$nrgrp <= 0))
+ stop("Number of groups is ", f$nrgrp, ", but must be >0 and <=2 for 'rowttests'.")
+
+ if (typeof(x) == "integer")
+ x[] <- as.numeric(x)
+
+ #cc = .Call("rowcolttests", x, f$fac, f$nrgrp, which-1L, na.rm)
+ cc = XiaLabCppLib::rowcolttestsR(x, f$fac, f$nrgrp, which-1L, na.rm)
+
+ res = data.frame(statistic = cc$statistic,
+ dm = cc$dm,
+ row.names = dimnames(x)[[which]])
+
+ if (!tstatOnly)
+ res = cbind(res, p.value = 2*pt(abs(res$statistic), cc$df, lower.tail=FALSE))
+
+ attr(res, "df") = cc$df
+ return(res)
+}
+
+checkfac = function(fac) {
+
+ if(is.numeric(fac)) {
+ nrgrp = as.integer(max(fac, na.rm=TRUE)+1)
+ fac = as.integer(fac)
+ }
+ ## this must precede the factor test
+ if(is.character(fac))
+ fac = factor(fac)
+
+ if (is.factor(fac)) {
+ nrgrp = nlevels(fac)
+ fac = as.integer(as.integer(fac)-1)
+ }
+ if(!is.integer(fac))
+ stop("'fac' must be factor, character, numeric, or integer.")
+
+ if(any(fac<0, na.rm=TRUE))
+ stop("'fac' must not be negative.")
+
+ return(list(fac=fac, nrgrp=nrgrp))
+}
+
+# to convert all rds files to qs file for faster access
+convert.rds2qs <- function(){
+ rds.files <- list.files(".", pattern=".rds$");
+ for(rds in rds.files){
+ lib.rds <- readRDS(rds);
+ nm <- substr(rds, 1, nchar(rds)-4);
+ qs::qsave(lib.rds,paste0(nm, ".qs"));
+ }
+}
+
+# to convert all rda files to qs file for faster access
+convert.rda2qs <- function(){
+ rda.files <- list.files(".", pattern=".rda$");
+ for(rda in rda.files){
+ nm <- substr(rda, 1, nchar(rda)-4);
+ lib.rda <- load(rda);
+ # here the name is inmexpa (jointpa)
+ # qs::qsave(inmexpa,paste0(nm, ".qs"));
+ # here the name is metpa (metpa)
+ qs::qsave(metpa,paste0(nm, ".qs"));
+ # here the name is current.msetlib (msets)
+ #qs::qsave(current.msetlib,paste0(nm, ".qs"));
+ }
+}
\ No newline at end of file
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/general_norm_utils.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/general_norm_utils.R
new file mode 100755
index 0000000000000000000000000000000000000000..202eb1a36349bb20bbc88777b99cdaf73dc79243
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/general_norm_utils.R
@@ -0,0 +1,646 @@
+#'Clean the data matrix
+#'@description Function used in higher functinos to clean data matrix
+#'@param ndata Input the data to be cleaned
+#'@export
+#'
+CleanDataMatrix <- function(ndata){
+ # make sure no costant columns crop up
+ varCol <- apply(data.frame(ndata), 2, var, na.rm=T); # getting an error of dim(X) must have a positive length, fixed by data.frame
+ constCol <- (varCol == 0 | is.na(varCol));
+ return(ndata[,!constCol, drop=FALSE]); # got an error of incorrect number of dimensions, added drop=FALSE to avoid vector conversion
+}
+
+#'Normalization
+#'@description This function performs row-wise normalization, transformation, and
+#'scaling of your metabolomic data.
+#'@usage Normalization(mSetObj, rowNorm, transNorm, scaleNorm, ref=NULL, ratio=FALSE, ratioNum=20)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param rowNorm Select the option for row-wise normalization, "QuantileNorm" for Quantile Normalization,
+#'"ProbNormT" for Probabilistic Quotient Normalization without using a reference sample,
+#'"ProbNormF" for Probabilistic Quotient Normalization based on a reference sample,
+#'"CompNorm" for Normalization by a reference feature,
+#'"SumNorm" for Normalization to constant sum,
+#'"MedianNorm" for Normalization to sample median, and
+#'"SpecNorm" for Normalization by a sample-specific factor.
+#'@param transNorm Select option to transform the data, "LogNorm" for Log Normalization,
+#'and "CrNorm" for Cubic Root Transformation.
+#'@param scaleNorm Select option for scaling the data, "MeanCenter" for Mean Centering,
+#'"AutoNorm" for Autoscaling, "ParetoNorm" for Pareto Scaling, amd "RangeNorm" for Range Scaling.
+#'@param ref Input the name of the reference sample or the reference feature, use " " around the name.
+#'@param ratio This option is only for biomarker analysis.
+#'@param ratioNum Relevant only for biomarker analysis.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}, Jasmine Chong
+#'McGill University, Canada
+#'@import qs
+#'@export
+#'
+Normalization1 <- function(mSetObj=NA, rowNorm, transNorm, scaleNorm, ref=NULL, ratio=FALSE, ratioNum=20){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # PreparePrenormData() called already
+ data <- qs::qread("prenorm.qs");
+ cls <- mSetObj$dataSet$prenorm.cls;
+
+ # note, setup time factor
+ if(substring(mSetObj$dataSet$format,4,5)=="ts"){
+ if(is.null(mSetObj$dataSet$prenorm.facA)){
+ nfacA <- mSetObj$dataSet$facA;
+ nfacB <- mSetObj$dataSet$facB;
+ }else{
+ nfacA <- mSetObj$dataSet$prenorm.facA;
+ nfacB <- mSetObj$dataSet$prenorm.facB;
+ }
+
+ mSetObj$dataSet$facA <- nfacA;
+ mSetObj$dataSet$facB <- nfacB;
+ if(mSetObj$dataSet$design.type =="time" | mSetObj$dataSet$design.type =="time0"){
+ # determine time factor and should order first by subject then by each time points
+ if(tolower(mSetObj$dataSet$facA.lbl) == "time"){
+ time.fac <- nfacA;
+ exp.fac <- nfacB;
+ }else{
+ time.fac <- nfacB;
+ exp.fac <- nfacA;
+ }
+ # now make sure time fac is ordered
+ lvls <- levels(time.fac);
+ time.points <- as.numeric(as.character(lvls));
+ ord.lvls <- lvls[order(time.points)];
+ time.fac <- ordered(time.fac, levels = ord.lvls);
+ mSetObj$dataSet$time.fac <- time.fac;
+ mSetObj$dataSet$exp.fac <- exp.fac;
+ }
+ }
+
+ colNames <- colnames(data);
+ rowNames <- rownames(data);
+
+ # row-wise normalization
+ if(rowNorm=="QuantileNorm"){
+ data<-QuantileNormalize(data);
+ # this can introduce constant variables if a variable is
+ # at the same rank across all samples (replaced by its average across all)
+
+ varCol <- apply(data, 2, var, na.rm=T);
+ constCol <- (varCol == 0 | is.na(varCol));
+ constNum <- sum(constCol, na.rm=T);
+ if(constNum > 0){
+ print(paste("After quantile normalization", constNum, "features with a constant value were found and deleted."));
+ data <- data[,!constCol, drop=FALSE];
+ colNames <- colnames(data);
+ rowNames <- rownames(data);
+ }
+ rownm<-"Quantile Normalization";
+ }else if(rowNorm=="GroupPQN"){
+ grp.inx <- cls == ref;
+ ref.smpl <- apply(data[grp.inx, , drop=FALSE], 2, mean);
+ data<-t(apply(data, 1, ProbNorm, ref.smpl));
+ rownm<-"Probabilistic Quotient Normalization by a reference group";
+ }else if(rowNorm=="SamplePQN"){
+ ref.smpl <- data[ref, , drop=FALSE];
+ data<-t(apply(data, 1, ProbNorm, ref.smpl));
+ rownm<-"Probabilistic Quotient Normalization by a reference sample";
+ }else if(rowNorm=="CompNorm"){
+ data<-t(apply(data, 1, CompNorm, ref));
+ rownm<-"Normalization by a reference feature";
+ }else if(rowNorm=="SumNorm"){
+ data<-t(apply(data, 1, SumNorm));
+ rownm<-"Normalization to constant sum";
+ }else if(rowNorm=="MedianNorm"){
+ data<-t(apply(data, 1, MedianNorm));
+ rownm<-"Normalization to sample median";
+ }else if(rowNorm=="SpecNorm"){
+ if(!exists("norm.vec")){
+ norm.vec <- rep(1,nrow(data)); # default all same weight vec to prevent error
+ print("No sample specific information were given, all set to 1.0");
+ }
+ rownm<-"Normalization by sample-specific factor";
+ data<-data/norm.vec;
+ }else{
+ # nothing to do
+ rownm<-"N/A";
+ }
+
+ # use apply will lose dimension info (i.e. row names and colnames)
+ rownames(data)<-rowNames;
+ colnames(data)<-colNames;
+
+ # if the reference by feature, the feature column should be removed, since it is all 1
+ if(rowNorm=="CompNorm" && !is.null(ref)){
+ inx<-match(ref, colnames(data));
+ data<-data[,-inx, drop=FALSE];
+ colNames <- colNames[-inx];
+ }
+
+ # record row-normed data for fold change analysis (b/c not applicable for mean-centered data)
+ row.norm <- as.data.frame(CleanData(data, T, T)); #moved below ratio
+ qs::qsave(row.norm, file="row_norm.qs");
+ # this is for biomarker analysis only (for compound concentration data)
+ if(ratio){
+ min.val <- min(abs(data[data!=0]))/2;
+ norm.data <- log2((data + sqrt(data^2 + min.val))/2);
+ transnm<-"Log2 Normalization";
+ ratio.mat <- CalculatePairwiseDiff(norm.data);
+
+ fstats <- Get.Fstat(ratio.mat, cls);
+ hit.inx <- rank(-fstats) < ratioNum; # get top n
+
+ ratio.mat <- ratio.mat[, hit.inx, drop=FALSE];
+
+ data <- cbind(norm.data, ratio.mat);
+
+ colNames <- colnames(data);
+ rowNames <- rownames(data);
+ mSetObj$dataSet$use.ratio <- TRUE;
+ mSetObj$dataSet$proc.ratio <- data;
+
+ }else{
+ mSetObj$dataSet$use.ratio <- FALSE;
+ # transformation
+ if(transNorm=='LogNorm'){
+ min.val <- min(abs(data[data!=0]))/10;
+ data<-apply(data, 2, LogNorm, min.val);
+ transnm<-"Log10 Normalization";
+ }else if(transNorm=='CrNorm'){
+ norm.data <- abs(data)^(1/3);
+ norm.data[data<0] <- - norm.data[data<0];
+ data <- norm.data;
+ transnm<-"Cubic Root Transformation";
+ }else{
+ transnm<-"N/A";
+ }
+ }
+
+ # scaling
+ if(scaleNorm=='MeanCenter'){
+ data<-apply(data, 2, MeanCenter);
+ scalenm<-"Mean Centering";
+ }else if(scaleNorm=='AutoNorm'){
+ data<-apply(data, 2, AutoNorm);
+ scalenm<-"Autoscaling";
+ }else if(scaleNorm=='ParetoNorm'){
+ data<-apply(data, 2, ParetoNorm);
+ scalenm<-"Pareto Scaling";
+ }else if(scaleNorm=='RangeNorm'){
+ data<-apply(data, 2, RangeNorm);
+ scalenm<-"Range Scaling";
+ }else{
+ scalenm<-"N/A";
+ }
+
+ # note after using "apply" function, all the attribute lost, need to add back
+ rownames(data)<-rowNames;
+ colnames(data)<-colNames;
+
+ # need to do some sanity check, for log there may be Inf values introduced
+ data <- CleanData(data, T, F);
+
+ if(ratio){
+ mSetObj$dataSet$ratio <- CleanData(ratio.mat, T, F)
+ }
+
+ mSetObj$dataSet$norm <- as.data.frame(data);
+ qs::qsave(as.data.frame(data), file="complete_norm.qs");
+ mSetObj$dataSet$cls <- cls;
+
+ mSetObj$dataSet$rownorm.method <- rownm;
+ mSetObj$dataSet$trans.method <- transnm;
+ mSetObj$dataSet$scale.method <- scalenm;
+ mSetObj$dataSet$combined.method <- FALSE;
+ mSetObj$dataSet$norm.all <- NULL; # this is only for biomarker ROC analysis
+
+# processedObj <- list();#for omicsanalyst
+# processedObj$name <- "met_t_omicsanalyst.json"
+# processedObj$type <- "met.t"
+# processedObj$data.proc <- as.matrix(t(mSetObj$dataSet$norm))
+# processedObj$feature.nms <- rownames(processedObj$data.proc)
+# processedObj$sample.nms <- colnames(processedObj$data.proc)
+# meta = data.frame(Condition = mSetObj$dataSet$cls)
+# rownames(meta) <- colnames(processedObj$data.proc)
+# processedObj$meta <- meta
+# library(RJSONIO)
+# sink(processedObj$name);
+# cat(toJSON(processedObj));
+# sink();
+ return(.set.mSet(mSetObj));
+}
+
+#'Row-wise Normalization
+#'@description Row-wise norm methods, when x is a row.
+#'Normalize by a sum of each sample, assume constant sum (1000).
+# Return: normalized data.
+#'Options for normalize by sum median, reference sample,
+#'reference reference (compound), or quantile normalization
+#'@param x Input data to normalize
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'@export
+#'
+SumNorm<-function(x){
+ 1000*x/sum(x, na.rm=T);
+}
+
+# normalize by median
+MedianNorm<-function(x){
+ x/median(x, na.rm=T);
+}
+
+# normalize by a reference sample (probability quotient normalization)
+# ref should be the name of the reference sample
+ProbNorm<-function(x, ref.smpl){
+ x/median(as.numeric(x/ref.smpl), na.rm=T)
+}
+
+# normalize by a reference reference (i.e. creatinine)
+# ref should be the name of the cmpd
+CompNorm<-function(x, ref){
+ 1000*x/x[ref];
+}
+
+# perform quantile normalization on the raw data (can be log transformed later by user)
+# https://stat.ethz.ch/pipermail/bioconductor/2005-April/008348.html
+QuantileNormalize <- function(data){
+ return(t(preprocessCore::normalize.quantiles(t(data), copy=FALSE)));
+}
+
+#'Column-wise Normalization
+#'@description Column-wise norm methods, when x is a column
+#'Options for log, zero mean and unit variance, and
+#'several zero mean and variance/SE
+#'@param x Input data
+#'@param min.val Input minimum value
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+
+# generalize log, tolerant to 0 and negative values
+LogNorm<-function(x, min.val){
+ log10((x + sqrt(x^2 + min.val^2))/2)
+}
+
+# normalize to zero mean and unit variance
+AutoNorm<-function(x){
+ (x - mean(x))/sd(x, na.rm=T);
+}
+
+# normalize to zero mean but variance/SE
+ParetoNorm<-function(x){
+ (x - mean(x))/sqrt(sd(x, na.rm=T));
+}
+
+# normalize to zero mean but variance/SE
+MeanCenter<-function(x){
+ x - mean(x);
+}
+
+# normalize to zero mean but variance/SE
+RangeNorm<-function(x){
+ if(max(x) == min(x)){
+ x;
+ }else{
+ (x - mean(x))/(max(x)-min(x));
+ }
+}
+
+#'Two plot summary plot: Feature View of before and after normalization
+#'@description For each plot, the top is a box plot, bottom is a density plot
+#'@usage PlotNormSummary(mSetObj, imgName, format, dpi, width)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}, Jasmine Chong
+#'McGill University, Canada
+#'@export
+#'
+PlotNormSummary <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+
+ if(is.na(width)){
+ w <- 10.5; h <- 12.5;
+ }else if(width==0){
+ w = 7.2
+ h = 9.5
+ }else if(width>0){
+ w = width
+ h = width*1.25
+ # w <- 7.2; h <- 9;
+ }
+
+ mSetObj$imgSet$norm <- imgName
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ layout(matrix(c(1,2,2,2,3,4,4,4), 4, 2, byrow = FALSE))
+
+ # since there may be too many compounds, only plot a subsets (50) in box plot
+ # but density plot will use all the data
+
+ pre.inx<-GetRandomSubsetIndex(ncol(mSetObj$dataSet$proc), sub.num=50);
+ namesVec <- colnames(mSetObj$dataSet$proc[,pre.inx, drop=FALSE]);
+
+ # only get common ones
+ nm.inx <- namesVec %in% colnames(mSetObj$dataSet$norm)
+ namesVec <- namesVec[nm.inx];
+ pre.inx <- pre.inx[nm.inx];
+
+ norm.inx<-match(namesVec, colnames(mSetObj$dataSet$norm));
+ namesVec <- substr(namesVec, 1, 12); # use abbreviated name
+
+ rangex.pre <- range(mSetObj$dataSet$proc[, pre.inx, drop=FALSE], na.rm=T);
+ rangex.norm <- range(mSetObj$dataSet$norm[, norm.inx, drop=FALSE], na.rm=T);
+
+ x.label<-GetAbundanceLabel(mSetObj$dataSet$type);
+ y.label<-GetVariableLabel(mSetObj$dataSet$type);
+
+ # fig 1
+ if(anal.type == "roc" & mSetObj$dataSet$roc_cols == 1){
+ op<-par(mar=c(4,7,4,0), xaxt="s");
+ plot.new()
+ }else{
+ op<-par(mar=c(4,7,4,0), xaxt="s");
+ plot(density(apply(mSetObj$dataSet$proc, 2, mean, na.rm=TRUE)), col='darkblue', las =2, lwd=2, main="", xlab="", ylab="");
+ mtext("Density", 2, 5);
+ mtext("Before Normalization",3, 1)
+ }
+
+ # fig 2
+ op<-par(mar=c(7,7,0,0), xaxt="s");
+ boxplot(mSetObj$dataSet$proc[,pre.inx, drop=FALSE], names=namesVec, ylim=rangex.pre, las = 2, col="lightgreen", horizontal=T, show.names=T);
+ mtext(x.label, 1, 5);
+
+ # fig 3
+ if(anal.type == "roc" & mSetObj$dataSet$roc_cols == 1){
+ op<-par(mar=c(4,7,4,2), xaxt="s");
+ plot.new()
+ }else{
+ op<-par(mar=c(4,7,4,2), xaxt="s");
+ plot(density(apply(mSetObj$dataSet$norm, 2, mean, na.rm=TRUE)), col='darkblue', las=2, lwd =2, main="", xlab="", ylab="");
+ mtext("After Normalization",3, 1);
+ }
+
+ # fig 4
+ op<-par(mar=c(7,7,0,2), xaxt="s");
+ boxplot(mSetObj$dataSet$norm[,norm.inx, drop=FALSE], names=namesVec, ylim=rangex.norm, las = 2, col="lightgreen", horizontal=T, show.names=T);
+ mtext(paste("Normalized",x.label),1, 5);
+
+ dev.off();
+
+ return(.set.mSet(mSetObj));
+}
+
+#'Two plot summary plot: Sample View of before and after normalization
+#'@description For each plot, the top is a density plot and the bottom is a box plot.
+#'@usage PlotSampleNormSummary(mSetObj=NA, imgName, format="png", dpi=72, width=NA)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", of "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}, Jasmine Chong
+#'McGill University, Canada
+#'@export
+
+PlotSampleNormSummary <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- 10.5; h <- 12.5;
+ }else if(width == 0){
+ w <- 7.2;h <- 9.5;
+ }else if(width>0){
+ w = width
+ h = width*1.25
+ # w <- 7.2; h <- 9;
+ }
+
+ mSetObj$imgSet$summary_norm <-imgName;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ layout(matrix(c(1,1,1,2,3,3,3,4), 4, 2, byrow = FALSE))
+
+ # since there may be too many samples, only plot a subsets (50) in box plot
+ # but density plot will use all the data
+
+ pre.inx<-GetRandomSubsetIndex(nrow(mSetObj$dataSet$proc), sub.num=50);
+ namesVec <- rownames(mSetObj$dataSet$proc[pre.inx, , drop=FALSE]);
+
+ # only get common ones
+ nm.inx <- namesVec %in% rownames(mSetObj$dataSet$norm)
+ namesVec <- namesVec[nm.inx];
+ pre.inx <- pre.inx[nm.inx];
+
+ norm.inx<-match(namesVec, rownames(mSetObj$dataSet$norm));
+ namesVec <- substr(namesVec, 1, 12); # use abbreviated name
+
+ rangex.pre <- range(mSetObj$dataSet$proc[pre.inx, , drop=FALSE], na.rm=T);
+ rangex.norm <- range(mSetObj$dataSet$norm[norm.inx, , drop=FALSE], na.rm=T);
+
+ x.label<-GetAbundanceLabel(mSetObj$dataSet$type);
+ y.label<-"Samples";
+
+ # fig 1
+ op<-par(mar=c(5.75,8,4,0), xaxt="s");
+ boxplot(t(mSetObj$dataSet$proc[pre.inx, , drop=FALSE]), names= namesVec, ylim=rangex.pre, las = 2, col="lightgreen", horizontal=T);
+ mtext("Before Normalization", 3,1)
+
+ # fig 2
+ op<-par(mar=c(6.5,7,0,0), xaxt="s");
+ plot(density(apply(mSetObj$dataSet$proc, 1, mean, na.rm=TRUE)), col='darkblue', las =2, lwd=2, main="", xlab="", ylab="");
+ mtext(x.label, 1, 4);
+ mtext("Density", 2, 5);
+
+ # fig 3
+ op<-par(mar=c(5.75,8,4,2), xaxt="s");
+ boxplot(t(mSetObj$dataSet$norm[norm.inx, , drop=FALSE]), names=namesVec, ylim=rangex.norm, las = 2, col="lightgreen", ylab="", horizontal=T);
+ mtext("After Normalization", 3, 1);
+
+ # fig 4
+ op<-par(mar=c(6.5,7,0,2), xaxt="s");
+ plot(density(apply(mSetObj$dataSet$norm, 1, mean, na.rm=TRUE)), col='darkblue', las=2, lwd =2, main="", xlab="", ylab="");
+ mtext(paste("Normalized",x.label),1, 4)
+
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+#'Update data for filtering
+#'@description Function to update the mSetObj after removing features or samples.
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@export
+# note: feature.nm.vec, smpl.nm.vec, grp.nm.vec all set up
+UpdateData <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+
+ #Reset to default
+ mSetObj$dataSet$edit <- NULL;
+
+ if(is.null(mSetObj$dataSet$filt)){
+ data <- mSetObj$dataSet$proc;
+ cls <- mSetObj$dataSet$proc.cls;
+ if(substring(mSetObj$dataSet$format,4,5)=="ts"){
+ facA <- mSetObj$dataSet$proc.facA;
+ facB <- mSetObj$dataSet$proc.facB;
+ }
+ }else{
+ data <- mSetObj$dataSet$filt;
+ cls <- mSetObj$dataSet$filt.cls;
+ if(substring(mSetObj$dataSet$format,4,5)=="ts"){
+ facA <- mSetObj$dataSet$filt.facA;
+ facB <- mSetObj$dataSet$filt.facB;
+ }
+ }
+
+ # update feature
+ feat.hit.inx <- colnames(data) %in% feature.nm.vec;
+ data <- CleanDataMatrix(data[,!feat.hit.inx,drop=FALSE]);
+ #AddMsg("Successfully updated the feature items!");
+
+ # update samples
+ smpl.hit.inx <- rownames(data) %in% smpl.nm.vec;
+ data <- CleanDataMatrix(data[!smpl.hit.inx,,drop=FALSE]);
+ cls <- as.factor(as.character(cls[!smpl.hit.inx]));
+ if(substring(mSetObj$dataSet$format,4,5)=="ts"){
+ facA <- as.factor(as.character(facA[!smpl.hit.inx]));
+ facB <- as.factor(as.character(facB[!smpl.hit.inx]));
+ }
+ #AddMsg("Successfully updated the sample items!");
+
+ # update groups
+ grp.hit.inx <- cls %in% grp.nm.vec;
+ data <- CleanDataMatrix(data[!grp.hit.inx,,drop=FALSE]);
+ cls <- droplevels(factor(cls[!grp.hit.inx]));
+ if(substring(mSetObj$dataSet$format,4,5)=="ts"){
+ facA <- droplevels(factor(facA[!grp.hit.inx]));
+ facB <- droplevels(factor(facB[!grp.hit.inx]));
+ }
+ AddMsg("Successfully updated the data!");
+
+ # now set to
+ mSetObj$dataSet$edit <- data;
+ mSetObj$dataSet$edit.cls <- cls;
+ if(substring(mSetObj$dataSet$format,4,5)=="ts"){
+ mSetObj$dataSet$edit.facA <- facA;
+ mSetObj$dataSet$edit.facB <- facB;
+ }
+
+ if(.on.public.web){
+ .set.mSet(mSetObj);
+ return(length(levels(mSetObj$dataSet$edit.cls)));
+ }else{
+ return(.set.mSet(mSetObj));
+ }
+}
+
+# should always init (new or overwrite previous prenorm object)
+# note in right order that dataSet$edit will always performed using dataSet$filt (if it exists)
+# note dataSet$filt can be re-performed after dataSet$edit during analysis
+# need to make sure prenorm created using the latest information (based on both)
+
+#'Prepare data for normalization
+#'@description Function should always be initialized (new or overwrite previous prenorm object).
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@import qs
+#'@export
+
+PreparePrenormData1 <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(!is.null(mSetObj$dataSet$edit)){
+ mydata <- mSetObj$dataSet$edit;
+ if(!is.null(mSetObj$dataSet$filt)){
+ # some features could be removed
+ hit.inx <- colnames(mydata) %in% colnames(mSetObj$dataSet$filt);
+ mydata <- mydata[,hit.inx, drop=FALSE];
+ }
+ prenorm <- mydata;
+ mSetObj$dataSet$prenorm.cls <- mSetObj$dataSet$edit.cls;
+ if(substring(mSetObj$dataSet$format,4,5) == "ts"){
+ mSetObj$dataSet$prenorm.facA <- mSetObj$dataSet$edit.facA;
+ mSetObj$dataSet$prenorm.facB <- mSetObj$dataSet$edit.facB;
+ }
+ }else if(!is.null(mSetObj$dataSet$filt)){
+ prenorm <- mSetObj$dataSet$filt;
+ mSetObj$dataSet$prenorm.cls <- mSetObj$dataSet$filt.cls;
+ if(substring(mSetObj$dataSet$format,4,5)=="ts"){
+ mSetObj$dataSet$prenorm.facA <- mSetObj$dataSet$filt.facA;
+ mSetObj$dataSet$prenorm.facB <- mSetObj$dataSet$filt.facB;
+ }
+ }else{
+ prenorm <- mSetObj$dataSet$proc;
+ mSetObj$dataSet$prenorm.cls <- mSetObj$dataSet$proc.cls;
+ if(substring(mSetObj$dataSet$format,4,5) == "ts"){
+ mSetObj$dataSet$prenorm.facA <- mSetObj$dataSet$proc.facA;
+ mSetObj$dataSet$prenorm.facB <- mSetObj$dataSet$proc.facB;
+ }
+ }
+ qs::qsave(prenorm, "prenorm.qs");
+ mSetObj$dataSet$prenorm.smpl.nms <- rownames(prenorm);
+ mSetObj$dataSet$prenorm.feat.nms <- colnames(prenorm);
+ .set.mSet(mSetObj)
+}
+
+##############################################
+##############################################
+########## Utilities for web-server ##########
+##############################################
+##############################################
+
+# get the dropdown list for sample normalization view
+GetPrenormSmplNms <-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$dataSet$prenorm.smpl.nms);
+}
+
+GetPrenormFeatureNum <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(length(mSetObj$dataSet$prenorm.feat.nms));
+}
+
+GetPrenormFeatureNms <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$dataSet$prenorm.feat.nms);
+}
+
+ValidateFeatureName<- function(mSetObj=NA, nm){
+ mSetObj <- .get.mSet(mSetObj);
+ if(nm %in% mSetObj$dataSet$prenorm.feat.nms){
+ return(1);
+ }
+ return(0);
+}
+
+GetPrenormClsNms <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(levels(mSetObj$dataSet$prenorm.cls));
+}
+
+########## Utility Functions ###############
+GetRandomSubsetIndex<-function(total, sub.num = 50){
+ if(total < sub.num){
+ 1:total;
+ }else{
+ sample(1:total, sub.num);
+ }
+}
+
+# Test if data require genefilter version
+# if so, then microservice will be used
+RequireFastUnivTests <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ if(ncol(mSetObj$dataSet$norm) < 1000){
+ return(FALSE);
+ }else{
+ return(TRUE);
+ }
+}
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/general_proc_utils.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/general_proc_utils.R
new file mode 100755
index 0000000000000000000000000000000000000000..8c12096a37d12c2cc72291adc102d29f374a4251
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/general_proc_utils.R
@@ -0,0 +1,653 @@
+#'Sanity Check Data
+#'@description SanityCheckData is used for data processing, and performs a basic sanity
+#'check of the uploaded content, ensuring that the data is suitable for further analysis.
+#'The function will return a message if the data has successfully passed the check
+#'and is deemed suitable for further analysis. If it fails, the function will return a 0.
+#'The function will perform the check directly onto the mSet$dataSet object, and must
+#'be performed immediately after reading in data.
+#'The sanity check function evaluates the accuracy of sample and class labels, data structure,
+#'deals with non-numeric values, removes columns that are constant across all samples (variance = 0),
+#'and by default replaces missing values with half of the original minimal positive value in your dataset.
+#'@usage SanityCheckData(mSetObj=NA)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@import qs
+#'@export
+#'
+SanityCheckData1 <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(file.exists("peakSet.qs") & !file.exists("data_orig.qs")){
+ return(.set.mSet(mSetObj));
+ }
+
+ orig.data <- qs::qread("data_orig.qs");
+ msg <- NULL;
+ cls <- mSetObj$dataSet$orig.cls;
+ mSetObj$dataSet$small.smpl.size <- 0;
+
+ # check class info
+ if(mSetObj$dataSet$cls.type == "disc"){
+ if(substring(mSetObj$dataSet$format,4,5)=="ts"){
+ if(mSetObj$dataSet$design.type =="time"){
+ msg<-c(msg, "The data is time-series data.");
+ }else if(mSetObj$dataSet$design.type =="time0"){
+ msg<-c(msg, "The data is time-series only data.");
+ }else{
+ msg<-c(msg, "The data is not time-series data.");
+ }
+ clsA.num <- length(levels(mSetObj$dataSet$facA));
+ clsB.num <- length(levels(mSetObj$dataSet$facB));
+ msg<-c(msg, paste(clsA.num, "groups were detected in samples for factor", mSetObj$dataSet$facA.lbl));
+ msg<-c(msg, paste(clsB.num, "groups were detected in samples for factor", mSetObj$dataSet$facB.lbl));
+ }else{
+ if(mSetObj$dataSet$paired){
+ msg<-c(msg,"Samples are paired.");
+ # need to first set up pair information if not csv file
+ if(!(mSetObj$dataSet$type=="conc" | mSetObj$dataSet$type=="specbin" | mSetObj$dataSet$type=="pktable" )){
+ pairs <- ReadPairFile();
+ # check if they are of the right length
+ if(length(pairs)!=length(mSetObj$dataSet$orig.smp.nms)){
+ AddErrMsg("Error: the total paired names are not equal to sample names.");
+ return(0);
+ }else{
+ # matching the names of the files
+ inx<-match(mSetObj$dataSet$orig.smp.nms, names(pairs));
+ #check if all matched exactly
+ if(sum(is.na(inx))>0){
+ AddErrMsg("Error: some paired names not match the sample names.");
+ return(0);
+ }else{
+ mSetObj$dataSet$pairs <- pairs[inx];
+ }
+ }
+ }
+
+ pairs <- mSetObj$dataSet$pairs;
+
+ # check if QC samples are present
+ qc.hits <- tolower(as.character(cls)) %in% "qc";
+ if(sum(qc.hits) > 0){
+ AddErrMsg("<font color='red'>Error: QC samples not supported in paired analysis mode.</font>");
+ AddErrMsg("You can perform QC filtering using regular two-group labels.");
+ AddErrMsg("Then re-upload your data (without QC samples) for paired analysis.");
+ return(0);
+ }else{
+ pairs <- as.numeric(pairs);
+ }
+
+ label <- as.numeric(pairs);
+ cls <- as.factor(ifelse(label>0,1,0));
+ mSetObj$dataSet$pairs <- label;
+
+ lev <- unique(pairs);
+ uni.cl <- length(lev);
+ uni.cl.abs <- uni.cl/2;
+ sorted.pairs <- sort(pairs,index=TRUE);
+
+ if(!all(sorted.pairs$x==c(-uni.cl.abs:-1,1:uni.cl.abs))){
+ AddErrMsg("There are some problems in paired sample labels! ");
+ if(uni.cl.abs != round(uni.cl.abs)){
+ duplicates <- pairs[duplicated(pairs)]
+ dup.msg <- paste0("Duplicated labels:", duplicates)
+ AddErrMsg(paste("The total samples must be of even number!", dup.msg));
+ }else{
+ AddErrMsg(paste("And class labels between ",-uni.cl.abs,
+ " and 1, and between 1 and ",uni.cl.abs,".",sep=""));
+ }
+ return(0);
+ } else {
+ msg <- c(msg,"The labels of paired samples passed sanity check.");
+ msg <- c(msg, paste("A total of", uni.cl.abs, "pairs were detected."));
+ # make sure paired samples are sorted 1:n/2 and -1:-n/2
+
+ x<-sorted.pairs$ix[(uni.cl.abs+1):uni.cl]
+ y<-sorted.pairs$ix[uni.cl.abs:1]
+ index<-as.vector(cbind(x,y));
+ cls<-cls[index];
+ pairs <- pairs[index];
+ mSetObj$dataSet$pairs <- pairs;
+ mSetObj$dataSet$orig.cls <- cls;
+ orig.data<- orig.data[index,];
+ qs::qsave(orig.data, file="data_orig.qs");
+ }
+ } else {
+
+ # check for class labels at least two replicates per class but QC and BLANK
+ cls.lbl <- mSetObj$dataSet$orig.cls;
+ qb.inx <- tolower(cls.lbl) %in% c("qc", "blank");
+ if(sum(qb.inx) > 0){
+ cls.Clean <- as.factor(as.character(cls.lbl[!qb.inx])); # make sure drop level
+ } else {
+ cls.Clean <- cls.lbl;
+ }
+
+ # allow it pass to sanity check and correct there
+ if(anal.type != "network"){ # add exception for DSPC correlation network
+ if(min(table(cls.Clean)) < 3 | length(levels(cls.Clean)) < 2){
+ AddErrMsg(paste ("A total of", length(levels(cls.Clean)), "groups found with", length(cls.Clean), "samples."));
+ AddErrMsg("<font color='red'>At least <b>two</b> groups and <b>three replicates</b> per group are required for analysis</font>!");
+ AddErrMsg("You can click the <b>Edit Groups</b> button below to see the group labels for each sample and make corrections.");
+ return(-1);
+ }
+ }
+
+ if("NMDR_id" %in% names(mSetObj$dataSet)){
+ msg <- c(msg, paste("Study", mSetObj$dataSet$NMDR_id, "was successfully downloaded from the Metabolomics Workbench!"))
+ }
+ msg <- c(msg,"Samples are not paired.");
+ }
+
+ # checking if too many groups but a few samples in each group
+ cls.lbl <- mSetObj$dataSet$orig.cls;
+ # need to exclude QC or blank
+ qb.inx <- tolower(cls.lbl) %in% c("qc", "blank");
+ if(sum(qb.inx) > 0){
+ cls.lbl <- as.factor(as.character(cls.lbl[!qb.inx])); # make sure drop level
+ }
+ min.grp.size <- min(table(cls.lbl));
+ cls.num <- length(levels(cls.lbl));
+ if(cls.num/min.grp.size > 3){
+ mSetObj$dataSet$small.smpl.size <- 1;
+ msg <- c(msg, "<font color='red'>Too many groups with very small number of replicates!</font>");
+ msg <- c(msg, "<font color='red'>Only a subset of methods will be available for analysis!</font>");
+ }
+
+ msg <- c(msg, paste(cls.num, "groups were detected in samples."));
+
+ if("NMDR_id" %in% names(mSetObj$dataSet)){
+ msg <- c(msg, paste("Study", mSetObj$dataSet$NMDR_id, "group labels:", paste0(unique(cls.lbl), collapse = ", ")))
+ }
+
+ mSetObj$dataSet$cls.num <- cls.num;
+ mSetObj$dataSet$min.grp.size <- min.grp.size;
+ }
+
+ #samples may not be sorted properly, need to do some sorting at the beginning
+ if(substring(mSetObj$dataSet$format,4,5)=="ts"){
+ nfacA <- mSetObj$dataSet$facA;
+ nfacB <- mSetObj$dataSet$facB;
+ if(mSetObj$dataSet$design.type =="time" | mSetObj$dataSet$design.type =="time0"){
+ # determine time factor and should order first by subject then by each time points
+ if(tolower(mSetObj$dataSet$facA.lbl) == "time"){
+ time.fac <- nfacA;
+ exp.fac <- nfacB;
+ }else{
+ time.fac <- nfacB;
+ exp.fac <- nfacA;
+ }
+ # update with new index
+ ord.inx <- order(exp.fac);
+ }else{
+ ord.inx <- order(nfacA);
+ }
+ mSetObj$dataSet$orig.cls <- mSetObj$dataSet$orig.cls[ord.inx];
+ mSetObj$dataSet$facA <- mSetObj$dataSet$orig.facA <- mSetObj$dataSet$facA[ord.inx];
+ mSetObj$dataSet$facB <- mSetObj$dataSet$orig.facB <- mSetObj$dataSet$facB[ord.inx];
+ orig.data <- orig.data[ord.inx,];
+ qs::qsave(orig.data, file="data_orig.qs");
+ }else{
+ ord.inx <- order(mSetObj$dataSet$orig.cls);
+ mSetObj$dataSet$orig.cls <- cls[ord.inx];
+ orig.data <- orig.data[ord.inx, , drop=FALSE];
+ qs::qsave(orig.data, file="data_orig.qs");
+ if(mSetObj$dataSet$paired){
+ mSetObj$dataSet$pairs <- mSetObj$dataSet$pairs[ord.inx];
+ }
+ }
+ }
+ msg<-c(msg,"Only English letters, numbers, underscore, hyphen and forward slash (/) are allowed.");
+ msg<-c(msg,"<font color=\"orange\">Other special characters or punctuations (if any) will be stripped off.</font>");
+
+ int.mat <- orig.data;
+
+ if(ncol(int.mat)==1){
+ if(anal.type=="roc"){
+ mSetObj$dataSet$roc_cols <- 1;
+ }else{
+ AddErrMsg("<font color='red'>One-column data is only supported for biomarker analysis.</font>");
+ return(0);
+ }
+ }else{
+ mSetObj$dataSet$roc_cols <- 2;
+ }
+
+ # check numerical matrix
+ rowNms <- rownames(int.mat);
+ colNms <- colnames(int.mat);
+ naNms <- sum(is.na(int.mat));
+
+ num.mat <- apply(int.mat, 2, as.numeric)
+
+ if(sum(is.na(num.mat)) > naNms){
+ # try to remove "," in thousand seperator if it is the cause
+ num.mat <- apply(int.mat,2,function(x) as.numeric(gsub(",", "", x)));
+ if(sum(is.na(num.mat)) > naNms){
+ msg<-c(msg,"<font color=\"red\">Non-numeric values were found and replaced by NA.</font>");
+ }else{
+ msg<-c(msg,"All data values are numeric.");
+ }
+ }else{
+ msg<-c(msg,"All data values are numeric.");
+ }
+
+ int.mat <- num.mat;
+ rownames(int.mat) <- rowNms;
+ colnames(int.mat)<- colNms;
+
+ # check for columns with all constant (var =0)
+ varCol <- apply(int.mat, 2, var, na.rm=T);
+
+ constCol <- (varCol == 0 | is.na(varCol));
+ constNum <- sum(constCol, na.rm=T);
+ if(constNum > 0){
+ msg<-c(msg, paste("<font color=\"red\">", constNum, "features with a constant or single value across samples were found and deleted.</font>"));
+ int.mat <- int.mat[,!constCol, drop=FALSE];
+ }
+
+ # check zero, NA values
+ totalCount <- nrow(int.mat)*ncol(int.mat);
+ naCount <- sum(is.na(int.mat));
+ naPercent <- round(100*naCount/totalCount,1)
+
+ mSetObj$dataSet$missingCount <- naCount;
+
+ msg<-c(msg, paste("A total of ", naCount, " (", naPercent, "%) missing values were detected.", sep=""));
+ msg<-c(msg, "<u>By default, missing values will be replaced by 1/5 of min positive values of their corresponding variables</u>",
+ "Click the <b>Skip</b> button if you accept the default practice;",
+ "Or click the <b>Missing value imputation</b> to use other methods.");
+
+ qs::qsave(as.data.frame(int.mat), "preproc.qs");
+ mSetObj$dataSet$proc.cls <- mSetObj$dataSet$cls <- mSetObj$dataSet$orig.cls;
+
+ if(substring(mSetObj$dataSet$format,4,5)=="ts"){
+ mSetObj$dataSet$proc.facA <- mSetObj$dataSet$orig.facA;
+ mSetObj$dataSet$proc.facB <- mSetObj$dataSet$orig.facB;
+ }
+
+ mSetObj$msgSet$check.msg <- c(mSetObj$msgSet$read.msg, msg);
+ if(!.on.public.web){
+ print(c("Successfully passed sanity check!", msg))
+ }
+ return(.set.mSet(mSetObj));
+}
+
+#'Replace missing or zero values
+#'@description This function will replace zero/missing values by half of the smallest
+#'positive value in the original dataset.
+#'This method will be called after all missing value imputations are conducted.
+#'Also, it directly modifies the mSet$dataSet$proc if executed after normalization,
+#'or the mSet$dataSet$norm if before normalization.
+#'@usage ReplaceMin(mSetObj=NA)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@import qs
+#'@export
+#'
+ReplaceMin1 <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ #Reset to default
+ mSetObj$dataSet$proc <- mSetObj$dataSet$filt <- mSetObj$dataSet$edit <- NULL;
+
+ # replace zero and missing values using Detection Limit for each variable
+ preproc <- qs::qread("preproc.qs");
+ int.mat <- ReplaceMissingByLoD(preproc);
+
+ # note, this is last step of processing, also save to proc
+ mSetObj$dataSet$proc <- as.data.frame(int.mat);
+ mSetObj$msgSet$replace.msg <- paste("Zero or missing values were replaced by 1/5 of the min positive value for each variable.");
+ invisible(gc()); # suppress gc output
+
+ return(.set.mSet(mSetObj));
+}
+
+#'Data processing: remove variables with missing values
+#'@description Remove variables based upon a user-defined percentage cut-off of missing values.
+#'If a user specifies a threshold of 20% (0.2), it will remove variables that are missing
+#'in at least 20% of all samples.
+#'@usage RemoveMissingPercent(mSetObj, percent)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param percent Input the percentage cut-off you wish to use. For instance, 50 percent is represented by percent=0.5.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@import qs
+#'@export
+#'
+RemoveMissingPercent <- function(mSetObj=NA, percent=perct){
+
+ mSetObj <- .get.mSet(mSetObj);
+ if(!.on.public.web & !is.null(mSetObj$dataSet$norm)){
+ int.mat <- mSetObj$dataSet$norm;
+ good.inx <- apply(is.na(int.mat), 2, sum)/nrow(int.mat)<percent;
+ mSetObj$dataSet$norm <- as.data.frame(int.mat[,good.inx, drop=FALSE]);
+ }else{
+ int.mat <- qs::qread("preproc.qs");
+ good.inx <- apply(is.na(int.mat), 2, sum)/nrow(int.mat)<percent;
+ preproc <- as.data.frame(int.mat[,good.inx, drop=FALSE]);
+ qs::qsave(preproc, "preproc.qs");
+ }
+ mSetObj$msgSet$replace.msg <- c(mSetObj$msgSet$replace.msg, paste(sum(!good.inx), "variables were removed for threshold", round(100*percent, 2), "percent."));
+ return(.set.mSet(mSetObj));
+}
+
+#'Data processing: Replace missing variables
+#'@description Replace missing variables by min/mean/median/KNN/BPCA/PPCA/svdImpute.
+#'@usage ImputeMissingVar(mSetObj, method)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param method Select the option to replace missing variables, either
+#'replacement based on the minimum ("min), the mean ("mean"), or the median ("median") value of each feature columns,
+#'or several options to impute the missing values, using k-nearest neighbour ("KNN"), probabilistic PCA ("PPCA"),
+#'Bayesian PCA ("BPCA") method, or Singular Value Decomposition ("svdImpute")
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@import qs
+#'@export
+#'
+ImputeMissingVar <- function(mSetObj=NA, method="min"){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ int.mat <- qs::qread("preproc.qs");
+ new.mat <- NULL;
+ msg <- mSetObj$msgSet$replace.msg;
+
+ if(method=="exclude"){
+ good.inx<-apply(is.na(int.mat), 2, sum)==0
+ new.mat<-int.mat[,good.inx, drop=FALSE];
+ msg <- c(msg,"Variables with missing values were excluded.");
+
+ }else if(method=="min"){
+ new.mat<- ReplaceMissingByLoD(int.mat);
+ msg <- c(msg,"Missing variables were replaced by LoDs (1/5 of the min positive value for each variable)");
+ }else if(method=="colmin"){
+ new.mat<-apply(int.mat, 2, function(x){
+ if(sum(is.na(x))>0){
+ x[is.na(x)]<-min(x,na.rm=T)/2;
+ }
+ x;
+ });
+ msg <- c(msg,"Missing variables were replaced by 1/2 of min values for each feature column.");
+ }else if (method=="mean"){
+ new.mat<-apply(int.mat, 2, function(x){
+ if(sum(is.na(x))>0){
+ x[is.na(x)]<-mean(x,na.rm=T);
+ }
+ x;
+ });
+ msg <- c(msg,"Missing variables were replaced with the mean value for each feature column.");
+ }else if (method == "median"){
+ new.mat<-apply(int.mat, 2, function(x){
+ if(sum(is.na(x))>0){
+ x[is.na(x)]<-median(x,na.rm=T);
+ }
+ x;
+ });
+ msg <- c(msg,"Missing variables were replaced with the median for each feature column.");
+ }else{
+ if(method == "knn_var"){
+ new.mat<-t(impute::impute.knn(t(int.mat))$data);
+ }else if(method == "knn_smp"){
+ new.mat<-impute::impute.knn(data.matrix(int.mat))$data;
+ }else{
+ if(method == "bpca"){
+ new.mat<-pcaMethods::pca(int.mat, nPcs =5, method="bpca", center=T)@completeObs;
+ }else if(method == "ppca"){
+ new.mat<-pcaMethods::pca(int.mat, nPcs =5, method="ppca", center=T)@completeObs;
+ }else if(method == "svdImpute"){
+ new.mat<-pcaMethods::pca(int.mat, nPcs =5, method="svdImpute", center=T)@completeObs;
+ }
+ }
+ msg <- c(msg, paste("Missing variables were imputated using", toupper(method)));
+ }
+
+ mSetObj$dataSet$proc <- as.data.frame(new.mat);
+ mSetObj$msgSet$replace.msg <- msg;
+ return(.set.mSet(mSetObj))
+}
+
+
+#'Methods for non-specific filtering of variables
+#'@description This is a function that filters the dataset, dependent on the user-specified method
+#'for filtering. The function applies a filtering method, ranks the variables within the dataset,
+#'and removes variables based on its rank. The final dataset should contain no more than
+#'than 5000 variables for effective computing.
+#'@usage FilterVariable(mSetObj=NA, filter, qcFilter, rsd)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param filter Select the filter option, "rsd" which is the relative standard deviation, "nrsd" which
+#'is the non-parametric relative standard deviation, "mean" which is the mean, "sd" which is the standard
+#'deviation, "mad" which is the median absolute deviation, or "iqr" which is the interquantile range.
+#'@param qcFilter Filter the variables based on QC samples - True (T), or use non-QC based filtering - False (F).
+#'@param rsd Define the relative standard deviation cut-off. Variables with a RSD greater than this number
+#'will be removed from the dataset. It is only necessary to specify this argument if qcFilter is True (T).
+#'Otherwise, it will not be used in the function.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+FilterVariable <- function(mSetObj=NA, filter, qcFilter, rsd){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ #Reset to default
+ mSetObj$dataSet$filt <- NULL;
+
+ int.mat <- as.matrix(mSetObj$dataSet$proc);
+ cls <- mSetObj$dataSet$proc.cls;
+
+ # save a copy
+ mSetObj$dataSet$filt.cls <- cls;
+ if(substring(mSetObj$dataSet$format,4,5)=="ts"){
+ mSetObj$dataSet$filt.facA <- mSetObj$dataSet$proc.facA;
+ mSetObj$dataSet$filt.facB <- mSetObj$dataSet$proc.facB;
+ }
+
+ msg <- "";
+ if(qcFilter == "T"){
+ rsd <- rsd/100;
+ # need to check if QC exists
+ qc.hits <- tolower(as.character(cls)) %in% "qc";
+ if(sum(qc.hits) > 2){ # require at least 3 QC for RSD
+ qc.mat <- int.mat[qc.hits,];
+ sds <- apply(qc.mat, 2, sd, na.rm=T);
+ mns <- apply(qc.mat, 2, mean, na.rm=T);
+ rsd.vals <- abs(sds/mns);
+ gd.inx <- rsd.vals < rsd;
+ int.mat <- int.mat[,gd.inx];
+ msg <- paste("Removed ", sum(!gd.inx), " features based on QC RSD values. QC samples are still kept. You can remove them later.");
+ }else if(sum(qc.hits) > 0){
+ AddErrMsg("RSD requires at least 3 QC samples, and only non-QC based filtering can be applied.");
+ return(0);
+ }else{
+ AddErrMsg("No QC Samples (with class label: QC) found. Please use non-QC based filtering.");
+ return(0);
+ }
+ }
+
+ feat.num <- ncol(int.mat);
+ feat.nms <- colnames(int.mat);
+ nm <- NULL;
+ if(filter == "none" && feat.num < 5000){ # only allow for less than 4000
+ remain <- rep(TRUE, feat.num);
+ msg <- paste(msg, "No non-QC based data filtering was applied");
+ }else{
+ if (filter == "rsd" ){
+ sds <- apply(int.mat, 2, sd, na.rm=T);
+ mns <- apply(int.mat, 2, mean, na.rm=T);
+ filter.val <- abs(sds/mns);
+ nm <- "Relative standard deviation";
+ }else if (filter == "nrsd" ){
+ mads <- apply(int.mat, 2, mad, na.rm=T);
+ meds <- apply(int.mat, 2, median, na.rm=T);
+ filter.val <- abs(mads/meds);
+ nm <- "Non-paramatric relative standard deviation";
+ }else if (filter == "mean"){
+ filter.val <- apply(int.mat, 2, mean, na.rm=T);
+ nm <- "mean";
+ }else if (filter == "sd"){
+ filter.val <- apply(int.mat, 2, sd, na.rm=T);
+ nm <- "standard deviation";
+ }else if (filter == "mad"){
+ filter.val <- apply(int.mat, 2, mad, na.rm=T);
+ nm <- "Median absolute deviation";
+ }else if (filter == "median"){
+ filter.val <- apply(int.mat, 2, median, na.rm=T);
+ nm <- "median";
+ }else{ # iqr
+ filter.val <- apply(int.mat, 2, IQR, na.rm=T);
+ nm <- "Interquantile Range";
+ }
+
+ # get the rank of the filtered variables
+ rk <- rank(-filter.val, ties.method='random');
+
+ var.num <- ncol(int.mat);
+ if(var.num < 250){ # reduce 5%
+ remain <- rk < var.num*0.95;
+ msg <- paste(msg, "Further feature filtering based on", nm);
+ }else if(ncol(int.mat) < 500){ # reduce 10%
+ remain <- rk < var.num*0.9;
+ msg <- paste(msg, "Further feature filtering based on", nm);
+ }else if(ncol(int.mat) < 1000){ # reduce 25%
+ remain <- rk < var.num*0.75;
+ msg <- paste(msg, "Further feature filtering based on", nm);
+ }else{ # reduce 40%, if still over 5000, then only use top 5000
+ remain <- rk < var.num*0.6;
+ msg <- paste(msg, "Further feature filtering based on", nm);
+
+ if(mSetObj$analSet$type == "mummichog"){
+ max.allow <- 7500;
+ }else if(mSetObj$analSet$type == "power"){
+ max.allow <- 5000;
+ }else{
+ max.allow <- 2500;
+ }
+
+ if(sum(remain) > max.allow){
+ remain <-rk < max.allow;
+ msg <- paste(msg, paste("Reduced to", max.allow, "features based on", nm));
+ }
+ }
+ }
+
+ mSetObj$dataSet$filt <- int.mat[, remain];
+ mSetObj$msgSet$filter.msg <- msg;
+ AddMsg(msg);
+
+ return(.set.mSet(mSetObj));
+}
+
+##############################################
+##############################################
+########## Utilities for web-server ##########
+##############################################
+##############################################
+
+GetOrigSmplNms <-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$dataSet$orig.smp.nms);
+}
+
+GetOrigGrpNms <-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$dataSet$orig.cls);
+}
+
+GetGroupNumber<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(length(levels(mSetObj$dataSet$cls)));
+}
+
+#'Check if the sample size is small
+#'@description Returns whether or not the sanity check found that there were too many
+#'groups in the dataset containing too few samples. It will return a 0 if the data passes the check,
+#'or will return a 1 if the data does not.
+#'@usage IsSmallSmplSize(mSetObj=NA)
+#'@param mSetObj Input name of the created mSet Object
+#'@export
+#'
+IsSmallSmplSize<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ print(mSetObj$dataSet$small.smpl.size);
+ return(.set.mSet(mSetObj));
+}
+
+GetMinGroupSize<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$dataSet$min.grp.size);
+}
+
+IsDataContainsNegative<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$dataSet$containsNegative);
+}
+
+# users can manually update sample names
+UpdateFeatureName<-function(mSetObj=NA, old.nm, new.nm){
+ mSetObj <- .get.mSet(mSetObj);
+ if(!is.null(mSetObj$dataSet[["orig"]])){
+ orig.data <- qs::qread("data_orig.qs");
+ orig.data <- .update.feature.nm(orig.data, old.nm, new.nm);
+ qs::qsave(orig.data, file="data_orig.qs");
+ }
+
+ if(!is.null(mSetObj$dataSet[["proc"]])){
+ mSetObj$dataSet$proc <- .update.feature.nm(mSetObj$dataSet$proc, old.nm, new.nm);
+ if(!is.null(mSetObj$dataSet[["filt"]])){
+ mSetObj$dataSet$filt <- .update.feature.nm(mSetObj$dataSet$filt, old.nm, new.nm);
+ }
+ }
+
+ if(!is.null(mSetObj$dataSet[["norm"]])){
+ mSetObj$dataSet$norm <- .update.feature.nm(mSetObj$dataSet$norm, old.nm, new.nm);
+ }
+ return(.set.mSet(mSetObj));
+}
+
+.update.feature.nm<-function(dat, old.nm, new.nm){
+ hit.inx <- match(old.nm, colnames(dat));
+ if(!is.na(hit.inx)){
+ colnames(dat)[hit.inx] <- new.nm;
+ }
+ return(dat);
+}
+
+UpdateSampleGroups<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ cls.lbl <- ClearStrings(as.vector(grp.vec));
+ mSetObj$dataSet$orig.cls <- mSetObj$dataSet$cls <- as.factor(cls.lbl);
+ return(.set.mSet(mSetObj));
+}
+
+#'Check for missing data
+#'@description ContainMissing is used to check if any missing data exists in the uploaded file.
+#'@usage ContainMissing(mSetObj=NA)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+ContainMissing1 <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ if(.on.public.web){
+ if(mSetObj$dataSet$missingCount > 0){
+ return(1);
+ }
+ return(0);
+ }else{
+ if(mSetObj$dataSet$missingCount > 0){
+ print("Contains missing data - will be dealt with in next step.");
+ }
+ print("Does not contain missing data.");
+ return(.set.mSet(mSetObj));
+ }
+}
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/generic_c_utils.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/generic_c_utils.R
new file mode 100755
index 0000000000000000000000000000000000000000..d81870fcfb15372b892c1159487900f21d4daa0c
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/generic_c_utils.R
@@ -0,0 +1,33 @@
+#' MetaboAnalystR: A package for computating the notorious bar statistic.
+#'
+#' The MetaboAnalystR package provides a pipeline for metabolomics processing.
+#'
+#' @section MetaboAnalystR functions:
+#' The MetaboAnalystR functions ...
+#'
+#' @docType package
+#' @name MetaboAnalystR
+#' @useDynLib MetaboAnalystR, .registration=TRUE, .fixes = "C_"
+NULL
+#> NULL
+
+
+######### ======= ------------- C function Bin: Batch Effect Module ----------- ======== #########
+
+#' Internal C fucntion - C_imodwt_r
+#' @references Percival, D. B. and A. T. Walden (2000) Wavelet Methods for Time Series Analysis, Cambridge University Press.
+ C_imodwt_r <- function(y,z,N,j, L, ht, gt, XX){
+ if (.on.public.web){ .C("imodwt", y, z, N, j, L, ht, gt, out=XX)$out} else{
+ .C(C_imodwt, y, z, N, j, L, ht, gt, out=XX, PACKAGE = "MetaboAnalystR")$out}
+ }
+
+#' Internal C fucntion - C_modwt_r
+#' @references Percival, D. B. and A. T. Walden (2000) Wavelet Methods for Time Series Analysis, Cambridge University Press.
+ C_modwt_r <- function(X,N,j, L, ht, gt,W, V){
+ if (.on.public.web){ .C("modwt", X, N, as.integer(j), L,ht, gt, W = W, V = V)[7:8]} else {
+ .C(C_modwt, X, N, as.integer(j), L, ht, gt, W = W, V = V, PACKAGE = "MetaboAnalystR")[7:8]}
+ }
+
+############# ============ ------------- Bin bottom ----------- ============ ###########
+
+
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/meta_data_utils.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/meta_data_utils.R
new file mode 100755
index 0000000000000000000000000000000000000000..a0b840a7c9f3e7b9a7ca9fa09e3dd4b88f81c9d7
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/meta_data_utils.R
@@ -0,0 +1,684 @@
+#'Read in individual data
+#'@description This function determines reads in user's individual data for meta-analysis.
+#'@param mSetObj Input name of the created mSet Object
+#'@param dataName Name of inputted dataset.
+#'@param format Specify if samples are paired and in rows (rowp), unpaired and in rows (rowu),
+#'in columns and paired (colp), or in columns and unpaired (colu).
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+ReadIndData <- function(mSetObj=NA, dataName, format="colu"){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ dat <- .readDataTable(dataName);
+ if(class(dat) == "try-error" || ncol(dat) == 1){
+ AddErrMsg("Data format error. Failed to read in the data!");
+ AddErrMsg("Make sure the data table is saved as comma separated values (.csv) format!");
+ AddErrMsg("Please also check the followings: ");
+ AddErrMsg("Either sample or feature names must in UTF-8 encoding; Latin, Greek letters are not allowed.");
+ AddErrMsg("We recommend to use a combination of English letters, underscore, and numbers for naming purpose.");
+ AddErrMsg("Make sure sample names and feature (peak, compound) names are unique.");
+ AddErrMsg("Missing values should be blank or NA without quote.");
+ return(0);
+ }
+
+ #mSetObj$dataSet <- list();
+ mSetObj$dataSet$data.orig <- dat;
+ mSetObj$dataSet$format <- format;
+ mSetObj$dataSet$name <- dataName;
+
+ if(.on.public.web){
+ .set.mSet(mSetObj)
+ return(RegisterData(mSetObj, mSetObj$dataSet));
+ }else{
+ RegisterData(mSetObj, mSetObj$dataSet)
+ return(.set.mSet(mSetObj));
+ }
+}
+
+#'Register data in R
+#'@description When there are multiple datasets, record their name and save the inputted data as
+#'a .qs file to save memory. Note, the memory will only contain one mSetObj$dataSet object. By default the last one
+#'will be the most recent/current dataSet object. Users can switch which data to load into memory.
+#'@param mSetObj Input name of the created mSet Object
+#'@param dataSet Input dataset to be registered in R.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@import qs
+#'@export
+
+RegisterData <- function(mSetObj=NA, dataSet){
+
+ mSetObj <- .get.mSet(mSetObj);
+ dataName <- dataSet$name;
+ qs::qsave(dataSet, file=dataName);
+ dataSet <<- dataSet; # redundant? have mSetObj$dataSet = 2 copies
+ mdata.all[[dataName]] <<- 1;
+ return(1);
+}
+
+#'Sanity check of individual datasets for meta-analysis
+#'@description Performs a sanity check on each-uploaded dataset for meta-analysis. Briefly, this function
+#'will exclude empty rows, check class labels, ensure only 2 groups are being compared within the dataset,
+#'ensure sample names are unique, remove low quality samples/features, and replace missing values.
+#'@param mSetObj Input name of the created mSet Object
+#'@param dataName Input name of the dataset to perform the sanity check.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@import qs
+#'@export
+#
+SanityCheckIndData<-function(mSetObj=NA, dataName){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(mSetObj$dataSet$name != dataName){
+ dataSet <- qs::qread(dataName);
+ }else{
+ dataSet <- mSetObj$dataSet
+ }
+
+ dat <- dataSet$data.orig;
+
+ msg <- NULL;
+ if(substring(dataSet$format,1,3)=="row"){ # sample in row
+ msg <- "Samples are in rows and features in columns";
+ smpl.nms <-dat[,1];
+ dat[,1] <- NULL;
+ cls.lbl <- dat[,1];
+ conc <- dat[,-1];
+ var.nms <- colnames(conc);
+ }else{ # sample in col
+ msg<-"Samples are in columns and features in rows.";
+ var.nms <- dat[-1,1];
+ dat[,1] <- NULL;
+ smpl.nms <- colnames(dat);
+ cls.lbl <- dat[1,];
+ conc <- t(dat[-1,]);
+ }
+
+ dataSet$cls.orig <- cls.lbl;
+
+ empty.inx <- is.na(smpl.nms) | smpl.nms == ""
+ if(sum(empty.inx) > 0){
+ msg <- c(msg, paste("<font color=\"red\">", sum(empty.inx), "empty rows</font> were detected and excluded from your data."));
+ smpl.nms <- smpl.nms[!empty.inx];
+ cls.lbl <- cls.lbl[!empty.inx];
+ conc <- conc[!empty.inx, ];
+ }else{
+ msg <- c(msg, "No empty rows were found in your data.");
+ }
+
+ # try to check & remove empty lines if class label is empty
+ # Added by B. Han
+ empty.inx <- is.na(cls.lbl) | cls.lbl == ""
+ if(sum(empty.inx) > 0){
+ msg <- c(msg, paste("<font color=\"red\">", sum(empty.inx), "empty labels</font> were detected and excluded from your data."));
+ smpl.nms <- smpl.nms[!empty.inx];
+ cls.lbl <- cls.lbl[!empty.inx];
+ conc <- conc[!empty.inx, ];
+ }else{
+ msg <- c(msg, "No empty labels were found in your data.");
+ }
+
+ if(length(unique(cls.lbl[!empty.inx])) > 2){
+ msg <- c(msg, paste(c("Groups found:", unique(cls.lbl[!empty.inx])), collapse=" "));
+ msg <- c(msg, "<font color=\"red\">Meta-analysis is only defined for two-group comparisions!</font>");
+ current.msg <<- msg;
+ return(0);
+ }else{
+ lvls <- as.character(unique(unlist(cls.lbl)))
+ msg <- c(msg, paste("Two groups found:", lvls[1], "and", lvls[2], collapse=" "));
+ }
+
+ # check for uniqueness of dimension name
+ if(length(unique(smpl.nms))!=length(smpl.nms)){
+ dup.nm <- paste(smpl.nms[duplicated(smpl.nms)], collapse=" ");
+ msg <- c(msg, "Duplicate sample names are not allowed!");
+ current.msg <<- msg;
+ return(0);
+ }else{
+ msg <- c(msg, "All sample names are unique.");
+ }
+
+ # try to remove check & remove empty line if feature name is empty
+ empty.inx <- is.na(var.nms) | var.nms == "";
+ if(sum(empty.inx) > 0){
+ msg <- c(msg, paste("<font color=\"red\">", sum(empty.inx), "empty features</font> were detected and excluded from your data."));
+ var.nms <- var.nms[!empty.inx];
+ conc <- conc[,!empty.inx];
+ }else{
+ msg <- c(msg, "No empty feature names found");
+ }
+
+ if(length(unique(var.nms))!=length(var.nms)){
+ dup.inx <- which(duplicated(var.nms));
+ msg <- c(msg, paste("Error: a total of", length(dup.inx), "duplicate feature names found!"));
+ if(length(dup.inx) > 9){
+ dup.inx <- dup.inx[1:9];
+ }
+ dup.nm <- paste("Duplicated names [max 9]: ", var.nms[dup.inx], collapse=" ");
+ AddErrMsg(dup.nm);
+ current.msg <<- msg;
+ return(0);
+ }else{
+ msg <- c(msg, "All feature names are unique");
+ }
+
+ # now check for special characters in the data labels
+ if(sum(is.na(iconv(smpl.nms)))>0){
+ na.inx <- is.na(iconv(smpl.nms));
+ nms <- paste(smpl.nms[na.inx], collapse="; ");
+ msg <- c(msg, paste("No special letters (i.e. Latin, Greek) are allowed in sample names!", nms, collapse=" "));
+ current.msg <<- msg;
+ return(0);
+ }else{
+ msg <- c(msg, "All sample names are OK");
+ }
+
+ if(sum(is.na(iconv(var.nms)))>0){
+ na.inx <- is.na(iconv(var.nms));
+ nms <- paste(var.nms[na.inx], collapse="; ");
+ msg <- c(msg, paste("No special letters (i.e. Latin, Greek) are allowed in feature names!", nms, collapse=" "));
+ current.msg <<- msg;
+ return(0);
+ }else{
+ msg <- c(msg, "All feature names are OK");
+ }
+
+ # only keep alphabets, numbers, ",", "." "_", "-" "/"
+ smpl.nms <- gsub("[^[:alnum:]./_-]", "", smpl.nms);
+ var.nms <- gsub("[^[:alnum:][:space:],'./_-]", "", var.nms); # allow space, comma and period
+ cls.lbl <- ClearStrings(as.vector(cls.lbl));
+
+ # now assgin the dimension names
+ conc <- apply(conc, 2, as.numeric);
+ rownames(conc) <- smpl.nms;
+ colnames(conc) <- var.nms;
+
+ proc.cls <- as.factor(as.character(cls.lbl));
+
+ # now need to remove low quality samples and genes
+ data <- conc;
+ smpl.num <- nrow(data);
+ gene.num <- ncol(data);
+
+ # remove smpls/exp with over half missing value
+ good.inx<-apply(is.na(data), 1, sum)/ncol(data)<0.6;
+ smpl.msg <- "";
+ if(sum(!good.inx)>0){
+
+ msg <- c(msg, paste(sum(!good.inx), "low quality samples(>60% missing) removed."));
+
+ data <- data[good.inx,];
+ if(nrow(data)/smpl.num < 0.5){
+ msg <- c(msg, paste(msg, "Low quality data rejected!"));
+ current.msg <<- msg;
+ return(0);
+ }
+
+ # update meta information
+ proc.cls <- proc.cls[good.inx];
+ }
+
+ if(ncol(data) < 4){
+ msg <- c(msg, paste("The sample # (", nrow(data), ") is too small."));
+ current.msg <<- msg;
+ return(0);
+ }else{
+ msg <- c(msg, paste("A total of", nrow(data), "samples were found."));
+ }
+
+ # feature with 75% NA will be removed
+ gd.inx<-apply(is.na(data), 2, sum)/nrow(data) < 0.75;
+
+ feat.msg <- "";
+ if(sum(!gd.inx) > 0){
+ data <- data[, gd.inx];
+ msg <- c(msg, paste(sum(!gd.inx), "low quality features (>75% missing) removed"));
+ if(ncol(data)/gene.num < 0.25){
+ msg <- c(msg, paste(feat.msg, "Low quality data rejected."));
+ current.msg <<- msg;
+ return(0);
+ }
+ }
+
+ # feature with 90% ZEROs will be removed
+ gd.inx<-apply(data==0, 2, function(x) {sum(x, na.rm=T)})/nrow(data) < 0.9;
+
+ feat.msg <- "";
+ if(sum(!gd.inx) > 0){
+ data <- data[, gd.inx];
+ msg <- c(msg, paste(sum(!gd.inx), "low quality features (>90% zeros) removed"));
+ if(ncol(data)/gene.num< 0.25){
+ msg <- c(msg, paste(feat.msg, "Low quality data rejected."));
+ current.msg <<- msg;
+ return(0);
+ }
+ }
+
+ if(ncol(data) < 10){
+ msg <- c(msg, "The feature# (", ncol(data), ") is too small (<10).");
+ current.msg <<- msg;
+ return(0);
+ }else{
+ msg <- c(msg, paste("A total of", ncol(data), "features were found.", collapse=" "));
+ }
+
+ # replace missing values should use median for normalized data
+ min.val <- min(data[data>0], na.rm=T)/10;
+ data[is.na(data)] <- min.val;
+ data[data<=0] <- min.val;
+
+ dataSet$check.msg <- msg;
+ dataSet$data.proc <- dataSet$data <- data;
+ dataSet$cls.proc <- dataSet$cls <- factor(proc.cls);
+
+ mSetObj$dataSet <- dataSet
+
+ if(.on.public.web){
+ .set.mSet(mSetObj)
+ return(RegisterData(mSetObj, dataSet));
+ }else{
+ RegisterData(mSetObj, dataSet)
+ return(.set.mSet(mSetObj));
+ }
+}
+
+#removed setcurrentdata, never used?
+
+#'Remove data object, the current dataSet will be the last one by default
+#'@param dataName Input name of data to remove
+#'@export
+RemoveData <- function(dataName){
+ if(!is.null(mdata.all[[dataName]])){
+ mdata.all[[dataName]] <<- NULL;
+ }
+}
+
+#'Select one or more datasets for meta-analysis
+#'@description This function selects one or more datasets to be used for meta-analysis. 1 is used to indicate that
+#'a dataset is selected and by default, all datasets will be selected for meta-analysis.
+#'@param mSetObj Input name of the created mSet Object
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+SelectMultiData <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(!exists('nm.vec')){
+ AddErrMsg("No dataset is selected for analysis!");
+ return(0);
+ }
+
+ all.nms <- names(mdata.all);
+ for(nm in all.nms){
+ if(nm %in% nm.vec){
+ mdata.all[[nm]] <<- 1;
+ }else{
+ mdata.all[[nm]] <<- 0;
+ }
+ }
+
+ if("meta_dat" %in% nm.vec){
+ meta.selected <<- TRUE;
+ }else{
+ meta.selected <<- FALSE;
+ }
+
+ rm('nm.vec', envir = .GlobalEnv);
+
+ return(.set.mSet(mSetObj));
+
+}
+
+#' Get all meta-analysis name data
+#'@export
+GetAllDataNames <- function(){
+ names(mdata.all);
+}
+
+#'Perform normalization for individually-uploaded datasets for meta-analysis
+#'@description This function performs normalization of individuall-uploaded datasets prior to meta-analysis.
+#'@param mSetObj Input name of the created mSet Object
+#'@param dataName Input the name of the individual dataset for normalization.
+#'@param norm.opt Performs log2 normalization "log", or no normalization "none".
+#'@param auto.opt Performs auto-scaling of data (1), or no (0).
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@import qs
+#'@export
+
+PerformIndNormalization <- function(mSetObj=NA, dataName, norm.opt, auto.opt){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(mSetObj$dataSet$name != dataName){
+ dataSet <- qs::qread(dataName);
+ }else{
+ dataSet <- mSetObj$dataSet
+ }
+
+ msg <- NULL;
+ data <- dataSet$data.proc;
+
+ if(norm.opt != "none"){
+ data <- PerformDataNormalization(data, norm.opt);
+ }
+
+ if(auto.opt==1){
+ row.nms <- rownames(data);
+ col.nms <- colnames(data);
+ data <- apply(data, 2, AutoNorm);
+ msg <- paste(msg, "Autoscaling performed.", collapse=" ");
+ rownames(data) <- row.nms;
+ colnames(data) <- col.nms;
+ }
+
+ dataSet$data <- data;
+ dataSet$cls <- dataSet$cls.proc;
+ dataSet$auto_opt <- auto.opt
+
+ mSetObj$dataSet <- dataSet
+ RegisterData(mSetObj, dataSet);
+ AddMsg(msg);
+
+ return(.set.mSet(mSetObj));
+}
+
+PerformDataNormalization <- function(data, norm.opt){
+
+ msg <- NULL;
+ row.nms <- rownames(data);
+ col.nms <- colnames(data);
+ if(norm.opt=="log"){
+ data <- log10(data);
+ msg <- paste(msg, "Log10 transformation.", collapse=" ");
+ }else if(norm.opt=="vsn"){
+ data <- limma::normalizeVSN(data);
+ msg <- paste(msg, "VSN normalization.", collapse=" ");
+ }else if(norm.opt=="quantile"){
+ data <- preprocessCore::normalize.quantiles(data, copy=TRUE);
+ msg <- paste(msg, "Quantile normalization.", collapse=" ");
+ }else{
+ msg <- paste("Unknown normalization: ", norm.opt, collapse=" ");
+ print(msg);
+ return(null);
+ }
+ norm.msg <<- msg;
+ rownames(data) <- row.nms;
+ colnames(data) <- col.nms;
+ return(data);
+}
+
+#'Perform differential expression analysis using Limma for individually-uploaded data.
+#'@description This function performs DE analysis of individually-uploaded data prior to meta-analysis.
+#'@param mSetObj Input name of the created mSet Object
+#'@param dataName Input the name of the individual dataset for normalization.
+#'@param p.lvl Numeric, input the p-value (FDR) cutoff.
+#'@param fc.lvl Numeric, input the fold-change (FC) cutoff.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@import qs
+#'@export
+PerformLimmaDE<-function(mSetObj=NA, dataName, p.lvl=0.1, fc.lvl=0.0){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(mSetObj$dataSet$name != dataName){
+ dataSet <- qs::qread(dataName);
+ }else{
+ dataSet <- mSetObj$dataSet
+ }
+
+ res.limma <- PerformLimma(t(dataSet$data), dataSet$cls);
+ res.all <- GetLimmaResTable(res.limma$fit.obj);
+
+ hit.inx <- abs(res.all$logFC)>= fc.lvl & res.all$adj.P.Val <= p.lvl
+
+ # note, hit.inx can contain NA, not T/F
+ hit.inx <- which(hit.inx);
+ res <- res.all[hit.inx,];
+
+ # rm .txt suffix for new names
+ shortNm <- substring(dataName, 0, nchar(dataName)-4);
+ fileName <- paste("SigFeatures_", shortNm, ".csv",sep="")
+ fast.write.csv(signif(res[,-1],5), file=fileName);
+
+ sig.count <- nrow(res);
+ non.sig.count <- nrow(res.all)-sig.count;
+
+ gc();
+
+ mSetObj$dataSet$deparam <- paste(c("P value cutoff:", p.lvl, "Fold-Change cutoff:", fc.lvl))
+ mSetObj$dataSet$desig <- paste(c("Number of significant features:", sig.count, "Number of non-significant features:", non.sig.count))
+ # record the sig gene vec
+ if(.on.public.web){
+ .set.mSet(mSetObj)
+
+ return(c(1, sig.count, non.sig.count));
+ }else{
+ return(.set.mSet(mSetObj));
+ }
+}
+
+# perfor differential analysis for array/RNA seq data
+# for two groups only (used for meta-analysis)
+PerformLimma<-function(data, group){
+
+ data <- data;
+ design <- model.matrix(~-1 + group);
+ fit = limma::lmFit(data, design)
+
+ grps.cmp <- paste("group", levels(group)[2], " - ", "group", levels(group)[1], sep="");
+ myargs <- list(grps.cmp, levels = design);
+ contrast.matrix <- do.call(limma::makeContrasts, myargs);
+ fit <- limma::contrasts.fit(fit, contrast.matrix)
+ fit <- limma::eBayes(fit);
+ gc();
+ return(list(fit.obj=fit));
+}
+
+#'Get result table from eBayes fit object
+#'@param fit.obj eBayes fit object to parse to a table
+#'@export
+GetLimmaResTable<-function(fit.obj){
+
+ resTable <- limma::topTable(fit.obj, number=Inf, adjust.method="BH");
+ if(!is.null(resTable$ID)){ # for older version
+ rownames(resTable) <- resTable$ID;
+ resTable$ID <- NULL;
+ }
+ return(resTable);
+}
+
+# given a gene id, plot its expression profile as box plot
+
+#'Create a box-plot of a feature's expression pattern across the different datasets
+#'@description This function plots a box-plot of the expression pattern of a user-selected feature
+#'across the different datasets included in meta-analysis.
+#'@param mSetObj Input name of the created mSet Object.
+#'@param gene.id Input the name of the selected feature.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+PlotSelectedFeature<-function(mSetObj=NA, gene.id){
+
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$imgSet$meta.anal$feature <- symb <- gene.id;
+ imgName <- paste(gene.id, ".png", sep="");
+ mSetObj$imgSet$meta.anal$plot <- imgName
+
+ if(.on.public.web){
+ load_lattice()
+ }
+ num <- sum(mdata.all == 1);
+ # calculate width based on the dataset number
+ if(num == 1){
+ Cairo::Cairo(file = imgName, width=280, height=320, type="png", bg="white");
+ myplot <- bwplot(metastat.meta$plot.data[gene.id,] ~ as.character(metastat.meta$cls.lbl), fill="#0000ff22",
+ xlab="Class", ylab="Expression Pattern", main=symb, scales=list(x=list(rot=30)))
+ }else{
+ # calculate layout
+ if(num < 6){
+ layout <- c(num, 1);
+ height=320;
+ width=160*num;
+ }else{
+ rn <- round(num/2);
+ layout <- c(rn, 2);
+ height=500;
+ width=160*rn;
+ }
+
+ Cairo::Cairo(file = imgName, width=width, height=height, type="png", bg="white");
+ data.lbl <- as.character(metastat.meta$data.lbl);
+ data.lbl <- substr(data.lbl, 0, nchar(data.lbl)-4);
+
+ # get counts in each data, same order as a levels
+ counts <- table(data.lbl);
+ # back to factor
+ data.lbl <- factor(data.lbl);
+
+ # get new lbls to cut potential long names, and add sample numbers
+ nlbls <- data.lbl;
+ levels(nlbls) <- abbreviate(levels(nlbls),9);
+ nlbls <- paste(levels(nlbls), "( n=", as.vector(counts), ")");
+ # update labels
+ data.lbl <- factor(data.lbl, labels=nlbls);
+ # some time the transformed plot.data can switch class label, use the original data, need to be similar scale
+ myplot <- bwplot(metastat.meta$plot.data[gene.id,] ~ as.character(metastat.meta$cls.lbl) | data.lbl,
+ xlab="Datasets", ylab="Expression Pattern", main=symb, scales=list(x=list(rot=30)),
+ fill="#0000ff22", layout=layout);
+ }
+
+ print(myplot);
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+##############################################
+##############################################
+########## Utilities for web-server ##########
+##############################################
+##############################################
+
+GetMetaSanityCheckMsg <- function(mSetObj=NA, dataName){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(mSetObj$dataSet$name != dataName){
+ dataSet <- qs::qread(dataName);
+ }
+
+ return(dataSet$check.msg);
+}
+
+GetDataDims <- function(mSetObj=NA, dataName){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(mSetObj$dataSet$name != dataName){
+ dataSet <- qs::qread(dataName);
+ }
+ data <- dataSet$data;
+ dm <- dim(data);
+ naNum <- sum(is.na(data));
+ zoNum <- sum(data == 0);
+ return(c(dm, naNum, zoNum));
+}
+
+GetMetaGroupNames <-function(mSetObj=NA, dataName){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(mSetObj$dataSet$name != dataName){
+ dataSet <- qs::qread(dataName);
+ }
+ return(levels(dataSet$cls));
+}
+
+######################################
+## methods for merged expression data
+#######################################
+
+GlobalCutOff = list(
+ logFC = 0,
+ BHth = 0.05
+)
+
+# function to set up results combining individual data analysis
+# as well as to prepare for GO analysis
+# no return, as set global
+
+SetupMetaStats <- function(BHth){
+
+ GlobalCutOff$BHth <<- BHth;
+ #all common genes
+ gene.ids <- rownames(metastat.meta$data);
+ # meta.sig genes
+ metade.genes <- rownames(meta.mat);
+
+ # setup individual sig genes & stats
+ # that overlap with meta.sig
+ metastat.de <- list();
+
+ pval.mat <- fc.mat <- matrix(nrow=nrow(meta.mat), ncol=sum(mdata.all==1));
+ for(i in 1:length(metastat.ind)){
+ de.res <- metastat.ind[[i]];
+
+ hit.inx <- de.res[,2] <= BHth;
+ hit.inx <- which(hit.inx); # need to get around NA
+ metastat.de[[i]] <- rownames(de.res)[hit.inx];
+
+ # only choose the genes that are also meta sig genes from in
+ # individual analysis for display
+ de.res <- de.res[metade.genes,];
+
+ fc.mat[,i] <- de.res[,1];
+ pval.mat[,i] <- de.res[,2];
+ }
+ names(metastat.de) <- names(metastat.ind);
+
+ # calculate gain/loss
+ deindst <- unique(unlist(metastat.de));
+ gains=metade.genes[which(!(metade.genes %in% deindst))];
+ losses=deindst[which(!(deindst %in% metade.genes))];
+ all.de <- cbind(gene.ids %in% metade.genes, gene.ids %in% deindst);
+ colnames(all.de) <- c("Meta-DE", "Individual-DE");
+ vennC <- getVennCounts(all.de);
+
+ # significant features from individual
+ de.len <- sapply(metastat.de, length);
+ stat <- c(length(metade.genes), de.len);
+ names(stat) <- c("Meta", substr(names(metastat.de), 0, nchar(names(metastat.de))-4));
+ meta.stat <- list(
+ stat = stat,
+ de = metade.genes,
+ idd = gains,
+ loss = losses,
+ venn = vennC
+ );
+
+ fc.mat <<- fc.mat;
+ pval.mat <<- pval.mat;
+ metastat.de <<- metastat.de;
+ meta.stat <<- meta.stat;
+
+ # save the result
+ res <- cbind(ID=metade.genes, meta.mat);
+
+ fast.write.csv(res, file=paste("meta_sig_features_", metastat.method, ".csv", sep=""), row.names=F);
+}
+
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/meta_methods.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/meta_methods.R
new file mode 100755
index 0000000000000000000000000000000000000000..e62aed163daf5287e1afaff49cb2508994e9175c
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/meta_methods.R
@@ -0,0 +1,873 @@
+#'Check if data are ready for meta-analysis
+#'@description This function determines if all annotated data are ready for meta-analysis
+#'@param mSetObj Input name of the created mSet Object
+#'@param combat Adjust for batch effects, logical variable: TRUE = adjust for batch effects using an empirical Bayes framework (R package sva),
+#'FALSE = no batch effect adjustment.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@import qs
+#'@export
+
+CheckMetaDataConsistency<-function(mSetObj=NA, combat=TRUE){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(length(mdata.all) == 0){
+ AddErrMsg("Please upload your data or try our example datasets!");
+ return(0);
+ }
+
+ include.inx <- mdata.all==1;
+ if(sum(include.inx) < 2){
+ AddErrMsg("At least two datasets are required for meta-analysis!");
+ return(0);
+ }
+
+ sel.nms <- names(mdata.all)[include.inx];
+
+ # first check that all class labels are consistent
+ dataSet <- qs::qread(sel.nms[1]);
+ lvls <- levels(dataSet$cls);
+ id.type <- dataSet$id.type;
+
+ # note, the features are in columns!!!!
+ nms <- colnames(dataSet$data);
+ shared.nms <- nms;
+ for(i in 2:length(sel.nms)){
+ dataSet <- qs::qread(sel.nms[i]);
+ # check if class label is consistent
+ if(!all(levels(dataSet$cls) == lvls)){
+ AddErrMsg(paste(sel.nms[i], "has different group labels", paste(levels(dataSet$cls), collapse=":"), "from", sel.nms[1], paste(lvls, collapse=":")));
+ return(0);
+ }
+
+ # check and record if there is common genes
+ shared.nms <- intersect(shared.nms, colnames(dataSet$data));
+ if(length(shared.nms) < ncol(dataSet$data)/4){
+ AddErrMsg(paste(sel.nms[i], "has less than 25% common features from the previous data sets"));
+ return(0);
+ }
+ }
+ AddMsg("Passed experimental condition check!");
+
+ # now construct a common matrix to faciliate plotting across all studies
+ dataName <- sel.nms[1];
+ dataSet <- qs::qread(dataName);
+ common.matrix <- dataSet$data[, shared.nms];
+ data.lbl <- rep(dataName, nrow(common.matrix));
+ cls.lbl <- dataSet$cls;
+
+ for(i in 2:length(sel.nms)){
+ dataName <- sel.nms[i];
+ dataSet <- qs::qread(dataName);
+ ndat <- dataSet$data[, shared.nms];
+
+ # note, there could be duplicate sample names across studies
+ rownames(ndat) <- paste(rownames(ndat),"_",i, sep="");
+ plot.ndat <- t(scale(t(ndat))); # scale sample wise (default scale column)
+ common.matrix <- rbind(common.matrix, ndat);
+ data.lbl <- c(data.lbl, rep(dataName, nrow(dataSet$data[,])));
+ cls.lbl <- c(cls.lbl, dataSet$cls);
+ }
+
+ cls.lbl <- factor(cls.lbl);
+ levels(cls.lbl) <- lvls;
+ colnames(common.matrix) <- shared.nms;
+ ord.inx <- order(data.lbl, cls.lbl);
+ cls.lbl <- cls.lbl[ord.inx];
+ data.lbl <- data.lbl[ord.inx];
+ common.matrix <- data.matrix(common.matrix[ord.inx,]);
+
+ AddMsg("Constructed the commom matrix!");
+
+ if(nrow(common.matrix) > 1000){ # max sample number allow 1000
+ AddErrMsg(paste("Total combined sample #:", nrow(common.matrix), "(exceed the limit: 1000!)"));
+ return(0);
+ }
+
+ # now from here, we want to transpose the data as in gene expression data
+ # (i.e. samples in columns) to be easier for further analysis
+ common.matrix <- t(common.matrix);
+
+ if(combat){
+ pheno <- data.frame(cbind(cls.lbl, data.lbl));
+ modcombat = model.matrix(~1, data=pheno)
+ batch <- data.lbl;
+ combat_edata = sva::ComBat(dat=common.matrix, batch=batch, mod=modcombat, par.prior=TRUE, prior.plots=FALSE)
+ common.matrix <- combat_edata;
+ }
+
+ # save the meta-dataset
+ res <- data.frame(colnames(common.matrix), cls.lbl, data.lbl, t(common.matrix));
+ colnames(res) <- c('Samples', 'Conditions', 'Datasets', rownames(common.matrix));
+ write.table(t(res), file="MetaboAnalyst_merged_data.csv", col.names=F, quote=FALSE);
+
+ # need to set up the data for plotting (boxplot, heatmap) so
+ # we need to scale row for each dataset in order to elimiate the maganitude difference
+ plot.matrix <- matrix(NA, nrow=nrow(common.matrix), ncol=ncol(common.matrix));
+ rownames(plot.matrix) <- rownames(common.matrix);
+ colnames(plot.matrix) <- colnames(common.matrix);
+ for(i in 1:length(sel.nms)){
+ data.inx <- data.lbl == sel.nms[i];
+ plot.matrix[,data.inx] <- t(scale(t(common.matrix[,data.inx])));
+ }
+
+ # if entrez, get symbols for display
+ shared.nms <- rownames(common.matrix);
+ symbols <- shared.nms;
+ names(symbols) <- shared.nms;
+
+ metastat.meta <<- list(data=common.matrix,
+ plot.data=plot.matrix,
+ gene.symbls = symbols,
+ cls.lbl=factor(cls.lbl),
+ data.lbl=data.lbl);
+
+ PerformEachDEAnal(mSetObj);
+
+ # setup common stats gene number, smpl number, grp info
+ studyinfo <- paste("Sample #:", ncol(metastat.meta$data), "Common ID #:", nrow(metastat.meta$data), "Condition:", paste(levels(metastat.meta$cls.lbl), collapse=" vs. "));
+
+ AddMsg(studyinfo)
+ mSetObj$dataSet$studyinfo <- studyinfo
+
+ if(.on.public.web){
+ if(length(sel.nms) == 1){
+ .set.mSet(mSetObj)
+ return(2);
+ }else{
+ .set.mSet(mSetObj)
+ return(1);
+ }
+ }else{
+ return(.set.mSet(mSetObj));
+ }
+}
+
+#'Performs differential expression analysis on individual data
+#'@description This function performs DE analysis on individual data using the common matrix, which
+#'will be used/compared in later steps of the analysis (according to the p-value). The DE for each feature
+#'may be adjusted using the p-value.
+#'@param mSetObj Input name of the created mSet Object
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@import qs
+#'@export
+
+PerformEachDEAnal <- function(mSetObj=NA){
+
+ metastat.ind <- list();
+ sel.nms <- names(mdata.all)[mdata.all==1];
+
+ for(i in 1:length(sel.nms)){
+ dataName <- sel.nms[i];
+ sel.inx <- metastat.meta$data.lbl == dataName;
+ group <- factor(metastat.meta$cls.lbl[sel.inx]); # note regenerate factor to drop levels
+ data <- metastat.meta$data[, sel.inx];
+
+ dataSet <- qs::qread(dataName);
+ grp.lvl <- levels(dataSet$cls);
+
+ # update data set
+ group <- factor(metastat.meta$cls.lbl[sel.inx], levels=grp.lvl, ordered=T); # note regenerate factor to drop levels
+ dataSet$cls <- group;
+
+ res.limma <- PerformLimma(data, group);
+
+ # save dataSet object for meta-analysis
+ dataSet$fit.obj <- res.limma$fit.obj;
+
+ res.all <- GetLimmaResTable(res.limma$fit.obj);
+ res.mat <- cbind(logFC=res.all$logFC, Pval = res.all$adj.P.Val);
+ rownames(res.mat) <- rownames(res.all);
+ metastat.ind[[dataName]] <- res.mat;
+
+ RegisterData(mSetObj, dataSet);
+
+ # clean up
+ rm(dataSet, res.all);
+ gc();
+ }
+ metastat.ind <<- metastat.ind;
+}
+
+#'Meta-Analysis Method: Combining p-values
+#'@description This function is one of three methods to perform meta-analysis. Here, p-values are combined using either
+#'the Fisher's method or the Stouffer's method.
+#'@param mSetObj Input name of the created mSet Object.
+#'@param method Method of p-value combination. By default it is "stouffer", else it is "fisher".
+#'@param BHth Numeric input to set the significance level. By default it is 0.05.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@import qs
+#'@export
+
+PerformPvalCombination <- function(mSetObj=NA, method="stouffer", BHth=0.05){
+
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$dataSet$pvalmethod <- method
+ mSetObj$dataSet$pvalcutoff <- BHth
+
+ metastat.method <<- "metap";
+ meta.mat <<- meta.stat <<- NULL;
+ sel.nms <- names(mdata.all)[mdata.all==1];
+
+ classes <- list();
+ nbstudies <- length(sel.nms);
+ listgd=vector("list", (nbstudies+3));
+
+ for (i in 1:nbstudies){
+ data.nm <- sel.nms[i];
+ dataSet <- qs::qread(data.nm);
+ classes[[i]] <- dataSet$cls;
+
+ fit2i <- dataSet$fit.obj;
+ pvals <- p.adjust(fit2i$p.value, method="BH");
+ listgd[[i]]=which(pvals<=BHth);
+
+ #recalculate moderated one sided p
+ p1sidedLimma=pt(fit2i$t,df=(fit2i$df.prior+fit2i$df.residual))
+ assign(paste("p1sidedLimma",i,sep=""), p1sidedLimma)
+ }
+
+ names(classes) <- sel.nms;
+ tempvec=paste("p1sidedLimma",1:nbstudies,sep="");
+
+ lsinglep=lapply(tempvec,FUN=function(x) get(x,inherits=TRUE));
+ nrep=unlist(lapply(classes,FUN=function(x)length(x)));
+ listgd[[(nbstudies+1)]]=unique(unlist(listgd[1:nbstudies]));
+
+ restempdirect=combinePvals(lsinglep,nrep,BHth,method);
+
+ listgd[[(nbstudies+2)]]=restempdirect$DEindices
+ listgd[[(nbstudies+3)]]=restempdirect$CombinedP
+ names(listgd)=c(paste("study",1:nbstudies,sep=""),"AllIndStudies","Meta","CombinedP");
+
+ pc.mat <- cbind(CombinedTstat=restempdirect$CombinedStat, CombinedPval=restempdirect$CombinedP);
+ rownames(pc.mat) <- rownames(metastat.meta$data);
+
+ # now keep only genes with at least on sig (in one study or meta analysis)
+ inx <- union(listgd[[(nbstudies+1)]], listgd[[(nbstudies+2)]]);
+ pc.mat <- pc.mat[inx,];
+
+ #sort
+ ord.inx <- order(pc.mat[, "CombinedPval"], decreasing = F);
+ pc.mat<-signif(pc.mat[ord.inx,],5);
+ sig.inx <- which(pc.mat[, "CombinedPval"]<=BHth);
+
+ meta.mat <<- pc.mat[sig.inx, ];
+ SetupMetaStats(BHth);
+
+ if(.on.public.web){
+ .set.mSet(mSetObj)
+ return(length(sig.inx));
+ }else{
+ return(.set.mSet(mSetObj));
+ }
+}
+
+#'Meta-Analysis Method: Vote Counting
+#'@description This function is one of three methods to perform meta-analysis. Here, significant features are selected based on a selected criteria (i.e. an adjusted p-value
+#'<0.05 and the same direction of FC) for each dataset. The votes are then calculated for each feature by counting the total of number of times
+#'a feature is significant across all included datasets. However, this method is statistically inefficient and should be considered the
+#'last resort in situations where other methods to perform meta-analysis cannot be applied.
+#'@param mSetObj Input name of the created mSet Object.
+#'@param BHth Numeric input to set the significance level. By default it is 0.05.
+#'@param minVote Numeric input to set the minimum vote-count.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+PerformVoteCounting <- function(mSetObj=NA, BHth = 0.05, minVote){
+
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$dataSet$vote <- minVote
+ mSetObj$dataSet$pvalcutoff <- BHth
+
+ metastat.method <<- "votecount";
+ DE.vec <<- NULL; # store entrez id from meta-analysis for GO
+ meta.mat <<- meta.stat <<- NULL;
+ sel.nms <- names(mdata.all)[mdata.all==1];
+
+ # first create a matrix to store the result
+ # row for each feature and col for each dataset uploaded
+ vc.mat <- matrix(0, nrow=nrow(metastat.meta$data), ncol=length(sel.nms)+1);
+ shared.ids <- rownames(metastat.meta$data);
+ for(i in 1:length(metastat.ind)){
+ res.mat <- metastat.ind[[i]];
+ res.mat <- res.mat[shared.ids, ];
+
+ #note in meta-analysis should consider directions
+ # use logFC for this purpose
+ # consider upregulated
+ hit.up.inx <- res.mat[,1]> 0 & res.mat[,2] <= BHth;
+ up.vote <- as.numeric(hit.up.inx);
+
+ # consider downregulated
+ hit.dn.inx <- res.mat[,1] < 0 & res.mat[,2] <= BHth;
+ dn.vote <- -as.numeric(hit.dn.inx);
+
+ vc.mat[,i] <- up.vote + dn.vote;
+ }
+
+ # total score (votes for each direction)
+ vc.mat[,length(sel.nms)+1] <- apply(vc.mat, 1, sum);
+ colnames(vc.mat) <- c(paste("Vote", substring(sel.nms,0, nchar(sel.nms)-4)), "VoteCounts");
+ rownames(vc.mat) <- rownames(metastat.meta$data);
+
+ # compute at least one vote (no direction)
+ vote.any <- apply(abs(vc.mat), 1, sum)
+ vote.any.inx <- vote.any > 0;
+
+ # return results with at least one vote
+ vc.mat <- vc.mat[vote.any.inx, ];
+
+ #sort
+ ord.inx <- order(abs(vc.mat[, "VoteCounts"]), decreasing = T);
+ vc.mat <- vc.mat[ord.inx, "VoteCounts", drop=F];
+
+ sig.inx <- abs(vc.mat[,"VoteCounts"]) >= minVote;
+ meta.mat <<- vc.mat[sig.inx, ,drop=F];
+ SetupMetaStats(BHth);
+
+ if(.on.public.web){
+ .set.mSet(mSetObj)
+ return(sum(sig.inx));
+ }else{
+ return(.set.mSet(mSetObj));
+ }
+}
+
+#'Meta-Analysis Method: Direct merging of datasets
+#'@description This function is one of three methods to perform meta-analysis. Direct merging of individual data into
+#'a mega-dataset results in an analysis of that mega-dataset as if the individual data were derived from the same experiment. This
+#'method thereby ignores any inherent bias and heterogeneity between the different data. Because of this, there exists several confounders
+#'such as different experimental protocols, technical platforms, and raw data processing procedures that can mask true underlying differences.
+#'It is therefore highly suggested that this approach be used only when individual data are very similar (i.e. from the same lab, same platform,
+#'without batch effects)."
+#'@param mSetObj Input name of the created mSet Object.
+#'@param BHth Numeric input to set the significance level. By default it is 0.05.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+PerformMetaMerge<-function(mSetObj=NA, BHth=0.05){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ mSetObj$dataSet$pvalcutoff <- BHth
+
+ metastat.method <<- "merge";
+ meta.mat <<- meta.stat <<- NULL;
+
+ # prepare for meta-stats
+ # calculate sig genes for individual analysis
+ shared.names <- rownames(metastat.meta$data);
+
+ res.limma <- PerformLimma(metastat.meta$data, as.factor(metastat.meta$cls.lbl));
+ res.all <- GetLimmaResTable(res.limma$fit.obj);
+
+ ord.inx <- order(res.all$adj.P.Val, decreasing=F);
+ dm.mat <- as.matrix(res.all[ord.inx,c("logFC", "adj.P.Val")]);
+ colnames(dm.mat) <- c("CombinedLogFC", "Pval");
+
+ sig.inx <- which(dm.mat[,"Pval"] <= BHth);
+
+ meta.mat <<- dm.mat[sig.inx,];
+ SetupMetaStats(BHth);
+
+ if(.on.public.web){
+ .set.mSet(mSetObj)
+ return(length(sig.inx));
+ }else{
+ return(.set.mSet(mSetObj));
+ }
+}
+
+#'Meta-Analysis: Plot Venn Diagram
+#'@description This function plots a venn diagram of the individual studies.
+#'@param mSetObj Input name of the created mSet Object.
+#'@param imgNM Input the name of the created Venn Diagram
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+PlotMetaVenn<-function(mSetObj=NA, imgNM=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ imgName <- paste(imgNM, ".png", sep="");
+ mSetObj$imgSet$venn <- imgName;
+
+ Cairo::Cairo(file = imgName, width=420, height=300, type="png", bg="transparent");
+ plotVennDiagram(meta.stat$venn, circle.col=c("blue", "forestgreen"), mar=c(0,0,2,0));
+ dev.off();
+
+ sums <- unlist(lapply(metastat.de, length))
+ names <- unlist(lapply(metastat.de, paste, collapse = ", "))
+ metasum <- length(meta.stat$idd)
+ metaname <- paste(meta.stat$idd, collapse = ", ")
+ allsums <- c(sums, metasum)
+ allnames <- c(names, metaname)
+ sigmat <- cbind(allsums, allnames)
+ colnames(sigmat) <- c("Sum of DE Features", "Names of DE Features")
+ rownames(sigmat) <- c(names(metastat.de), "Meta-Analysis")
+ mSetObj$analSet$sigfeat.matrix <- sigmat
+
+ return(.set.mSet(mSetObj));
+}
+
+# Utility function: Plot Venn diagram
+# Gordon Smyth, James Wettenhall.
+# Capabilities for multiple counts and colors by Francois Pepin.
+# 4 July 2003. Last modified 12 March 2010.
+plotVennDiagram <- function(object, include="both", names, mar=rep(0,4), cex=1.2, lwd=1,
+ circle.col, counts.col, show.include,...){
+
+ nsets <- ncol(object)-1
+ if(missing(names)) names <- colnames(object)[1:nsets]
+ counts <- object[,"Counts"]
+ if(length(include)==2) counts.2 <- object.2[, "Counts"]
+ if(missing(circle.col)) circle.col <- par('col')
+ if(length(circle.col)<nsets) circle.col <- rep(circle.col,length.out=nsets)
+ if(missing(counts.col)) counts.col <- par('col')
+ if(length(counts.col)<length(include)) counts.col <- rep(counts.col,length.out=length(include))
+ if(missing(show.include)) show.include <- as.logical(length(include)-1)
+ theta <- 2*pi*(0:360)/360
+ xcentres <- c(-1.2, 1.2);
+ ycentres <- c(0,0);
+ r <- 2.8;
+ xtext <- c(-1.5,1.5)
+ ytext <- c(3.5,3.5)
+
+ par(oma=c(0,0,0,0),mar=c(0,0,0,0));
+
+ plot(x=0,y=0,type="n",xlim=c(-4,4),ylim=c(-4,4),xlab="",ylab="",axes=FALSE,...);
+
+ circle.col <- col2rgb(circle.col) / 255
+ circle.col <- rgb(circle.col[1,], circle.col[2,], circle.col[3,], 0.3)
+ for(i in 1:nsets) {
+ lines(xcentres[i]+r*cos(theta),ycentres[i]+r*sin(theta),lwd=lwd,col=circle.col[i])
+ polygon(xcentres[i] + r*cos(theta), ycentres[i] + r*sin(theta), col = circle.col[i], border = NULL)
+ text(xtext[i],ytext[i],names[i],cex=cex)
+ }
+
+ printing <- function(counts, cex, adj,col,leg){
+ text(2.5,0.1,counts[2],cex=cex,col=col,adj=adj)
+ text(-2.5,0.1,counts[3],cex=cex,col=col,adj=adj)
+ text(0,0.1,counts[4],cex=cex,col=col,adj=adj)
+ }
+
+ printing(counts,cex,c(0.5,0.5),counts.col[1],include[1])
+ invisible()
+}
+
+##############################################
+##############################################
+########## Utilities for web-server ##########
+##############################################
+##############################################
+
+GetMetaGeneIDType<-function(){
+ return(metastat.meta$id.type);
+}
+
+GetMetaResultGeneIDs<-function(){
+ return(rownames(meta.mat));
+}
+
+# note, due to limitation of get/post
+# maximum gene symb for list is top 5000
+GetMetaResultGeneSymbols<-function(){
+ ids <- rownames(meta.mat);
+ if(length(ids) > 5000){
+ ids <- ids[1:5000];
+ }
+ return(ids);
+}
+
+GetMetaResultGeneIDLinks <- function(){
+ ids <- rownames(meta.mat);
+ symbs <- metastat.meta$gene.symbls[ids];
+ # set up links to genbank
+ annots <- paste("<a href='http://www.ncbi.nlm.nih.gov/gene?term=", ids,
+ "' target='_blank'>", symbs, "</a>", sep="");
+ return(annots);
+}
+
+GetMetaResultColNames <- function(){
+ sel.nms <- names(mdata.all)[mdata.all==1];
+ c(substring(sel.nms, 0, nchar(sel.nms)-4), colnames(meta.mat));
+}
+
+#'Single.type return logFC or p value for individual data analysis
+#'@param mSetObj Input name of the created mSet Object
+#'@param single.type Default is "fc"
+#'@export
+GetMetaResultMatrix <- function(mSetObj = NA, single.type="fc"){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(single.type == "fc"){
+ meta.mat <- cbind(fc.mat, meta.mat);
+ }else{
+ meta.mat <- cbind(pval.mat, meta.mat);
+ }
+ meta.mat <- signif(as.matrix(meta.mat), 5);
+ mSetObj$analSet$meta.mat <- meta.mat;
+
+ if(.on.public.web == TRUE){
+ .set.mSet(mSetObj)
+ meta.mat;
+ }else{
+ return(.set.mSet(mSetObj));
+ }
+}
+
+GetMetaStat <- function(){
+ return (meta.stat$stat);
+}
+
+GetMetaStatNames <- function(){
+ return (names(meta.stat$stat));
+}
+
+combinePvals <- function(pvalonesided,nrep,BHth=0.05, method) {
+ listres=vector("list",3);
+ nbstudies=length(pvalonesided);
+ nbreptot=sum(nrep);
+ if (nbreptot <2) {
+ stop("Error: the argument \"nrep\" must be a vector with at least two values higher than 1")
+ }
+
+ weight=sqrt(nrep/nbreptot);
+ fstatmeta=function(g){
+ vecptime=unlist(lapply(pvalonesided, FUN = function(x) x[g]));
+ vec = qnorm(1 - vecptime);
+ stattestg = sum(weight[1:length(pvalonesided)] * vec[1:length(pvalonesided)], na.rm = TRUE);
+ stattestg;
+ }
+
+ fishersum <- function(pvec){
+ return(sum(-2*log10(pvec)))
+ }
+
+ if(method=="stouffer"){
+ statpvalc=-unlist(lapply(rep(1:length(as.vector(pvalonesided[[1]])), 1), function(x) fstatmeta(x)));
+ rpvalpvalc=2*(1-pnorm(abs(statpvalc)));
+ }else{ # fisher
+ data <- data.frame(pvalonesided);
+ #data[data == 0] <- 1*10^-10;
+
+ #note, p value are calculated for one side
+ # pt (lower.tail=T by default) which tests if group A < group B
+ # for one side
+ fsum1 <- apply(data, 1, fishersum);
+ rpvalpvalc1 = 1-pchisq(fsum1, df=(ncol(data)*2));
+
+ # for the other side
+ data <- 1-data;
+ fsum2 <- apply(data, 1, fishersum);
+ rpvalpvalc2 = 1-pchisq(fsum2, df=(ncol(data)*2));
+
+ # report the min of two direction calculation
+ rpvalpvalc <- pmin(rpvalpvalc1, rpvalpvalc2);
+
+ # adding direction information
+ statpvalc <- pmax(fsum1, fsum2);
+ # if A<B sig, then it should be negative
+ statpvalc[statpvalc == fsum1]<- -statpvalc[statpvalc == fsum1];
+ }
+
+ rpvalpvalc <- p.adjust(rpvalpvalc,method="BH");
+ res=which(rpvalpvalc<=BHth);
+ listres[[1]]=res
+ listres[[2]]=statpvalc;
+ listres[[3]]=rpvalpvalc
+ names(listres)=c("DEindices", "CombinedStat", "CombinedP")
+ listres
+}
+
+PlotDataProfile<-function(dataName, boxplotName, pcaName){
+ dataSet <- qs::qread(dataName);
+ if(.on.public.web){
+ load_lattice()
+ }
+ qc.boxplot(dataSet$data, boxplotName);
+ qc.pcaplot(dataSet$data, pcaName);
+}
+
+qc.boxplot <- function(dat, imgNm, format="png", dpi=72, width=NA){
+ imgNm <- paste(imgNm, "dpi", dpi, ".", format, sep="");
+
+ subgene=10000;
+ if (nrow(dat)>subgene) {
+ set.seed(28051968);
+ sg = sample(nrow(dat), subgene)
+ Mss = dat[sg,,drop=FALSE]
+ } else {
+ Mss = dat
+ }
+
+ subsmpl=100;
+ if (ncol(Mss)>subsmpl) {
+ set.seed(28051968);
+ ss = sample(ncol(Mss), subsmpl)
+ Mss = Mss[,ss,drop=FALSE]
+ } else {
+ Mss = Mss
+ }
+
+ sample_id = rep(seq_len(ncol(Mss)), each = nrow(Mss));
+ values = as.numeric(Mss)
+ formula = sample_id ~ values
+
+ box = bwplot(formula, groups = sample_id, layout = c(1,1), as.table = TRUE,
+ strip = function(..., bg) strip.default(..., bg ="#cce6ff"),
+ horizontal = TRUE,
+ pch = "|", col = "black", do.out = FALSE, box.ratio = 2,
+ xlab = "", ylab = "Samples",
+ fill = "#1c61b6AA",
+ panel = panel.superpose,
+ scales = list(x=list(relation="free"), y=list(axs="i")),
+ ylim = c(ncol(Mss)+0.7,0.3),
+ prepanel = function(x, y) {
+ list(xlim = quantile(x, probs = c(0.01, 0.99), na.rm=TRUE))
+ },
+ panel.groups = function(x, y, ...) {
+ panel.bwplot(x, y, ...)
+ })
+
+ Cairo::Cairo(file=imgNm, width=460, height=420, type="png", bg="white");
+ print(box);
+ dev.off();
+}
+
+qc.pcaplot <- function(x, imgNm, format="png", dpi=72, width=NA){
+ imgNm <- paste(imgNm, "dpi", dpi, ".", format, sep="");
+ pca <- prcomp(t(na.omit(x)));
+ names <- colnames(x);
+ pca.res <- as.data.frame(pca$x);
+ # increase xlim ylim for text label
+ xlim <- GetExtendRange(pca.res$PC1);
+ ylim <- GetExtendRange(pca.res$PC2);
+ pcafig = lattice::xyplot(PC2~PC1, data=pca.res, pch=19, cex=1, xlim = xlim, ylim=ylim,
+ panel=function(x, y, ...) {
+ panel.xyplot(x, y, ...);
+ ltext(x=x, y=y, labels=names, pos=1, offset=1, cex=0.8, col="magenta")
+ })
+
+ Cairo::Cairo(file=imgNm, width=480, height=480, type="png", bg="white");
+ print(pcafig);
+ dev.off();
+}
+
+#'Prepare data for Venn diagram
+#'@param mSetObj Input name of the created mSet Object
+#'@export
+PrepareVennData <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # create a list store all possible combination (for a max of 4)
+ # note, the whole region is divided into small areas (16 for 4; 7 for 3, 3 for 2)
+ # for instance:
+ # a: a unique (no b, no c)
+ # ab: a and b, no c
+
+ newDat <- list();
+ hit.inx <- mdata.all==1;
+ sel.nms <- names(mdata.all)[hit.inx];
+ sel.dats <- list();
+
+ for(nm in sel.nms){
+ res.mat <- metastat.ind[[nm]];
+ sig.inx <- res.mat[,2]<=GlobalCutOff$BHth;
+ sel.dats[[nm]] <- rownames(res.mat[sig.inx,]);
+ }
+
+ if(anal.type == "metadata" & meta.selected){
+ sel.dats[["meta_dat"]] <- as.character(meta.stat$de);
+ }
+
+ if(length(sel.dats) == 0){
+ AddErrMsg("No signficant features for any dataset!");
+ return(0);
+ }
+ if(length(sel.dats) == 2){
+ Prepare2Venn(sel.dats);
+ }else if(length(sel.dats) == 3){
+ Prepare3Venn(sel.dats);
+ }else if(length(sel.dats) == 4){
+ Prepare4Venn(sel.dats);
+ }else{
+ AddErrMsg("Too big of a number of features for the venn diagram");
+ return(0);
+ }
+ venn.list <<- sel.dats;
+
+ save(sel.dats, file = "sel.dats.rda");
+ save(mSetObj, file = "mSetObj__venn.rda");
+ save.image(file = "image__venn.RData")
+ PlotMetaVenn(mSetObj, "venn_diagram");
+ return(.set.mSet(mSetObj));
+
+}
+
+#3
+Prepare2Venn <- function(dat){
+ nms <- names(dat);
+ a <- nms[1];
+ b <- nms[2];
+ ab <- paste(a, b, sep="");
+
+ a.l <- dat[[a]];
+ b.l <- dat[[b]];
+
+ vennData <- list();
+ vennData[[a]] <- setdiff(a.l, b.l);
+ vennData[[b]] <- setdiff(b.l, a.l);
+ vennData[[ab]] <- intersect(b.l, a.l);
+ vennData <<- vennData;
+}
+
+#7
+Prepare3Venn <- function(dat){
+ nms <- names(dat);
+ a <- nms[1];
+ b <- nms[2];
+ c <- nms[3];
+ ab <- paste(a, b, sep="");
+ ac <- paste(a, c, sep="");
+ bc <- paste(b, c, sep="");
+ abc <- paste(a, b, c, sep="");
+
+ a.l <- dat[[a]];
+ b.l <- dat[[b]];
+ c.l <- dat[[c]];
+
+ vennData <- list();
+ vennData[[a]] <- setdiff(a.l, union(b.l, c.l));
+ vennData[[b]] <- setdiff(b.l, union(a.l, c.l));
+ vennData[[c]] <- setdiff(c.l, union(a.l, b.l));
+ vennData[[ab]] <- setdiff(intersect(a.l, b.l), c.l);
+ vennData[[ac]] <- setdiff(intersect(a.l, c.l), b.l);
+ vennData[[bc]] <- setdiff(intersect(b.l, c.l), a.l);
+ vennData[[abc]] <- intersect(intersect(a.l, b.l), c.l);
+ vennData <<- vennData;
+}
+
+# 15
+Prepare4Venn <- function(dat){
+
+ nms <- names(dat);
+ a <- nms[1];
+ b <- nms[2];
+ c <- nms[3];
+ d <- nms[4];
+ ab <- paste(a, b, sep="");
+ ac <- paste(a, c, sep="");
+ ad <- paste(a, d, sep="");
+ bc <- paste(b, c, sep="");
+ bd <- paste(b, d, sep="");
+ cd <- paste(c, d, sep="");
+ abc <- paste(a, b, c, sep="");
+ abd <- paste(a, b, d, sep="");
+ acd <- paste(a, c, d, sep="");
+ bcd <- paste(b, c, d, sep="");
+ abcd <- paste(a, b, c, d, sep="");
+
+ a.l <- dat[[a]];
+ b.l <- dat[[b]];
+ c.l <- dat[[c]];
+ d.l <- dat[[d]];
+
+ vennData <- list();
+ vennData[[a]] <- setdiff(a.l, unique(c(b.l, c.l, d.l)));
+ vennData[[b]] <- setdiff(b.l, unique(c(a.l, c.l, d.l)));
+ vennData[[c]] <- setdiff(c.l, unique(c(a.l, b.l, d.l)));
+ vennData[[d]] <- setdiff(d.l, unique(c(a.l, b.l, c.l)));
+ vennData[[ab]] <- setdiff(intersect(a.l, b.l), union(c.l, d.l));
+ vennData[[ac]] <- setdiff(intersect(a.l, c.l), union(b.l, d.l));
+ vennData[[ad]] <- setdiff(intersect(a.l, d.l), union(b.l, c.l));
+ vennData[[bc]] <- setdiff(intersect(b.l, c.l), union(a.l, d.l));
+ vennData[[bd]] <- setdiff(intersect(b.l, d.l), union(a.l, c.l));
+ vennData[[cd]] <- setdiff(intersect(c.l, d.l), union(a.l, b.l));
+ vennData[[abc]] <- setdiff(intersect(intersect(a.l, b.l), c.l), d.l);
+ vennData[[abd]] <- setdiff(intersect(intersect(a.l, b.l), d.l), c.l);
+ vennData[[acd]] <- setdiff(intersect(intersect(a.l, c.l), d.l), b.l);
+ vennData[[bcd]] <- setdiff(intersect(intersect(b.l, c.l), d.l), a.l);
+ vennData[[abcd]] <- intersect(intersect(a.l, b.l), intersect(c.l, d.l));
+ vennData <<- vennData;
+
+}
+
+#'Retrieve selected data numbers
+#'@param mSetObj Input name of the created mSet Object
+#'@export
+GetSelectedDataNumber <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(.on.public.web){
+ return(length(venn.list));
+ }else{
+ return(.set.mSet(mSetObj));
+ }
+}
+
+#'Retrieve data names
+#'@param mSetObj Input name of the created mSet Object
+#'@export
+GetSelectedDataNames <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(.on.public.web){
+ return(paste(names(venn.list), collapse=";"));
+ }else{
+ return(.set.mSet(mSetObj));
+ }
+}
+
+# Areas is allname concated
+#'Get Venn names
+#'@param mSetObj Input name of the created mSet Object
+#'@param areas Input areas to retrieve names
+#'@export
+GetVennGeneNames <- function(mSetObj=NA, areas){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ nms <- strsplit(areas, "\\|\\|")[[1]];
+ gene.vec <- NULL;
+ for(nm in nms){
+ gene.vec <- c(gene.vec, vennData[[nm]]);
+ }
+ gene.vec <- unique(gene.vec);
+ names(gene.vec) <- gene.vec;
+
+ if(.on.public.web){
+ venn.genes <<- gene.vec;
+ return(paste(unique(gene.vec), collapse="||"));
+ }else{
+ mSetObj$dataSet$venn_overlap <- gene.vec
+ return(.set.mSet(mSetObj));
+ }
+}
+
+#'Export the significant hits from meta-analysis
+#'@param mSetObj Input name of the created mSet Object
+#'@export
+#areas is allname concated
+GetMetaSigHitsTable <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$analSet$sigfeat.matrix);
+}
+
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/meta_pathway.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/meta_pathway.R
new file mode 100644
index 0000000000000000000000000000000000000000..59d053b276496aedf69bfa26a8af4d89ca6d8185
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/meta_pathway.R
@@ -0,0 +1,1529 @@
+#'Convert mSetObj to proper format for MS Peaks to Pathways module
+#'@description Following t-test analysis or effect size calculation,
+#'this functions converts the results from the mSetObj
+#'to the proper format for mummichog analysis.
+#'@param mSetObj Input the name of the created mSetObj.
+#'@param rt Logical, whether or not to include retention time information.
+#'@param rds.file Logical, if true, the "annotated_peaklist.rds"
+#'must be in the current working directory to get corresponding retention time
+#'information for the features. If not, the retention time information
+#'will be taken from the feature names. Feature names must be formatted
+#'so that the mz and retention time for a single peak is separated by two
+#'underscores. For instance, m/z of 410.2148 and retention time of 42.46914 seconds
+#'must be formatted as 410.2148__42.46914.
+#'@param rt.type Character, input whether retention time is in seconds (default as RT using
+#'MetaboAnalystR is seconds) or minutes (as from MZmine).
+#'@param test Character, input what statistical values to include in the mummichog input.
+#'For p-values and t-scores only from t-test, use "tt".
+#'For log2FC from the fold-change analsis, use "fc".
+#'For effect-sizes, use "es".
+#'For, p-values, fold-changes and effect sizes, use "all".
+#'@author Jasmine Chong, Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+Convert2MummichogMetaPath <- function(mSetObj=NA, rt=FALSE, rds.file=FALSE, rt.type="seconds",
+ test="tt", mode=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # JX: we will only support tt on web. It is not clear if
+ # other options will be really useful or simply bewildering to users
+
+ tt.pval <- mSetObj$analSet$tt$p.value
+
+ if(is.null(tt.pval)){
+ AddErrMsg("T-test was not performed!")
+ return(0)
+ }
+
+ fdr <- p.adjust(tt.pval, "fdr")
+ mz.pval <- names(tt.pval)
+ pvals <- cbind(mz.pval, as.numeric(fdr))
+ colnames(pvals) <- c("m.z", "p.value")
+
+ tt.tsc <- mSetObj$analSet$tt$t.score
+ mz.tsc <- names(tt.tsc)
+ tscores <- cbind(mz.tsc, as.numeric(tt.tsc))
+ colnames(tscores) <- c("m.z", "t.score")
+
+ if(rt & rds.file){
+
+ if(!file.exists("annotated_peaklist.rds")){
+ AddErrMsg("annotated_peaklist.rds not found in current working directory!")
+ return(0)
+ }
+
+ camera_output <- readRDS("annotated_peaklist.rds")
+ mz.cam <- round(camera_output$mz, 5)
+ rt.cam <- round(camera_output$rt, 5)
+ camera <- cbind(mz.cam, rt.cam)
+ colnames(camera) <- c("m.z", "r.t")
+
+ mummi_new <- Reduce(function(x,y) merge(x,y,by="m.z", all = TRUE), list(pvals, tscores, camera))
+ complete.inx <- complete.cases(mummi_new[,c("p.value", "t.score", "r.t")]) # filter out m/zs without pval and tscore
+ mummi_new <- mummi_new[complete.inx,]
+
+ }else{
+
+ mummi_new <- merge(pvals, tscores)
+
+ if(rt){ # taking retention time information from feature name itself
+
+ feat_info <- mummi_new[,1]
+ feat_info_split <- matrix(unlist(strsplit(feat_info, "__", fixed=TRUE)), ncol=2, byrow=T)
+ colnames(feat_info_split) <- c("m.z", "r.t")
+
+ if(rt.type == "minutes"){
+ rtime <- as.numeric(feat_info_split[,2])
+ rtime <- rtime * 60
+ feat_info_split[,2] <- rtime
+ }
+
+ mummi_new <- cbind(feat_info_split, mummi_new[,-1])
+ }
+ }
+
+ if(!is.na(mode)){
+ if(mode=="positive"){
+ mode <- rep("positive", nrow(mummi_new))
+ }else{
+ mode <- rep("negative", nrow(mummi_new))
+ }
+ mummi_new <- cbind(mummi_new, mode)
+ }
+
+ mummi_new[,1] <- as.numeric(make.unique(as.character(mummi_new[,1]), sep=""))
+ mSetObj$dataSet$mummi_new <- mummi_new;
+
+ if(!.on.public.web){
+ filename <- paste0("mummichog_input_", Sys.Date(), ".txt")
+ write.table(mummi_new, filename, row.names = FALSE)
+ }
+
+ return(.set.mSet(mSetObj))
+}
+
+#'Function to save each mSetObj as a RDS file
+#'to be used later in PerformMetaPSEA.
+#'Should be called after SetPeakEnrichMethod/SetMummichogPval
+#'@import qs
+#'@export
+savePeakListMetaData <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ fileName <- gsub("_", "", mSetObj$dataSet$fileName)
+ file_name <- paste0(fileName, ".qs")
+
+ if(exists("metaFiles")){
+ metaFiles <<- c(metaFiles, file_name)
+ }else{
+ metaFiles <<- file_name
+ }
+
+ if(exists("meta.anal.type")){
+ meta.anal.type <<- c(meta.anal.type, anal.type)
+ }else{
+ meta.anal.type <<- anal.type
+ }
+
+ qs::qsave(mSetObj, file_name)
+
+ return(.set.mSet(mSetObj));
+}
+
+#'Function to perform peak set enrichment meta-analysis
+#'at either the empirical compound, compound level
+#'or pathway level.
+#'@description This is the main function that performs either the mummichog
+#'algorithm, GSEA, or both for peak set enrichment meta-analysis.
+#'@usage performMetaPSEA(mSetObj=NA, lib, libVersion, permNum = 100)
+#'@param mSetObj Input the name of the created mSetObj object.
+#'@param lib Input the name of the organism library, default is hsa_mfn.
+#'@param libVersion Input the version of the KEGG pathway libraries ("current" or "old").
+#'@param permNum Numeric, input the number of permutations to perform. Default is 100.
+#'@param metaLevel Character, input whether the meta-analysis is at the empirical compound ("ec"),
+#'compound ("cpd"), or pathway level ("pathway").
+#'@param combine.level Character, input whether to combine p-values or pool the peaks.
+#'@param pval.method Character, input the method to perform p-value combination.
+#'@param es.method Character, input the method to perform effect-size meta-analysis.
+#'@param rank.metric Character, input how to calculate pre-ranking metric. "mean"
+#'to use the average, "min" to use the lowest score, "max" to use the highest score.
+#'@author Jasmine Chong, Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@import qs
+#'@export
+
+performMetaPSEA <- function(mSetObj=NA, lib, libVersion, permNum = 100, metaLevel = "pathway",
+ combine.level="pvalue", pval.method = "fisher", es.method = "fixed",
+ rank.metric="mean", mutual.feats = TRUE, pooled_cutoff = 0.05){
+
+ metaFiles <- unique(metaFiles);
+ version <- mum.version;
+
+ if(.on.public.web){
+ ## TO solve the strong interferation
+ if(file.exists("mum_res.qs")) file.remove("mum_res.qs")
+ if(file.exists("pathwaysFiltered.qs")) file.remove("pathwaysFiltered.qs")
+ if(file.exists("mummichog_pathway_enrichment.csv")) file.remove("mummichog_pathway_enrichment.csv")
+ if(file.exists("mummichog_matched_compound_all.csv")) file.remove("mummichog_matched_compound_all.csv")
+ if(file.exists("mummichog_integ_pathway_enrichment.csv")) file.remove("mummichog_integ_pathway_enrichment.csv")
+ if(file.exists("mummichog_fgsea_pathway_enrichment.csv")) file.remove("mummichog_fgsea_pathway_enrichment.csv")
+ if(file.exists("ms_peaks_meta_anal_path_res.json")) file.remove("ms_peaks_meta_anal_path_res.json")
+ if(file.exists("initial_ecs.qs")) file.remove("initial_ecs.qs")
+ }
+
+ CMDSet <- mSet[["cmdSet"]];
+
+ if(length(unique(meta.anal.type)) > 1){
+ AddErrMsg("Selected algorithms are not consistent!")
+ return(0)
+ }
+
+ pathResults <- list();
+ pathResultsWhole <- list();
+
+ if(metaLevel == "pathway"){
+
+ # now save compound matching results
+ # and which compounds are significant - note if GSEA it's all
+ cpdMatchResults <- list()
+
+ for(i in 1:length(metaFiles)){
+ mSetObj <- qs::qread(metaFiles[i])
+ mSetObj <- .setup.psea.library(mSetObj, lib, libVersion)
+ cpdMatchResults[[metaFiles[i]]] <- qs::qread("mum_res.qs")
+
+ # don't need to write path result CSV files for meta-analysis in indiv' runs
+ # need to write each individual compound matching file with their own name
+ if(mSetObj$dataSet$mumRT & version=="v2"){
+ mSetObj <- .init.RT.Permutations(mSetObj, permNum)
+ }else{
+ mSetObj <- .init.Permutations(mSetObj, permNum)
+ }
+
+ if(anal.type == "mummichog"){
+ pathResults[[metaFiles[i]]] <- mSetObj$mummi.resmat
+ pathResultsWhole[[metaFiles[i]]] <- read.csv("mummichog_pathway_enrichment.csv")
+ }else if(anal.type == "gsea_peaks"){
+ pathResults[[metaFiles[i]]] <- mSetObj$mummi.gsea.resmat
+ }else{ # integ
+ pathResults[[metaFiles[i]]] <- mSetObj$integ.resmat
+ pathResultsWhole[[metaFiles[i]]] <- read.csv("mummichog_pathway_enrichment.csv")
+ }
+
+ if(i != length(metaFiles)){
+ rm(mSetObj)
+ }
+ }
+
+ sink("ms_peaks_meta_anal_cpd_matching.json");
+ cat(RJSONIO::toJSON(cpdMatchResults));
+ sink();
+
+ } else {
+
+ # finally for pooled
+ # this method will not handle RT (empirical cpd level)
+ metaMsetObj <- vector("list")
+
+ for(metafile in seq_along(metaFiles)){
+ mSetObj <- qs::qread(metaFiles[metafile])
+ metafile <- metaFiles[metafile]
+ metaMsetObj[[metafile]]$dat <- mSetObj$dataSet$mummi.proc
+ metaMsetObj[[metafile]]$pos_inx <- mSetObj$dataSet$pos_inx
+ metaMsetObj[[metafile]]$ins_tol <- mSetObj$dataSet$instrument
+ }
+
+ # first check that all instrument tol are equal
+ ins_tol <- unique(unlist(lapply(metaMsetObj, "[[", "ins_tol")))
+
+ # if different instrument tols
+ # do individual putative compound annotation
+ if(length(ins_tol) > 1){
+
+ mSetObj$mum_nm <- "mummichog_query.json"
+ mSetObj$mum_nm_csv <- "mummichog_pathway_enrichment.csv"
+
+ if(version == "v2"){
+ mSetObj$dataSet$mumRT <- TRUE
+ mSetObj <- .setup.psea.library(mSetObj, lib, libVersion, TRUE, "ec",
+ combine.level, pval.method, es.method, rank.metric, FALSE)
+ mSetObj <- .init.RT.Permutations(mSetObj, permNum)
+ }else{
+ mSetObj <- .setup.psea.library(mSetObj, lib, libVersion, TRUE, "cpd",
+ combine.level, pval.method, es.method, rank.metric, FALSE)
+ mSetObj <- .init.Permutations(mSetObj, permNum)
+ }
+
+ return(.set.mSet(mSetObj));
+ }
+
+ metadat <- lapply(metaMsetObj, "[[", "dat")
+ metadat <- lapply(metadat, data.frame)
+ metadat <- data.table::rbindlist(metadat, idcol = TRUE)
+ metadat$m.z <- make.unique(as.character(metadat$m.z), sep = "")
+
+ ref_mzlist <- as.numeric(unlist(metadat[,"m.z"]))
+ pos_inx <- unlist(metadat[,"pos_inx"])
+ pos_inx <- ifelse(pos_inx == 1, TRUE, FALSE)
+ expr_dic <- unlist(metadat[,"t.score"])
+
+ if(anal.type == "mummichog"){
+ pval_cutoff <- pooled_cutoff
+ my.inx <- metadat[,"p.value"] < pval_cutoff;
+ input_mzlist <- ref_mzlist[my.inx];
+
+ if(length(input_mzlist) < 10){
+ AddErrMsg("Not enough significant compounds for pathway analysis! Consider
+ changing the p-value cutoff!")
+ return(0)
+ }
+ mSetObj$dataSet$input_mzlist <- input_mzlist
+ mSetObj$dataSet$N <- length(input_mzlist)
+ }
+
+ mSetObj$dataSet$mummi.proc <- metadat
+ mSetObj$dataSet$ref_mzlist <- ref_mzlist
+ mSetObj$dataSet$pos_inx <- pos_inx
+ mSetObj$dataSet$expr_dic <- expr_dic
+ names(mSetObj$dataSet$expr_dic) <- ref_mzlist
+
+ if(version == "v2"){
+ mSetObj$dataSet$mumRT <- TRUE
+ }
+
+ mSetObj <- .setup.psea.library(mSetObj, lib, libVersion, FALSE, "pooled")
+
+ if(version == "v2"){
+ mSetObj <- .init.RT.Permutations(mSetObj, permNum)
+ }else{
+ mSetObj <- .init.Permutations(mSetObj, permNum)
+ }
+
+ if(class(mSetObj) != "list"){
+ if(mSetObj == 0){
+ AddErrMsg("MS Peaks to Paths analysis failed! Likely not enough m/z to compound hits for pathway analysis!")
+ return(0)
+ }
+ }
+
+ mSetObj$metaLevel <- metaLevel
+ mSetObj$pooled_cutoff <- pooled_cutoff
+ mSetObj$cmdSet <- CMDSet;
+
+ return(.set.mSet(mSetObj));
+ }
+
+ if(metaLevel == "pathway"){ # need to integrate pathway results
+
+ sink("ms_peaks_meta_anal_path_res.json");
+
+ if(anal.type!="gsea_peaks"){
+ cat(RJSONIO::toJSON(pathResultsWhole));
+ sink();
+ }
+
+ mSetObj$dataSet$pathResults <- pathResults; #TODO: to replace the I/O with this option
+
+ num_files <- length(metaFiles)
+ path.names.all <- lapply(pathResults, rownames)
+ path.intersect <- Reduce(intersect, path.names.all)
+
+ # remove paths not found by all three - complete.cases
+ path.intersected <- lapply(pathResults, function(x) x[row.names(x) %in% path.intersect,])
+
+ #li_2 <- lapply(seq_along(path.intersected), function(i) {colnames(path.intersected[[i]]) <- paste0(colnames(path.intersected[[i]]), names(path.intersected)[[i]]) ; path.intersected[[i]] } )
+ #path2 <- data.table::setDF(Reduce(merge, lapply(path.intersected, data.table::data.table, keep.rownames = TRUE, key = "rn")))
+ path_full <- path2 <- data.table::setDF(do.call("cbind", lapply(path.intersected, data.table::data.table, keep.rownames = TRUE, key = "rn")))
+
+ # now do the integration
+ # extract the p-values from each option into path2
+ # first if just mummichog
+ if(anal.type=="mummichog"){
+
+ if(pval.method == "fisher"){
+ path2_keep <- grep("rn|FET", colnames(path2))
+ }else{
+ path2_keep <- grep("rn|Gamma", colnames(path2))
+ }
+
+ }else if(anal.type=="gsea_peaks"){ # second if just gsea
+ path2_keep <- grep("rn|P_val", colnames(path2))
+ }else{ # third if both
+ path2_keep <- grep("rn|Combined_Pvals", colnames(path2))
+ }
+
+ # create df of just p-values for meta-analysis
+ path2 <- path2[,path2_keep]
+ path2[path2==0] <- 0.00001 # for sumlog to work
+ rownames(path_full) <- rownames(path2) <- path2[,1]
+ rm_col_inx <- grep("rn", colnames(path2))
+ path2 <- path2[,-rm_col_inx]
+
+ # rename path2
+ if(.on.public.web){
+ #colnames(path2) <- paste0("data", seq_along(colnames(path2)))
+ colnames(path2) <- tools::file_path_sans_ext(metaFiles)
+ }else{
+ colnames(path2) <- tools::file_path_sans_ext(metaFiles)
+ }
+
+ # combine p-values
+ if(pval.method=="fisher"){
+ meta.pvals <- apply(as.matrix(path2), 1, function(x) metap::sumlog(x))
+ }else if(pval.method=="edgington"){
+ meta.pvals <- apply(as.matrix(path2), 1, function(x) metap::sump(x))
+ }else if(pval.method=="stouffer"){
+ meta.pvals <- apply(as.matrix(path2), 1, function(x) metap::sumz(x))
+ }else if(pval.method=="vote"){
+ meta.pvals <- apply(as.matrix(path2), 1, function(x) metap::votep(x))
+ }else if(pval.method=="min"){
+ Meta.P <- apply(as.matrix(path2), 1, function(x) min(x) )
+ }else if(pval.method=="max") {
+ Meta.P <- apply(as.matrix(path2), 1, function(x) max(x) )
+ }else{
+ AddErrMsg("Invalid meta-analysis method!")
+ return(0)
+ }
+
+ #extract p-values
+ if(exists("meta.pvals")){
+ Meta.P <- unlist(lapply(meta.pvals, function(z) z["p"]))
+ }
+ Meta.P <- signif(Meta.P, 5);
+ path2 <- cbind(path2, Meta.P)
+ path2 <- path2[order(path2$Meta.P),]
+
+ mSetObj$metaLevel <- metaLevel
+ mSetObj$meta_results <- path2
+ mSetObj$meta.pval.method <- pval.method
+
+ path_full <- cbind(path_full, Meta.P)
+ col2_rm <- grep("qs.rn", colnames(path_full))
+ path_full <- path_full[,-col2_rm]
+ path_full <- path_full[order(path_full$Meta.P),]
+ fast.write.csv(path_full, "mspeaks_meta_anal_all_results.csv", row.names = TRUE)
+
+ }else{
+ AddErrMsg("Invalid meta-analysis level selected!")
+ return(0)
+ }
+
+ mSetObj$cmdSet <- CMDSet;
+
+ return(.set.mSet(mSetObj));
+}
+
+############### Function for visualization of MS Peaks to Paths Meta-Analysis #######################
+
+#'Function to create summary plot of MS Peaks to Paths
+#'meta-analysis at the pathway level.
+#'@description This function creates a summary plot of the
+#'MS Peaks to Paths meta-analysis at the pathway level. The plot
+#'can either be a heatmap or a network, both of which can
+#'be made interactive.
+#'NETWORK: The size of the nodes in the network correspond to the number of
+#'studies in which that pathway was significant. The color of the nodes correspond
+#'to the meta-p-value for each pathway, with (default coloring) red being the most
+#'significant and yellow the least.
+#'@param mSetObj Input the name of the created mSetObj object.
+#'@param plotType Use "heatmap" to create a heatmap summary, "network" to create
+#'a network summary, or "bubble" to create a bubble plot summary of the meta-analysis
+#'results.
+#'@param heatmap_colorType Character, "brewer" for R Color Brewer scales or
+#'"viridis" for viridis color scales. Used for creating the heatmap
+#'color scheme.
+#'@param heatmap_palette Character, input the preferred color palette according
+#'to R Color Brewer or viridis (e.g. "RdBu").
+#'@param heatmap_interactive Boolean. FALSE to create a non-interactive plot
+#'and TRUE for plotly generated interactive plot.
+#'@param heatmap_square Boolean. TRUE for the heatmap to be squares versus
+#'rectangles (FALSE).
+#'@param heatmap_allPaths Boolean. TRUE to use all paths when plotting the heatmap.
+#'FALSE to use a subset of paths, number defined in npaths.
+#'@param heatmap_npaths Numeric. The number of pathways to subset the pathway
+#'results.
+#'@param heatmap_vertical Boolean. TRUE, heatmap plot will be vertical. FALSE, heatmap plot
+#'will be horizontal.
+#'@param heatmap_fontSize Numeric, input the preferred font size to be used in the heatmap
+#'plot.
+#'@param pvalCutoff The size of the nodes in the network correspond to the number of
+#'studies in which that pathway was significant. This pvalCutoff (Numeric) is thus used
+#'to determine whether or not a pathway was found to be significant in each
+#'individual study.
+#'@param overlap Numeric, this number is used to create edges between the nodes.
+#'By default it is set to 0.25, meaning that if 2 pathways (nodes) share 25% of
+#'the same compounds/empirical compounds, they will be connected by a node.
+#'@param networkType Character, "static" to create a static image or
+#'"interactive" to create an interactive network saved as an html
+#'in your working directory.
+#'@param layout Character, layout from ggraph. "kk" for the spring-based algorithm by Kamada and Kawai
+#'as default. "drl" for force directed algorithm from the DrL toolbox. "lgl" for Large Graph Layout. "fr" for
+#'force-directed of Fruchterman and Reingold.
+#'@param net_palette Character, input the color code for the nodes in the network. Default is
+#'"YlOrRd". Uses the hcl palettes from the grDevices. Use hcl.pals()
+#'to view the name of all available palettes.
+#'@param netTextSize Numeric, input the preferred font size to be used in the network
+#'plot.
+#'@param netPlotSize Numeric, input the preferred dimensions (in inches) of the network
+#'to be saved.
+#'@param bubble_colorType Character, "brewer" for R Color Brewer scales or
+#'"viridis" for viridis color scales. Used for creating the bubble plot
+#'color scheme.
+#'@param bubble_palette Character, use two/three colors max if using R ColorBrewer palettes
+#'for pleasing looking plots.
+PlotPathwayMetaAnalysis <- function(mSetObj = NA, imgName, plotType = "heatmap",
+ heatmap_colorType = "brewer", heatmap_palette = "RdYlBu",
+ heatmap_interactive = FALSE, heatmap_square = TRUE,
+ heatmap_allPaths = TRUE, heatmap_npaths = 25, heatmap_vertical = TRUE,
+ heatmap_fontSize = 9, pvalCutoff = 0.05, overlap = 0.25,
+ networkType = "static", layout="kk", net_palette = "YlOrRd",
+ netTextSize = 2.5, netPlotSize = 7.5,
+ bubble_interactive = FALSE, bubbleMaxPaths = 15,
+ bubble_colorType = "brewer", bubble_palette = "RdBu",
+ bubbleFontSize = 9, bubblePlotSize = 7){
+
+ mSetObj <- .get.mSet(mSetObj);
+ metaLevel <- mSetObj$metaLevel;
+
+ if(metaLevel != "pathway"){
+ AddErrMsg("Function only for pathway-level meta-analysis!")
+ return(0)
+ }
+
+ path_results <- mSetObj$meta_results
+
+ if(plotType == "heatmap"){
+
+ path_results <- data.frame(apply(path_results, 2, rev), stringsAsFactors = FALSE)
+ path_results$pathways <- factor(rownames(path_results), as.character(unique(rownames(path_results))))
+
+ if(nrow(path_results) > heatmap_npaths & !heatmap_allPaths){
+ path_results <- tail(path_results, heatmap_npaths)
+ }
+
+ library(reshape2)
+
+ path_results <- melt(path_results, id = "pathways")
+
+ if(heatmap_colorType == "brewer"){
+ library(RColorBrewer)
+ pal <- colorRampPalette(brewer.pal(n = 9, heatmap_palette))
+ size = length(unique(path_results$value))
+ pal.pal <- pal(size)
+ }
+
+ library(ggplot2)
+
+ if(heatmap_vertical){
+ path.heatmap <- ggplot(data = path_results, mapping = aes(x = variable, y = pathways, fill = value))
+ }else{
+ path_results <- path_results[nrow(path_results):1,]
+ path.heatmap <- ggplot(data = path_results, mapping = aes(x = pathways, y = variable, fill = value))
+ }
+
+ path.heatmap <- path.heatmap +
+ geom_tile(color = "white") +
+ #remove x and y axis labels
+ labs(x="", y="", title="MS Peaks to Pathway Meta-Analysis") +
+ #remove extra space
+ scale_y_discrete(expand=c(0,0)) +
+ scale_x_discrete(expand=c(0,0)) +
+ #set a base size for all fonts
+ theme_grey(base_size=heatmap_fontSize) +
+ theme(axis.text.x = element_text(angle = 90, hjust = 1)) +
+ #theme options
+ theme(
+ #bold font for legend text
+ legend.text=element_text(face="bold"),
+ #set thickness of axis ticks
+ axis.ticks=element_line(size=0.4),
+ #remove plot background
+ plot.background=element_blank(),
+ #remove plot border
+ panel.border=element_blank())
+
+ if(heatmap_colorType == "brewer"){
+ path.heatmap <- path.heatmap +
+ scale_fill_gradient2(low = pal.pal[1],
+ mid = pal.pal[size/2],
+ high = pal.pal[size],
+ midpoint = 0.5,
+ name = "P-Value",
+ na.value="transparent")
+ }else{
+
+ library(viridis)
+ check.palette <- heatmap_palette %in% c("viridis", "magma", "plasma", "inferno")
+
+ if(!check.palette){
+ heatmap_palette <- "viridis"
+ }
+
+ path.heatmap <- path.heatmap +
+ scale_fill_viridis(option=heatmap_palette)+
+ labs(fill="P-Value")
+ }
+
+ if(heatmap_square){
+ path.heatmap <- path.heatmap + coord_fixed()
+ }
+
+ ggsave("mspeaks_pathway_heatmap.png")
+
+ if(heatmap_interactive){
+ library(plotly)
+ ax <- list(
+ zeroline = FALSE,
+ showline = FALSE,
+ showgrid = FALSE
+ )
+ p <- plotly::ggplotly(path.heatmap)
+ p <- p %>% layout(xaxis = ax, yaxis = ax)
+ htmlwidgets::saveWidget(p, "mspeaks_pathway_heatmap_interactive.html")
+ }
+
+ }
+
+ if(plotType == "network"){
+
+ hits_sig <- rowSums(path_results[, -ncol(path_results)] < pvalCutoff) + 1 # account for 0 studies < cutoff
+ folds <- scales::rescale(hits_sig, to = c(1,10))
+ names(folds) <- GetShortNames(rownames(path_results));
+ pvals <- path_results[,ncol(path_results)];
+ names(pvals) <- rownames(path_results)
+ title <- "MS Peaks to Pathway Network Overview";
+
+ if("emp_cpds" %in% names(mSet$pathways)){
+ path.names <- mSetObj$pathways$name
+ current.mset <- mSetObj$pathways$emp_cpds;
+ names(current.mset) <- path.names
+ }else{
+ path.names <- mSetObj$pathways$name
+ current.mset <- mSetObj$pathways$cpds;
+ names(current.mset) <- path.names
+ }
+
+ if(length(folds) > 50){
+ folds <- folds[1:50];
+ pvals <- pvals[1:50];
+ title <- "MS Peaks to Pathway Network Overview (Top 50)";
+ }
+
+ if(.on.public.web){
+ load_igraph()
+ load_reshape()
+ }
+
+ pvalue <- pvals;
+ id <- names(pvalue);
+ geneSets <- current.mset;
+ n <- length(pvalue);
+ w <- matrix(NA, nrow=n, ncol=n);
+ colnames(w) <- rownames(w) <- id;
+
+ for (i in 1:n) {
+ for (j in i:n) {
+ w[i,j] = overlap_ratio(geneSets[id[i]], geneSets[id[j]])
+ }
+ }
+
+ wd <- melt(w);
+ wd <- wd[wd[,1] != wd[,2],];
+ wd <- wd[!is.na(wd[,3]),];
+ g <- graph.data.frame(wd[,-3], directed=F);
+ E(g)$width <- sqrt(wd[,3]*20);
+ g <- delete.edges(g, E(g)[wd[,3] < overlap]); # change
+ V(g)$color <- hcl.colors(length(pvalue), net_palette);
+
+ cnt <- folds;
+ names(cnt) <- id;
+
+ if(networkType == "static"){
+ V(g)$size <- cnt + 3;
+ }else{
+ V(g)$size <- cnt + 20;
+ }
+
+ pos.xy <- layout.fruchterman.reingold(g,niter=500);
+
+ # now create the json object
+ nodes <- vector(mode="list");
+ node.nms <- V(g)$name;
+ node.sizes <- V(g)$size;
+ node.cols <- V(g)$color;
+
+ if(.on.public.web){
+ for(i in 1:length(node.sizes)){
+ nodes[[i]] <- list(
+ id = node.nms[i],
+ label=node.nms[i],
+ size=node.sizes[i],
+ color=node.cols[i],
+ x = pos.xy[i,1],
+ y = pos.xy[i,2]
+ );
+ }
+
+ edge.mat <- get.edgelist(g);
+ edge.mat <- cbind(id=1:nrow(edge.mat), source=edge.mat[,1], target=edge.mat[,2]);
+ # covert to json
+ netData <- list(nodes=nodes, edges=edge.mat);
+ sink("ms_peaks_network.json");
+ cat(RJSONIO::toJSON(netData));
+ sink();
+ return(g);
+ }else{
+ if(networkType == "static"){
+ # static plot
+ library(ggraph)
+ p <- ggraph(g, layout=layout) + theme_void() +
+ geom_edge_fan(color="gray20", width=0.5, alpha=0.5) +
+ geom_node_point(color=V(g)$color, size=V(g)$size, alpha = 0.95) +
+ geom_node_text(aes(label = V(g)$name), size = netTextSize, repel=TRUE, nudge_y = 0.05, nudge_x = 0.05, check_overlap = TRUE) +
+ # 10% space above/to the side of x
+ scale_y_continuous(expand = expansion(mult = c(.1, .1))) +
+ scale_x_continuous(expand = expansion(mult = c(.1, .1)))
+
+ filename <- paste0(anal.type, "_network", ".png")
+ ggsave(p, file=filename, width = netPlotSize, height = netPlotSize)
+
+ }else{
+ # interactive plot
+ library(visNetwork)
+ data <- toVisNetworkData(g)
+ network <- visNetwork(nodes = data$nodes, edges = data$edges,
+ idToLabel = TRUE, height = "900px", width = "100%") %>% visEdges(color=list(color="grey", highlight="red")) %>% visNodes(font = list(size = 30))
+
+ filename <- paste0(anal.type, "_network", ".html")
+ visSave(network, file = filename)
+ }
+ }
+ }
+
+ if(plotType == "bubble"){
+
+ full_results <- read.csv("mspeaks_meta_anal_all_results.csv", row.names = 1)
+
+ if(nrow(path_results) > bubbleMaxPaths){
+ path_results <- path_results[seq_len(bubbleMaxPaths),]
+ full_results <- full_results[seq_len(bubbleMaxPaths),]
+ }
+
+ if(anal.type=="gsea_peaks"){
+
+ studies <- colnames(path_results)[-length(colnames(path_results))] # remove the Meta.P
+ studies_pathway_total <- paste0(studies, ".qs.Pathway_Total")
+ studies_sig_hits <- paste0(studies, ".qs.Hits")
+
+ }else if(anal.type=="mummichog"){
+
+ studies <- colnames(path_results)[-length(colnames(path_results))] # remove the Meta.P
+ studies_pathway_total <- paste0(studies, ".qs.Pathway.total")
+ studies_sig_hits <- paste0(studies, ".qs.Hits.sig")
+
+ }else{ #integ
+
+ studies <- colnames(path_results)[-length(colnames(path_results))] # remove the Meta.P
+ studies_pathway_total <- paste0(studies, ".qs.Total_Size")
+ studies_sig_hits <- paste0(studies, ".qs.Sig_Hits")
+
+ }
+
+ studies_pathway_total <- full_results[,grepl(paste(studies_pathway_total, collapse="|"), colnames(full_results))]
+ studies_pathway_total_list <- lapply(split(t(studies_pathway_total), 1:nrow(t(studies_pathway_total))), unlist)
+
+ studies_sig_hits <- full_results[,grepl(paste(studies_sig_hits, collapse="|"), colnames(full_results))]
+ studies_sig_hits_list <- lapply(split(t(studies_sig_hits), 1:nrow(t(studies_sig_hits))), unlist)
+
+ ratio <- as.data.frame(mapply(function(X, Y) {
+ x = unlist(X)
+ y = unlist(Y)
+ ratio = x/y
+ return(ratio)
+ }, X = studies_sig_hits_list, Y = studies_pathway_total_list))
+
+ ratio_String <- as.data.frame(mapply(function(X, Y, Z) {
+ x = unlist(X)
+ y = unlist(Y)
+ z = unlist(Z)
+ #ratio_String = paste0(z, " [", x, "/", y, "]");
+ ratio_String = paste0(z);
+ return(ratio_String)
+ },
+ X = studies_sig_hits_list,
+ Y = studies_pathway_total_list,
+ Z = as.list(path_results[,-ncol(path_results)])))
+
+ ## Added row to calculate the average ratio
+ ratio_mean <- apply(ratio, 1, mean);
+ ratio <- cbind(ratio, ratio_mean);
+
+ ratio_String <- cbind(ratio_String, format(round(ratio_mean, 4)*100, nsmall = 2));
+
+ colnames(ratio) <- c(studies,"Meta.P");
+ #colnames(ratio_String) <- c(paste0(sub("mummichoginput", "",studies),"_Pvalue [Sig/Total]"), "Mean_Enrich(%)");
+ colnames(ratio_String) <- c(paste0(sub("mummichoginput", "",studies),"_Pvalue"), "Mean_Enrich(%)");
+ ratio$Pathway <- rownames(path_results);
+
+ ratio_String <- cbind(rownames(path_results), ratio_String);
+
+ ratio2 <- reshape2::melt(ratio, id.vars = "Pathway", variable.name = "Study", value.name = "Enrichment_Ratio")
+
+ #path_results <- path_results[, -length(colnames(path_results))]
+ path_results$Pathway <- rownames(path_results)
+ path_results2 <- reshape2::melt(path_results, id.vars = "Pathway", variable.name = "Study", value.name = "P_Value");
+
+ res_table <- cbind(ratio_String, path_results$Meta.P);
+ colnames(res_table)[c(1, length(colnames(res_table)))] <- c("Pathways", "Meta.P")
+
+ res_table <- res_table[order(res_table$Meta.P, -as.numeric(res_table$Mean_Enrich)),]
+
+ mSetObj$dataSet$res_table <- res_table;
+
+ require(ggplot2);
+ require(RColorBrewer);
+
+ ## This oder matrix is used to order the metap (first by P value, second by enrichment ratio)
+ order_matrix0 <- merge(path_results, ratio, by = c("Pathway"));
+ ColNMs <- c("Pathway", paste0(sub("mummichoginput", "",studies),"P_value"),"Meta.P",paste0(sub("mummichoginput", "",studies),"Enrich"),"Average_Enrich")
+
+ order_matrix <- cbind(order_matrix0$Pathway, order_matrix0$Meta.P.x, order_matrix0$Meta.P.y);
+ metap_order <- order_matrix[order(order_matrix[,2], -as.numeric(order_matrix[,3]))]
+
+ colnames(order_matrix0) <- ColNMs;
+ write.csv(order_matrix0, file = "Result_summary.csv",row.names = FALSE)
+
+ df <- merge(path_results2, ratio2, by = c("Pathway", "Study"))
+ df$Pathway <- factor(df$Pathway, levels = rownames(path_results))
+ df$Study <- sub("mummichoginput", "", df$Study);
+ df$Study <- as.factor(df$Study);
+
+ p <- ggplot(df, aes(x = Study, y = Pathway)) +
+ geom_point(aes(size = Enrichment_Ratio, col = P_Value)) +
+ theme(legend.key=element_blank(),
+ axis.text = element_text(size = bubbleFontSize),
+ axis.text.x = element_text(angle = 45, hjust = 1),
+ panel.background = element_blank(),
+ panel.border = element_rect(colour = "black", fill = NA, size = 0.5),
+ axis.title.x=element_blank(),
+ axis.title.y=element_blank()) +
+ scale_y_discrete(limits = rev(metap_order))
+
+ if(bubble_colorType == "brewer"){
+ pal <- brewer.pal(n = 8, bubble_palette)
+ p <- p + scale_colour_gradientn(colours = pal)
+ }else{
+
+ check.palette <- bubble_palette %in% c("viridis", "magma", "plasma", "inferno")
+
+ if(!check.palette){
+ bubble_palette <- "viridis"
+ }
+
+ p <- p + scale_color_viridis_c(option=bubble_palette, direction = -1)
+ }
+
+ filename <- paste0(imgName, ".png")
+ ggsave(p, file=filename, width = bubblePlotSize, height = bubblePlotSize*0.6)
+
+ if(bubble_interactive){
+ library(plotly)
+ ax <- list(
+ zeroline = FALSE,
+ showline = FALSE,
+ showgrid = FALSE
+ )
+ p <- plotly::ggplotly(p)
+ p <- p %>% layout(xaxis = ax, yaxis = ax)
+ htmlwidgets::saveWidget(p, "mspeaks_pathway_bubble_interactive.html")
+ }
+
+ mSetObj$imgSet$mummi.meta.path.plot <- filename;
+
+ }
+ return(.set.mSet(mSetObj));
+}
+
+########################################
+########################################
+########### Functions for Web ##########
+########################################
+########################################
+
+## R functions used to prepare for meta-mummichog analysis
+PrepareMetaPath <- function(mSetObj = NA, mode = "negative", ppm = 30,
+ version = "v2", pcutoff = 0.05, rt.type = "seconds") {
+
+ if(file.exists("mSet.qs") & .on.public.web){
+ mSetObj <<- qs::qread("mSet.qs")
+ } else {
+ mSetObj <- .get.mSet(mSetObj);
+ qs::qsave(mSetObj, file = "mSet.qs")
+ }
+
+ if(rt.type == "false"){
+ rt = FALSE
+ }else{
+ rt = TRUE
+ if(!(rt.type %in% c("seconds", "minutes"))){
+ AddErrMsg("Invalid RT type! Should be seconds or minutes!")
+ return(0)
+ }
+ }
+
+ if(!exists("rt.studies")){
+ rt.studies <- vector()
+ }
+
+ rt.studies <<- c(rt.studies, rt)
+
+ CMDSet <- mSetObj$cmdSet
+
+ if(length(mSetObj$dataSet2) == 0) {
+ # Here is dealing with the single ion mode data
+ mSetObj <- Ttests.Anal(mSetObj, F, 0.05, FALSE, TRUE);
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj <- Convert2MummichogMetaPath(mSetObj, rt, rds.file=FALSE, rt.type, "all", mode);
+
+ mSetObj <- .get.mSet(mSetObj);
+ fileNM <- mSetObj$dataSet$name;
+ fileNM <- gsub("\\.[^.]*$", "", basename(fileNM));
+ filename <- paste0(fileNM, "_mummichog_input.txt");
+
+ mSetObj <- .get.mSet(mSetObj);
+ mummi_new <- mSetObj$dataSet$mummi_new;
+ write.table(mummi_new, filename, row.names = FALSE)
+ } else {
+
+ # Here is dealing with the mix ion modes' data
+ # 1st step -- handle the dataset (pos) data in mSet
+ file.rename("data_orig1.qs", "data_orig.qs");
+ mSetObj1 <- mSetObj2 <- vector("list")
+ mSetObj1$dataSet <- mSetObj$dataSet
+ mSetObj2$dataSet <- mSetObj$dataSet2
+ .set.mSet(mSetObj1)
+ mSetObj1 <- Ttests.Anal(mSetObj1, F, 0.05, FALSE, TRUE);
+ mSetObj1 <- Convert2MummichogMetaPath(mSetObj1, rt, rds.file=FALSE, rt.type, "all", "positive");
+ mSetObj1 <- .get.mSet(mSetObj1);
+ dataset_pos <- mSetObj1$dataSet;
+
+ file.rename("data_orig.qs", "data_orig1.qs");
+
+ # 2nd step -- handle the dataset (neg) data in mSet
+ .set.mSet(mSetObj2)
+ file.rename("data_orig2.qs", "data_orig.qs");
+ mSetObj2 <- Ttests.Anal(mSetObj2, F, 0.05, FALSE, TRUE);
+ mSetObj2 <- Convert2MummichogMetaPath(mSetObj2, rt, rds.file=FALSE, rt.type, "all", "negative");
+ mSetObj2 <- .get.mSet(mSetObj2);
+ dataset_neg <- mSetObj2$dataSet;
+ file.rename("data_orig.qs", "data_orig2.qs");
+ fileNM <- mSetObj$dataSet$name;
+ fileNM <- gsub("\\.[^.]*$", "", basename(fileNM));
+ filename <- paste0(fileNM, "_mixed_mummichog_input.txt");
+
+ # Merge and save them
+ mtbl_all <- rbind(dataset_pos$mummi_new, dataset_neg$mummi_new[-1,])
+ write.table(mtbl_all, filename, row.names = FALSE, col.names = TRUE)
+
+ rm(mSetObj1)
+ rm(mSetObj2)
+ }
+
+ mSet <<- NULL;
+ mSetObj <- NULL;
+
+ mSetObj<-InitDataObjects("mass_all", "mummichog", FALSE);
+ SetPeakFormat("mpt");
+ mSetObj<-UpdateInstrumentParameters(mSetObj, ppm, mode);
+ mSetObj<-Read.PeakListData(mSetObj, filename, meta.anal=TRUE, method="both");
+ mSetObj<-SanityCheckMummichogData(mSetObj);
+
+ if(.on.public.web){
+ res <- SetMummichogPval(mSetObj, pcutoff);
+ }else{
+ mSetObj <- SetMummichogPval(mSetObj, pcutoff);
+ }
+
+ mSetObj <- savePeakListMetaData(mSetObj)
+
+ if(.on.public.web){
+ mSetObj <- InitDataObjects("conc", "metapaths", FALSE)
+ mSet$cmdSet <<- CMDSet;
+ return(res)
+ }else{
+ mSetObj$analSet$type <- "metapaths";
+ anal.type <<- "metapaths"
+ return(.set.mSet(mSetObj))
+ }
+}
+
+CheckAllRT <- function(){
+
+ if(all(rt.studies)){
+ rt = "true"
+ }else{
+ rt = "false"
+ }
+
+ return(rt)
+}
+
+mSetQSDelete <- function(){
+ if (file.exists("mSet.qs")) {
+ file.remove("mSet.qs")
+ }
+}
+
+CacheQSClean <- function(){
+ if(file.exists("complete_norm.qs")) file.remove("complete_norm.qs");
+ if(file.exists("complete_norm1.qs")) file.remove("complete_norm1.qs");
+ if(file.exists("complete_norm2.qs")) file.remove("complete_norm2.qs");
+}
+
+readMetaPathTable <- function(mSetObj = NA, dataNM, dataFormat, dataType) {
+
+ if(.on.public.web){
+ if(file.exists("data_orig.qs")) file.remove("data_orig.qs");
+ if(file.exists("data_orig1.qs")) file.remove("data_orig1.qs");
+ if(file.exists("data_orig2.qs")) file.remove("data_orig2.qs")
+ if(file.exists("mSet.qs")) file.remove("mSet.qs")
+ if(file.exists("prenorm.qs")) file.remove("prenorm.qs")
+ if(file.exists("preproc.qs")) file.remove("preproc.qs")
+ }
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(dataType == "massPeaks"){
+ # Handle mass peaks for mummichog
+ mSetObj <- Read.TextData(mSetObj, dataNM, dataFormat, "disc");
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$dataSet$name <- dataNM;
+ mSetObj$dataSet$format <- dataFormat;
+ } else if (dataType == "annoPeaks") {
+ # Handle annotated compounds for QEA pathway
+ # TODO: add more later
+ } else {
+
+ if(.on.public.web){
+ return (0);
+ }else{
+ AddErrMsg("Could not upload data file!")
+ return(0)
+ }
+ }
+
+ if(.on.public.web){
+ .set.mSet(mSetObj)
+ return (1)
+ }else{
+ return(.set.mSet(mSetObj));
+ }
+}
+
+readMetaPathTableMix <- function(mSetObj = NA, dataNM, dataNM2, dataFormat, dataType) {
+
+ if(.on.public.web){
+ if(file.exists("data_orig.qs")) file.remove("data_orig.qs");
+ if(file.exists("data_orig1.qs")) file.remove("data_orig1.qs");
+ if(file.exists("data_orig2.qs")) file.remove("data_orig2.qs")
+ if(file.exists("mSet.qs")) file.remove("mSet.qs")
+ if(file.exists("prenorm.qs")) file.remove("prenorm.qs")
+ if(file.exists("preproc.qs")) file.remove("preproc.qs")
+ }
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(dataType == "massPeaks"){
+ # Handle mass peaks for mummichog
+ mSetObj <- Read.TextData(mSetObj, dataNM, dataFormat, "disc");
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$dataSet$name <- dataNM;
+ mSetObj$dataSet$format <- dataFormat;
+ mSet0 <- mSetObj;
+ file.rename("data_orig.qs", "data_orig1.qs")
+
+ mSet0$dataSet2 <- list();
+ mSetObj <- Read.TextData(mSetObj, dataNM2, dataFormat, "disc");
+ mSetObj <- .get.mSet(mSetObj);
+ mSet0$dataSet2 <- mSetObj$dataSet;
+ mSet0$dataSet2$name <- dataNM2;
+ mSet0$dataSet2$format <- dataFormat;
+ file.rename("data_orig.qs", "data_orig2.qs")
+ } else if (dataType == "annoPeaks") {
+ # Handle annotated compounds for QEA pathway
+ # TODO: add more later
+ } else {
+ return (0);
+ }
+
+ if(.on.public.web){
+ .set.mSet(mSet0)
+ return (1)
+ }else{
+ return(.set.mSet(mSet0));
+ }
+}
+
+SanityCheckMetaPathTable<-function(mSetObj=NA, dataName){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(mSetObj$dataSet$name != dataName){
+ dataSet <- qs::qread(dataName);
+ }else{
+ dataSet <- mSetObj$dataSet
+ }
+
+ if(length(mSetObj$dataSet2) > 0){
+ data_oriNM <- c("data_orig1.qs", "data_orig2.qs");
+ } else {
+ data_oriNM <- "data_orig.qs";
+ }
+
+ msg <- NULL;
+
+ for(i in seq(data_oriNM)){
+
+ conc <- qs::qread(data_oriNM[i]);
+
+ if(i == 2){
+ dataSet <- mSetObj[[paste0("dataSet",i)]];
+ }
+
+ cls.lbl <- dataSet$cls.orig <- dataSet$orig.cls;
+ smpl.nms <- dataSet$orig.smp.nms;
+ var.nms <- dataSet$orig.var.nms;
+
+ empty.inx <- is.na(smpl.nms) | smpl.nms == ""
+ if(sum(empty.inx) > 0){
+ msg <- c(msg, paste("<font color=\"red\">", sum(empty.inx), "empty rows</font> were detected and excluded from your data."));
+ smpl.nms <- smpl.nms[!empty.inx];
+ cls.lbl <- cls.lbl[!empty.inx];
+ conc <- conc[!empty.inx, ];
+ }else{
+ msg <- c(msg, paste0("No empty rows were found in your data: ", dataName));
+ }
+
+ # try to check & remove empty lines if class label is empty
+ # Added by B. Han
+ empty.inx <- is.na(cls.lbl) | cls.lbl == ""
+ if(sum(empty.inx) > 0){
+ msg <- c(msg, paste("<font color=\"red\">", sum(empty.inx), "empty labels</font> were detected and excluded from your data."));
+ smpl.nms <- smpl.nms[!empty.inx];
+ cls.lbl <- cls.lbl[!empty.inx];
+ conc <- conc[!empty.inx, ];
+ }else{
+ msg <- c(msg, paste0("No empty labels were found in your data: ", dataName));
+ }
+
+ if(length(unique(cls.lbl[!empty.inx])) > 2){
+ msg <- c(msg, paste(c("Groups found:", unique(cls.lbl[!empty.inx])), collapse=" "));
+ msg <- c(msg, "<font color=\"red\">Meta-analysis is only defined for two-group comparisions!</font>");
+ current.msg <<- msg;
+ return(0);
+ }else{
+ lvls <- as.character(unique(unlist(cls.lbl)))
+ msg <- c(msg, paste("Two groups found:", lvls[1], "and", lvls[2], collapse=" "));
+ }
+
+ # check for uniqueness of dimension name
+ if(length(unique(smpl.nms))!=length(smpl.nms)){
+ dup.nm <- paste(smpl.nms[duplicated(smpl.nms)], collapse=" ");
+ msg <- c(msg, "Duplicate sample names are not allowed!");
+ current.msg <<- msg;
+ return(0);
+ }else{
+ msg <- c(msg, "All sample names are unique.");
+ }
+
+ # try to remove check & remove empty line if feature name is empty
+ empty.inx <- is.na(var.nms) | var.nms == "";
+ if(sum(empty.inx) > 0){
+ msg <- c(msg, paste("<font color=\"red\">", sum(empty.inx), "empty features</font> were detected and excluded from your data."));
+ var.nms <- var.nms[!empty.inx];
+ conc <- conc[,!empty.inx];
+ }else{
+ msg <- c(msg, "No empty feature names found");
+ }
+
+ if(length(unique(var.nms))!=length(var.nms)){
+ dup.inx <- which(duplicated(var.nms));
+ msg <- c(msg, paste("Error: a total of", length(dup.inx), "duplicate feature names found!"));
+ if(length(dup.inx) > 9){
+ dup.inx <- dup.inx[1:9];
+ }
+ dup.nm <- paste("Duplicated names [max 9]: ", var.nms[dup.inx], collapse=" ");
+ AddErrMsg(dup.nm);
+ current.msg <<- msg;
+ return(0);
+ }else{
+ msg <- c(msg, "All feature names are unique");
+ }
+
+ # now check for special characters in the data labels
+ if(sum(is.na(iconv(smpl.nms)))>0){
+ na.inx <- is.na(iconv(smpl.nms));
+ nms <- paste(smpl.nms[na.inx], collapse="; ");
+ msg <- c(msg, paste("No special letters (i.e. Latin, Greek) are allowed in sample names!", nms, collapse=" "));
+ current.msg <<- msg;
+ return(0);
+ }else{
+ msg <- c(msg, "All sample names are OK");
+ }
+
+ if(sum(is.na(iconv(var.nms)))>0){
+ na.inx <- is.na(iconv(var.nms));
+ nms <- paste(var.nms[na.inx], collapse="; ");
+ msg <- c(msg, paste("No special letters (i.e. Latin, Greek) are allowed in feature names!", nms, collapse=" "));
+ current.msg <<- msg;
+ return(0);
+ }else{
+ msg <- c(msg, "All feature names are OK");
+ }
+
+ # only keep alphabets, numbers, ",", "." "_", "-" "/"
+ smpl.nms <- gsub("[^[:alnum:]./_-]", "", smpl.nms);
+ var.nms <- gsub("[^[:alnum:][:space:],'./_-]", "", var.nms); # allow space, comma and period
+ cls.lbl <- ClearStrings(as.vector(cls.lbl));
+
+ # now assgin the dimension names
+ conc <- apply(conc, 2, as.numeric);
+ rownames(conc) <- smpl.nms;
+ colnames(conc) <- var.nms;
+
+ proc.cls <- as.factor(as.character(cls.lbl));
+
+ # now need to remove low quality samples and genes
+ data <- conc;
+ smpl.num <- nrow(data);
+ gene.num <- ncol(data);
+
+ # remove smpls/exp with over half missing value
+ good.inx<-apply(is.na(data), 1, sum)/ncol(data)<0.6;
+ smpl.msg <- "";
+ if(sum(!good.inx)>0){
+
+ msg <- c(msg, paste(sum(!good.inx), "low quality samples(>60% missing) removed."));
+
+ data <- data[good.inx,];
+ if(nrow(data)/smpl.num < 0.5){
+ msg <- c(msg, paste(msg, "Low quality data rejected!"));
+ current.msg <<- msg;
+ return(0);
+ }
+
+ # update meta information
+ proc.cls <- proc.cls[good.inx];
+ }
+
+ if(ncol(data) < 4){
+ msg <- c(msg, paste("The sample # (", nrow(data), ") is too small."));
+ current.msg <<- msg;
+ return(0);
+ }else{
+ msg <- c(msg, paste("A total of", nrow(data), "samples were found."));
+ }
+
+ # feature with 75% NA will be removed
+ gd.inx<-apply(is.na(data), 2, sum)/nrow(data) < 0.75;
+
+ feat.msg <- "";
+ if(sum(!gd.inx) > 0){
+ data <- data[, gd.inx];
+ msg <- c(msg, paste(sum(!gd.inx), "low quality features (>75% missing) removed"));
+ if(ncol(data)/gene.num < 0.25){
+ msg <- c(msg, paste(feat.msg, "Low quality data rejected."));
+ current.msg <<- msg;
+ return(0);
+ }
+ }
+
+ # feature with 90% ZEROs will be removed
+ gd.inx<-apply(data==0, 2, function(x) {sum(x, na.rm=T)})/nrow(data) < 0.9;
+
+ feat.msg <- "";
+ if(sum(!gd.inx) > 0){
+ data <- data[, gd.inx];
+ msg <- c(msg, paste(sum(!gd.inx), "low quality features (>90% zeros) removed"));
+ if(ncol(data)/gene.num< 0.25){
+ msg <- c(msg, paste(feat.msg, "Low quality data rejected."));
+ current.msg <<- msg;
+ return(0);
+ }
+ }
+
+ if(ncol(data) < 10){
+ msg <- c(msg, "The feature# (", ncol(data), ") is too small (<10).");
+ current.msg <<- msg;
+ return(0);
+ } else {
+ msg <- c(msg, paste("A total of", ncol(data), "features were found.", collapse=" "));
+ }
+
+ # replace missing values should use median for normalized data
+ min.val <- min(data[data>0], na.rm=T)/10;
+ data[is.na(data)] <- min.val;
+ data[data<=0] <- min.val;
+
+
+ dataSet$data.proc <- dataSet$data <- data;
+ dataSet$cls.proc <- dataSet$cls <- factor(proc.cls);
+
+ ## set 1 or 2
+ if(i == 1){
+ mSetObj$dataSet <- dataSet
+ } else {
+ mSetObj$dataSet2 <- dataSet
+ }
+
+ #RegisterData(mSetObj, dataSet)
+ } # end of the for loop
+
+ # Collect all msg here
+ mSetObj$dataSet$check.msg <- msg;
+
+ if(.on.public.web){
+ .set.mSet(mSetObj);
+ return(1);
+ } else {
+ RegisterData(mSetObj, dataSet)
+ return(.set.mSet(mSetObj));
+ }
+
+}
+
+GetMetaPathSanityCheckMsg <- function(mSetObj=NA, dataName){
+
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$dataSet$check.msg);
+}
+
+GetMetaPathDataDims <- function(mSetObj=NA, dataName){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(mSetObj$dataSet$name != dataName){
+ data <- mSetObj$dataSet2$data;
+ } else {
+ data <- mSetObj$dataSet$data;
+ }
+
+ dm <- dim(data);
+ naNum <- sum(is.na(data));
+ zoNum <- sum(data == 0);
+ return(c(dm, naNum, zoNum));
+}
+
+GetMetaPathGroupNames <-function(mSetObj=NA, dataName){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(mSetObj$dataSet$name != dataName){
+ dataSet <- qs::qread(dataName);
+ }
+ return(levels(mSetObj$dataSet$cls));
+}
+
+PlotPathDataProfile<-function(dataName, boxplotName, pcaName, dataformat){
+ #dataSet <- qs::qread(dataName);
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(.on.public.web){
+ load_lattice()
+ }
+ datatable <- mSetObj$dataSet$data;
+
+ if(is.null(datatable)){
+
+ if(dataformat == "colu"){
+ dt <- t(read.csv(dataName)[-1,])
+ colnames(dt) <- dt[1,]
+ } else if(dataformat == "rowu"){
+ dt <- read.csv(dataName,header = FALSE);
+ rownames(dt) <- dt[,1]
+ dt <- dt[,-c(1,2)]
+ colnames(dt) <- dt[1,]
+ dt <- dt[-1,]
+ }
+ datatable <- dt;
+ is.na(datatable) <-0 ;
+ }
+
+ qc.boxplot(datatable, boxplotName);
+}
+
+MetaPathNormalization <- function(mSetObj = NA, sampleNor, tranform, scale){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(length(mSetObj$dataSet2) == 0){
+ mSetObj <- SanityCheckData(mSetObj);
+ mSetObj <- ReplaceMin(mSetObj);
+ mSetObj <- FilterVariable(mSetObj, "iqr", "F", 25)
+ mSetObj <- PreparePrenormData(mSetObj)
+ mSetObj <- Normalization(mSetObj, sampleNor, tranform, "NULL", ratio=FALSE, ratioNum=20) #TODO: to enable scale function later
+ mSetObj <- PlotNormSummary(mSetObj, "norm")
+ mSetObj <- .get.mSet(mSetObj);
+ } else {
+ ## This is used to deal with the mix data files
+ # 1st step, process dataset 1 (pos data)
+ file.rename("data_orig1.qs", "data_orig.qs");
+ mSetObj <- SanityCheckData(mSetObj);
+ mSetObj <- ReplaceMin(mSetObj);
+ mSetObj <- FilterVariable(mSetObj, "iqr", "F", 25)
+ mSetObj <- PreparePrenormData(mSetObj)
+ mSetObj <- Normalization(mSetObj, sampleNor, tranform, "NULL", ratio=FALSE, ratioNum=20) #TODO: to enable scale function later
+ mSetObj <- PlotNormSummary(mSetObj, "norm_pos")
+ file.rename("data_orig.qs", "data_orig1.qs");
+ file.rename("complete_norm.qs", "complete_norm1.qs");
+ mSetObj <- .get.mSet(mSetObj);
+ dataset_pos <- mSetObj$dataSet;
+
+ # 2nd step, process dataset 2 (neg data)
+ file.rename("data_orig2.qs", "data_orig.qs");
+ mSetObj$dataSet <- mSet$dataSet2;
+ mSetObj <- SanityCheckData(mSetObj);
+ mSetObj <- ReplaceMin(mSetObj);
+ mSetObj <- FilterVariable(mSetObj, "iqr", "F", 25)
+ mSetObj <- PreparePrenormData(mSetObj)
+ mSetObj <- Normalization(mSetObj, sampleNor, tranform, "NULL", ratio=FALSE, ratioNum=20) #TODO: to enable scale function later
+ mSetObj <- PlotNormSummary(mSetObj, "norm_neg")
+ file.rename("data_orig.qs", "data_orig2.qs");
+ file.rename("complete_norm.qs", "complete_norm2.qs");
+
+ mSetObj <- .get.mSet(mSetObj);
+ dataset_neg <- mSetObj$dataSet;
+ # refine the mSet
+ mSetObj$dataSet <- dataset_pos;
+ mSetObj$dataSet2 <- dataset_neg;
+ }
+
+ if(.on.public.web){
+ .set.mSet(mSetObj)
+ return(1)
+ }else{
+ return(.set.mSet(mSetObj));
+ }
+}
+
+GetMetaPathResultColNames <- function() {
+ mSetObj <- .get.mSet(mSetObj);
+ return(colnames(mSetObj$dataSet$res_table)[-1])
+}
+
+GetMetaPathNMs <- function() {
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$dataSet$res_table$Pathways)
+}
+
+GetMetaPathResultItem <- function(rowN) {
+ mSetObj <- .get.mSet(mSetObj);
+ res <- mSetObj$dataSet$res_table[,-1];
+ return(as.character(unname(res[rowN,])))
+}
+
+PrepareCMPDList <- function() {
+
+ MetaMummiRes <- RJSONIO::fromJSON("ms_peaks_meta_anal_cpd_matching.json");
+ CMPDSet <- NULL;
+ CMPDSet <- unique(unlist(lapply(MetaMummiRes, function(x) return(unique(x$Matched.Compound)))))
+
+ return(CMPDSet)
+}
+
+Prepare4Network <- function(){
+
+ mSet <<- mSetObj <- NULL;
+
+ mSetObj <- InitDataObjects("conc", "network", FALSE)
+ mSetObj <- SetOrganism(mSetObj, "hsa")
+ cmpdList <- PrepareCMPDList()
+
+ cmpdList <- paste(cmpdList, collapse = "\n")
+ mSetObj <- PerformIntegCmpdMapping(mSetObj, cmpdList, "hsa", "kegg")
+
+ mSetObj <- CreateMappingResultTable(mSetObj)
+
+ mSetObj <- PrepareNetworkData(mSetObj)
+
+ idtype <<- "cmpd";
+ mSetObj <- PrepareQueryJson(mSetObj);
+ mSetObj <- PerformKOEnrichAnalysis_KO01100(mSetObj, "pathway","network_enrichment_pathway_0")
+
+ return(1)
+}
+
+pathsum <- function(pvalCutoff){
+
+ mSetObj <- .get.mSet(NA);
+
+ pathSet <- mSetObj$dataSet$pathResults;
+
+ if(anal.type == "mummichog"){
+ pathSum <- lapply(pathSet, function(x) return(rownames(x)[as.data.frame(x)$FET < pvalCutoff]));
+ }else{
+ pathSum <- lapply(pathSet, function(x) return(rownames(x)[as.data.frame(x)$P_val < pvalCutoff]));
+ }
+
+ names(pathSum) <- gsub("mummichoginput.qs", "", names(pathSum));
+ mSetObj$dataSet$pathSumData <- pathSum;
+ res <- .set.mSet(mSetObj);
+ return(pathSum)
+}
+
+SelectMultiPathData <- function(mSetObj=NA, nmVec = NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+ if(is.na(nmVec[1])){
+ AddErrMsg("No dataset is selected for analysis!");
+ return(0);
+ }
+
+ mSetObj[["dataSet"]][["pathResults_SelectedFiles"]] <-
+ gsub("_","",gsub("\\.[^.]*$", "", basename(nmVec)));
+
+ return(.set.mSet(mSetObj));
+}
+
+PrepareMetaPathData <- function(mSetObj = NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # do something here later
+ dat <- mSetObj[["dataSet"]][["pathSumData"]];
+ datNum <- length(mSetObj[["dataSet"]][["pathResults_SelectedFiles"]]);
+
+ dat <- dat[c(mSetObj[["dataSet"]][["pathResults_SelectedFiles"]])];
+
+ if(datNum == 2){
+ Prepare2Venn(dat);
+ }else if(datNum == 3){
+ Prepare3Venn(dat);
+ }else if(datNum == 4){
+ Prepare4Venn(dat);
+ }else{
+ AddErrMsg("Too big of a number of features for the venn diagram");
+ return(0);
+ }
+
+ return(.set.mSet(mSetObj));
+}
+
+GetVennPathsNames <- function(mSetObj=NA, areas){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ res <- vennData[[areas]];
+ if(length(res) ==0){
+ return("NA")
+ } else {
+ return(paste(res, collapse="||"))
+ }
+}
+
+
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/misc_effect_size_functions.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/misc_effect_size_functions.R
new file mode 100644
index 0000000000000000000000000000000000000000..b2829d81a70f0730bd157f5378f08e3a307f7ce5
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/misc_effect_size_functions.R
@@ -0,0 +1,709 @@
+#######################
+#######################
+# functions for combining effect-sizes
+# adapted from the meta and metafor R packages
+my_metagen <- function(TE, comb.fixed=TRUE, comb.random=FALSE, lower, upper, method.tau="DL"){
+
+ seTE <- rep(NA, length(TE))
+
+ sel.NA <- is.na(seTE)
+
+ seTE <- my.TE.seTE.ci(lower, upper, 0.95)$seTE
+
+ if(comb.fixed){
+ ## Fixed effect estimate (Cooper & Hedges, 1994, p. 265-6)
+ w.fixed <- 1 / seTE^2
+ w.fixed[is.na(w.fixed) | is.na(TE)] <- 0
+
+ TE.fixed <- weighted.mean(TE, w.fixed, na.rm = TRUE)
+ seTE.fixed <- sqrt(1 / sum(w.fixed, na.rm = TRUE))
+
+ ci.f <- my_ci(TE.fixed, seTE.fixed, 0.95, null.effect = 0)
+ zval.fixed <- ci.f$z
+ pval.fixed <- ci.f$p
+ lower.fixed <- ci.f$lower
+ upper.fixed <- ci.f$upper
+
+ res <- list(TE.fixed = TE.fixed, seTE.fixed = seTE.fixed,
+ lower.fixed = lower.fixed, upper.fixed = upper.fixed,
+ zval.fixed = zval.fixed, pval.fixed = pval.fixed)
+ }
+
+ if(comb.random){
+
+ meta2 <- my_rma.uni2(as.numeric(TE), sei=as.numeric(seTE), method=method.tau)
+
+ pval <- meta2$pval
+ beta <- as.vector(meta2$beta)
+ se <- meta2$se
+ ci.lower <- meta2$ci.lb
+ ci.upper <- meta2$ci.ub
+ zval <- meta2$zval
+
+ res <- list(TE.random = beta, seTE.random = se,
+ lower.random = ci.lower, upper.random = ci.upper,
+ zval.random = zval, pval.random = pval)
+ }
+ return(res)
+}
+
+my.TE.seTE.ci <- function(lower, upper, level = 0.95,
+ df = rep(NA, length(lower))) {
+
+ varTE <- ifelse(is.na(df),
+ ((upper - lower) /
+ (2 * qnorm((1 - level) / 2, lower.tail = FALSE)))^2,
+ ((upper - lower) /
+ (2 * qt((1 - level) / 2, df = df, lower.tail = FALSE)))^2)
+
+ seTE <- sqrt(varTE)
+
+ res <- list(TE = lower + (upper - lower) / 2, seTE = seTE,
+ lower = lower, upper = upper,
+ level = level, df = df)
+
+ res
+}
+
+my_ci <- function(TE, seTE, level = 0.95, null.effect = 0) {
+
+ alpha <- 1 - level
+
+ lower <- TE - qnorm(1 - alpha / 2) * seTE
+ upper <- TE + qnorm(1 - alpha / 2) * seTE
+ zscore <- (TE - null.effect) / seTE
+ pval <- 2 * pnorm(abs(zscore), lower.tail = FALSE)
+ df <- NA
+
+ list(TE = TE, seTE = seTE,
+ lower = lower, upper = upper,
+ z = zscore, p = pval, level = level)
+}
+
+my_rma.uni2 <- function(yi, vi, sei, ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, m1i, m2i, sd1i, sd2i, xi, mi, ri, ti, sdi, r2i, ni, mods, #scale,
+ measure="GEN", intercept=TRUE,
+ data, slab, subset,
+ add=1/2, to="only0", drop00=FALSE, vtype="LS",
+ method="REML", weighted=TRUE, test="z", #knha=FALSE,
+ level=95, digits, btt, tau2, verbose=FALSE, control, ...) {
+
+ tau2 <- NULL
+ control <- list()
+ Z <- NULL
+
+ digits <- c(est=4, se=4, test=4, pval=4, ci=4, var=4, sevar=4, fit=4, het=4)
+ mf <- match.call()
+
+ ### for certain measures, set add=0 by default unless user explicitly sets the add argument
+
+ addval <- mf[[match("add", names(mf))]]
+
+ ### extract yi (either NULL if not specified, a vector, a formula, or an escalc object)
+
+ mf.yi <- mf[[match("yi", names(mf))]]
+ data <- sys.frame(sys.parent())
+ yi <- eval(mf.yi, data, enclos=sys.frame(sys.parent())) ### NULL if user does not specify this
+ data <- yi
+ scale <- mods <- subset <- slab <- NULL ### NULL if user does not specify this
+ ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- NA
+
+ if (!is.null(yi)) {
+
+ yi.escalc <- FALSE
+
+ ### number of outcomes before subsetting
+
+ k <- length(yi)
+ k.all <- k
+ attr(yi, "measure") <- measure
+
+ ### extract ni argument
+ ni <- NULL ### NULL if user does not specify this
+ vi <- sei^2
+
+ ### check if user constrained vi to 0
+
+ if (length(vi) == 1L && vi == 0) {
+ vi0 <- TRUE
+ } else {
+ vi0 <- FALSE
+ }
+
+ ### allow easy setting of vi to a single value
+
+ if (length(vi) == 1L)
+ vi <- rep(vi, k) ### note: k is number of outcomes before subsetting
+ }
+
+ model <- "rma.uni"
+
+ ### study ids (1:k sequence before subsetting)
+
+ ids <- seq_len(k)
+
+ if (is.null(slab)) {
+ slab.null <- TRUE
+ slab <- ids
+ }
+
+ ### add slab attribute back
+
+ attr(yi, "slab") <- slab
+
+ ### number of outcomes after subsetting
+
+ k <- length(yi)
+
+ ### check for non-positive sampling variances (and set negative values to 0)
+
+ if (any(vi <= 0, na.rm=TRUE)) {
+ allvipos <- FALSE
+ vi.neg <- vi < 0
+ } else {
+ allvipos <- TRUE
+ }
+
+ ai.f <- ai
+ bi.f <- bi
+ ci.f <- ci
+ di.f <- di
+ x1i.f <- x1i
+ x2i.f <- x2i
+ t1i.f <- t1i
+ t2i.f <- t2i
+ yi.f <- yi
+ vi.f <- vi
+ ni.f <- ni
+ mods.f <- mods
+ Z.f <- Z
+
+ k.f <- k ### total number of observed outcomes including all NAs
+
+ if (k == 1) {
+ method <- "FE"
+ test <- "z"
+ }
+
+ ### add vector of 1s to the X matrix for the intercept (if intercept=TRUE)
+
+ X <- cbind(intrcpt=rep(1,k), mods)
+ X.f <- cbind(intrcpt=rep(1,k.f), mods.f)
+
+ ### drop redundant predictors
+ ### note: need to save coef.na for functions that modify the data/model and then refit the model (regtest() and the
+ ### various function that leave out an observation); so we can check if there are redundant/dropped predictors then
+ tmp <- lm(yi ~ X - 1)
+ coef.na <- is.na(coef(tmp))
+ if (any(coef.na)) {
+ X <- X[,!coef.na,drop=FALSE]
+ X.f <- X.f[,!coef.na,drop=FALSE]
+ }
+
+ ### check whether intercept is included and if yes, move it to the first column (NAs already removed, so na.rm=TRUE for any() not necessary)
+ is.int <- apply(X, 2, .is.intercept)
+ if (any(is.int)) {
+ int.incl <- TRUE
+ int.indx <- which(is.int, arr.ind=TRUE)
+ X <- cbind(intrcpt=1, X[,-int.indx, drop=FALSE]) ### this removes any duplicate intercepts
+ X.f <- cbind(intrcpt=1, X.f[,-int.indx, drop=FALSE]) ### this removes any duplicate intercepts
+ intercept <- TRUE ### set intercept appropriately so that the predict() function works
+ } else {
+ int.incl <- FALSE
+ }
+
+ p <- NCOL(X) ### number of columns in X (including the intercept if it is included)
+
+ ### check whether this is an intercept-only model
+
+ if ((p == 1L) && .is.intercept(X)) {
+ int.only <- TRUE
+ } else {
+ int.only <- FALSE
+ }
+
+ btt <- .set.btt(btt, p, int.incl, X)
+ m <- length(btt)
+
+ #########################################################################
+ ### set default control parameters
+
+ con <- list(verbose = FALSE,
+ tau2.init = NULL, # initial value for iterative estimators (ML, REML, EB, SJ, SJIT, DLIT)
+ tau2.min = 0, # lower bound for tau^2 value
+ tau2.max = 100, # upper bound for tau^2 value (for PM/PMM/GENQM estimators; and passed down for tau^2 CI obtained with confint())
+ threshold = 10^-5, # convergence threshold (for ML, REML, EB, SJIT, DLIT)
+ tol = .Machine$double.eps^0.25, # convergence tolerance for uniroot() as used for PM, PMM, and GENQM (also used in 'll0 - ll > con$tol' check for ML/REML)
+ ll0check = TRUE, # should the 'll0 - ll > con$tol' check be conducted for ML/REML?
+ maxiter = 100, # maximum number of iterations (for ML, REML, EB, SJIT, DLIT)
+ stepadj = 1, # step size adjustment for Fisher scoring algorithm (for ML, REML, EB)
+ REMLf = TRUE, # should |X'X| term be included in the REML log likelihood?
+ evtol = 1e-07, # lower bound for eigenvalues to determine if model matrix is positive definite (also for checking if vimaxmin >= 1/con$evtol)
+ alpha.init = NULL, # initial values for scale parameters
+ optimizer = "nlminb", # optimizer to use ("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "ucminf", "optimParallel") for location-scale model
+ optmethod = "BFGS", # argument 'method' for optim() ("Nelder-Mead" and "BFGS" are sensible options)
+ parallel = list(), # parallel argument for optimParallel() (note: 'cl' argument in parallel is not passed; this is directly specified via 'cl')
+ cl = NULL, # arguments for optimParallel()
+ ncpus = 1L, # arguments for optimParallel()
+ hessianCtrl=list(r=8), # arguments passed on to 'method.args' of hessian()
+ scaleZ = TRUE)
+
+ ### replace defaults with any user-defined values
+
+ con.pos <- pmatch(names(control), names(con))
+ con[c(na.omit(con.pos))] <- control[!is.na(con.pos)]
+
+ ### contrain negative tau2.min values to -min(vi) (to ensure that the marginal variance is always >= 0)
+
+ if (con$tau2.min < 0 && (-con$tau2.min > min(vi))) {
+ con$tau2.min <- -min(vi)
+ }
+
+ ### convergence indicator and change variable (for iterative estimators)
+ conv <- 1
+ change <- con$threshold + 1
+
+ ### iterations counter for iterative estimators (i.e., DLIT, SJIT, ML, REML, EB)
+ ### (note: PM, PMM, and GENQM are also iterative, but uniroot() handles that)
+ iter <- 0
+ se.tau2 <- I2 <- H2 <- QE <- QEp <- NA
+ s2w <- 1
+ level <- ifelse(level == 0, 1, ifelse(level >= 1, (100-level)/100, ifelse(level > .5, 1-level, level)))
+ Y <- as.matrix(yi)
+
+ #########################################################################
+ ###### heterogeneity estimation for standard model (rma.uni)
+
+ if (model == "rma.uni") {
+
+ tau2.fix <- FALSE
+ tau2.val <- NA
+
+ ### Hunter & Schmidt (HS) estimator
+
+ if (method == "HS") {
+
+ if (!allvipos)
+ stop("HS estimator cannot be used when there are non-positive sampling variances in the data.")
+
+ wi <- 1/vi
+ W <- diag(wi, nrow=k, ncol=k)
+ stXWX <- .invcalc(X=X, W=W, k=k)
+ P <- W - W %*% X %*% stXWX %*% crossprod(X,W)
+ RSS <- crossprod(Y,P) %*% Y
+ tau2 <- ifelse(tau2.fix, tau2.val, (RSS-k)/sum(wi))
+ }
+
+ ### Hedges (HE) estimator (or initial value for ML, REML, EB)
+
+ if (is.element(method, c("HE","ML","REML","EB"))) {
+
+ stXX <- .invcalc(X=X, W=diag(k), k=k)
+ P <- diag(k) - X %*% tcrossprod(stXX,X)
+ RSS <- crossprod(Y,P) %*% Y
+ V <- diag(vi, nrow=k, ncol=k)
+ PV <- P %*% V ### note: this is not symmetric
+ trPV <- .tr(PV) ### since PV needs to be computed anyway, can use .tr()
+ tau2 <- ifelse(tau2.fix, tau2.val, (RSS - trPV) / (k-p))
+ }
+
+ ### DerSimonian-Laird (DL) estimator
+
+ if (method == "DL") {
+
+ if (!allvipos)
+ stop("DL estimator cannot be used when there are non-positive sampling variances in the data.")
+
+ wi <- 1/vi
+ W <- diag(wi, nrow=k, ncol=k)
+ stXWX <- .invcalc(X=X, W=W, k=k)
+ P <- W - W %*% X %*% stXWX %*% crossprod(X,W)
+ RSS <- crossprod(Y,P) %*% Y
+ trP <- .tr(P)
+ tau2 <- ifelse(tau2.fix, tau2.val, (RSS - (k-p)) / trP)
+ }
+
+ ### DerSimonian-Laird (DL) estimator with iteration
+
+ if (method == "DLIT") {
+
+ if (is.null(con$tau2.init)) {
+ tau2 <- 0
+ } else {
+ tau2 <- con$tau2.init
+ }
+
+ while (change > con$threshold) {
+ iter <- iter + 1
+ old2 <- tau2
+ wi <- 1/(vi + tau2)
+ if (any(tau2 + vi < 0))
+ stop("Some marginal variances are negative.")
+ if (any(is.infinite(wi)))
+ stop("Division by zero when computing the inverse variance weights.")
+ W <- diag(wi, nrow=k, ncol=k)
+ stXWX <- .invcalc(X=X, W=W, k=k)
+ P <- W - W %*% X %*% stXWX %*% crossprod(X,W)
+ RSS <- crossprod(Y,P) %*% Y
+ trP <- .tr(P)
+ tau2 <- ifelse(tau2.fix, tau2.val, (RSS - (k-p)) / trP)
+ tau2[tau2 < con$tau2.min] <- con$tau2.min
+ change <- abs(old2 - tau2)
+
+ if (iter > con$maxiter) {
+ conv <- 0
+ break
+ }
+ }
+ if (conv == 0L)
+ stop("Algorithm did not converge.")
+ }
+
+ ### Sidik-Jonkman (SJ) estimator
+
+ if (method == "SJ") {
+
+ if (is.null(con$tau2.init)) {
+ tau2.0 <- c(var(yi) * (k-1)/k)
+ } else {
+ tau2.0 <- con$tau2.init
+ }
+
+ wi <- 1/(vi + tau2.0)
+ W <- diag(wi, nrow=k, ncol=k)
+ stXWX <- .invcalc(X=X, W=W, k=k)
+ P <- W - W %*% X %*% stXWX %*% crossprod(X,W)
+ RSS <- crossprod(Y,P) %*% Y
+ V <- diag(vi, nrow=k, ncol=k)
+ PV <- P %*% V ### note: this is not symmetric
+ tau2 <- ifelse(tau2.fix, tau2.val, tau2.0 * RSS / (k-p))
+ }
+
+ ### Sidik-Jonkman (SJ) estimator with iteration
+
+ if (method == "SJIT") {
+
+ if (is.null(con$tau2.init)) {
+ tau2 <- var(yi) * (k-1)/k
+ } else {
+ tau2 <- con$tau2.init
+ }
+
+ tau2.0 <- tau2
+
+ while (change > con$threshold) {
+
+ iter <- iter + 1
+ old2 <- tau2
+
+ wi <- 1/(vi + tau2)
+ W <- diag(wi, nrow=k, ncol=k)
+ stXWX <- .invcalc(X=X, W=W, k=k)
+ P <- W - W %*% X %*% stXWX %*% crossprod(X,W)
+ RSS <- crossprod(Y,P) %*% Y
+ V <- diag(vi, nrow=k, ncol=k)
+ PV <- P %*% V ### note: this is not symmetric
+ tau2 <- ifelse(tau2.fix, tau2.val, tau2 * RSS / (k-p))
+ change <- abs(old2 - tau2)
+
+ if (iter > con$maxiter) {
+ conv <- 0
+ break
+ }
+
+ }
+
+ if (conv == 0L)
+ stop("Algorithm did not converge.")
+ }
+
+ ### Paule-Mandel (PM) estimator
+
+ if (method == "PM") {
+
+ if (!allvipos)
+ stop("PM estimator cannot be used when there are non-positive sampling variances in the data.")
+
+ if (!tau2.fix) {
+
+ if (.QE.func(con$tau2.min, Y=Y, vi=vi, X=X, k=k, objective=0) < k-p) {
+ tau2 <- con$tau2.min
+ } else {
+ if (.QE.func(con$tau2.max, Y=Y, vi=vi, X=X, k=k, objective=0) > k-p) {
+ stop("Value of 'tau2.max' too low. Try increasing 'tau2.max' or switch to another 'method'.")
+ } else {
+ tau2 <- try(uniroot(.QE.func, interval=c(con$tau2.min, con$tau2.max), tol=con$tol, maxiter=con$maxiter, Y=Y, vi=vi, X=X, k=k, objective=k-p, verbose=verbose, digits=digits, extendInt="no")$root, silent=TRUE)
+ if (inherits(tau2, "try-error"))
+ stop("Error in iterative search for tau2 using uniroot().")
+ }
+ }
+ } else {
+ tau2 <- tau2.val
+ }
+ wi <- 1/(vi + tau2)
+ }
+
+ ### Paule-Mandel (PM) estimator (median unbiased version)
+
+ if (method == "PMM") {
+
+ if (!allvipos)
+ stop("PMM estimator cannot be used when there are non-positive sampling variances in the data.")
+
+ if (!tau2.fix) {
+ if (.QE.func(con$tau2.min, Y=Y, vi=vi, X=X, k=k, objective=0) < qchisq(0.5, df=k-p)) {
+ tau2 <- con$tau2.min
+ } else {
+ if (.QE.func(con$tau2.max, Y=Y, vi=vi, X=X, k=k, objective=0) > qchisq(0.5, df=k-p)) {
+ stop("Value of 'tau2.max' too low. Try increasing 'tau2.max' or switch to another 'method'.")
+ } else {
+ tau2 <- try(uniroot(.QE.func, interval=c(con$tau2.min, con$tau2.max), tol=con$tol, maxiter=con$maxiter, Y=Y, vi=vi, X=X, k=k, objective=qchisq(0.5, df=k-p), verbose=verbose, digits=digits, extendInt="no")$root, silent=TRUE)
+ if (inherits(tau2, "try-error"))
+ stop("Error in iterative search for tau2. Try increasing 'tau2.max' or switch to another 'method'.")
+ }
+ }
+ } else {
+ tau2 <- tau2.val
+ }
+ wi <- 1/(vi + tau2)
+ }
+
+ ### maximum-likelihood (ML), restricted maximum-likelihood (REML), and empirical Bayes (EB) estimators
+
+ if (is.element(method, c("ML","REML","EB"))) {
+
+ tau2 <- max(0, tau2, con$tau2.min)
+
+ while (change > con$threshold) {
+
+ iter <- iter + 1
+ old2 <- tau2
+ wi <- 1/(vi + tau2)
+ if (any(tau2 + vi < 0))
+ stop("Some marginal variances are negative.")
+ if (any(is.infinite(wi)))
+ stop("Division by zero when computing the inverse variance weights.")
+ W <- diag(wi, nrow=k, ncol=k)
+ stXWX <- .invcalc(X=X, W=W, k=k)
+ P <- W - W %*% X %*% stXWX %*% crossprod(X,W)
+
+ if (method == "ML") {
+ PP <- P %*% P
+ adj <- (crossprod(Y,PP) %*% Y - sum(wi)) / sum(wi^2)
+ }
+ if (method == "REML") {
+ PP <- P %*% P
+ adj <- (crossprod(Y,PP) %*% Y - .tr(P)) / .tr(PP)
+ }
+ if (method == "EB") {
+ adj <- (crossprod(Y,P) %*% Y * k/(k-p) - k) / sum(wi)
+ }
+
+ adj <- adj * con$stepadj ### apply (user-defined) step adjustment
+
+ while (tau2 + adj < con$tau2.min) ### use step-halving if necessary
+ adj <- adj / 2
+
+ tau2 <- ifelse(tau2.fix, tau2.val, tau2 + adj)
+ change <- abs(old2 - tau2)
+
+ if (iter > con$maxiter) {
+ conv <- 0
+ break
+ }
+ }
+
+ if (conv == 0L)
+ stop("Fisher scoring algorithm did not converge. See 'help(rma)' for possible remedies.")
+
+ ### check if ll is larger when tau^2 = 0 (only if ll0check=TRUE and only possible/sensible if allvipos and !tau2.fix)
+ ### note: this doesn't catch the case where tau^2 = 0 is a local maximum
+
+ if (is.element(method, c("ML","REML")) && con$ll0check && allvipos && !tau2.fix) {
+
+ wi <- 1/vi
+ W <- diag(wi, nrow=k, ncol=k)
+ stXWX <- .invcalc(X=X, W=W, k=k)
+ beta <- stXWX %*% crossprod(X,W) %*% Y
+ RSS <- sum(wi*(yi - X %*% beta)^2)
+ if (method == "ML")
+ ll0 <- -1/2 * (k) * log(2*base::pi) - 1/2 * sum(log(vi)) - 1/2 * RSS
+ if (method == "REML")
+ ll0 <- -1/2 * (k-p) * log(2*base::pi) - 1/2 * sum(log(vi)) - 1/2 * determinant(crossprod(X,W) %*% X, logarithm=TRUE)$modulus - 1/2 * RSS
+
+ wi <- 1/(vi + tau2)
+ if (any(tau2 + vi < 0))
+ stop("Some marginal variances are negative.")
+ if (any(is.infinite(wi)))
+ stop("Division by zero when computing the inverse variance weights.")
+ W <- diag(wi, nrow=k, ncol=k)
+ stXWX <- .invcalc(X=X, W=W, k=k)
+ beta <- stXWX %*% crossprod(X,W) %*% Y
+ RSS <- sum(wi*(yi - X %*% beta)^2)
+ if (method == "ML")
+ ll <- -1/2 * (k) * log(2*base::pi) - 1/2 * sum(log(vi + tau2)) - 1/2 * RSS
+ if (method == "REML")
+ ll <- -1/2 * (k-p) * log(2*base::pi) - 1/2 * sum(log(vi + tau2)) - 1/2 * determinant(crossprod(X,W) %*% X, logarithm=TRUE)$modulus - 1/2 * RSS
+
+ if (ll0 - ll > con$tol && tau2 > con$threshold) {
+ tau2 <- 0
+ }
+ }
+
+ ### need to run this so that wi and P are based on the final tau^2 value
+
+ wi <- 1/(vi + tau2)
+ if (any(tau2 + vi < 0))
+ stop("Some marginal variances are negative.")
+ if (any(is.infinite(wi)))
+ stop("Division by zero when computing the inverse variance weights.")
+ W <- diag(wi, nrow=k, ncol=k)
+ stXWX <- .invcalc(X=X, W=W, k=k)
+ P <- W - W %*% X %*% stXWX %*% crossprod(X,W)
+
+ }
+
+ ### make sure that tau2 is >= con$tau2.min
+ tau2 <- max(con$tau2.min, c(tau2))
+
+ ### check if any marginal variances are negative (only possible if user has changed tau2.min)
+
+ if (!is.na(tau2) && any(tau2 + vi < 0))
+ stop("Some marginal variances are negative.")
+
+ if (method == "HS")
+ se.tau2 <- sqrt(1/sum(wi)^2 * (2*(k-p) + 4*max(tau2,0)*.tr(P) + 2*max(tau2,0)^2*sum(P*P))) ### note: wi = 1/vi
+ if (method == "HE")
+ se.tau2 <- sqrt(1/(k-p)^2 * (2*sum(PV*t(PV)) + 4*max(tau2,0)*trPV + 2*max(tau2,0)^2*(k-p)))
+ if (method == "DL" || method == "DLIT")
+ se.tau2 <- sqrt(1/trP^2 * (2*(k-p) + 4*max(tau2,0)*trP + 2*max(tau2,0)^2*sum(P*P)))
+ if (method == "GENQ" || method == "GENQM")
+ se.tau2 <- sqrt(1/trP^2 * (2*sum(PV*t(PV)) + 4*max(tau2,0)*sum(PV*P) + 2*max(tau2,0)^2*sum(P*P)))
+ if (method == "SJ")
+ se.tau2 <- sqrt(tau2.0^2/(k-p)^2 * (2*sum(PV*t(PV)) + 4*max(tau2,0)*sum(PV*P) + 2*max(tau2,0)^2*sum(P*P)))
+ if (method == "ML")
+ se.tau2 <- sqrt(2/sum(wi^2)) ### note: wi = 1/(vi + tau2) for ML, REML, EB, PM, and SJIT
+ if (method == "REML")
+ se.tau2 <- sqrt(2/sum(P*P))
+ if (method == "EB" || method == "PM" || method == "PMM" || method == "SJIT") {
+ se.tau2 <- sqrt(2*k^2/(k-p) / sum(wi)^2) ### these two equations are actually identical, but this one is much simpler
+ }
+
+ }
+
+ ### fixed-effects model (note: set tau2 to zero even when tau2 is specified)
+
+ if (method == "FE")
+ tau2 <- 0
+
+ ###### model fitting, test statistics, and confidence intervals
+
+ wi <- 1/(vi + tau2)
+ W <- diag(wi, nrow=k, ncol=k)
+ M <- diag(vi + tau2, nrow=k, ncol=k)
+
+ stXX <- .invcalc(X=X, W=diag(k), k=k)
+ beta <- stXX %*% crossprod(X,Y)
+ vb <- tcrossprod(stXX,X) %*% M %*% X %*% stXX
+ RSS.f <- sum(wi*(yi - X %*% beta)^2)
+
+ ### calculate scaling factor for Knapp & Hartung method
+
+ if (is.element(test, c("knha","adhoc"))) {
+
+ if (any(is.infinite(wi)))
+ stop("Division by zero when computing the inverse variance weights.")
+
+ stXWX <- .invcalc(X=X, W=W, k=k)
+ beta.knha <- stXWX %*% crossprod(X,W) %*% Y
+ RSS.knha <- sum(wi*(yi - X %*% beta.knha)^2)
+ #P <- W - W %*% X %*% stXWX %*% crossprod(X,W)
+ #RSS.knha <- c(crossprod(Y,P) %*% Y)
+
+ if (RSS.knha <= .Machine$double.eps) {
+ s2w <- 0
+ } else {
+ s2w <- RSS.knha / (k-p)
+ }
+
+ }
+
+ ### Knapp & Hartung method with ad-hoc correction so that the scale factor is always >= 1
+
+ if (test == "adhoc")
+ s2w[s2w < 1] <- 1
+
+ ### for Knapp & Hartung method, apply scaling to vb
+
+ vb <- s2w * vb
+
+ ### QM calculation
+
+ QM <- try(as.vector(t(beta)[btt] %*% chol2inv(chol(vb[btt,btt])) %*% beta[btt]), silent=TRUE)
+
+ if (inherits(QM, "try-error"))
+ QM <- NA
+
+ se <- sqrt(diag(vb))
+ names(se) <- NULL
+ zval <- c(beta/se)
+
+ if (is.element(test, c("knha","adhoc","t"))) {
+ dfs <- k-p
+ QM <- QM / m
+ if (dfs > 0) {
+ QMp <- pf(QM, df1=m, df2=dfs, lower.tail=FALSE)
+ pval <- 2*pt(abs(zval), df=dfs, lower.tail=FALSE)
+ crit <- qt(level/2, df=dfs, lower.tail=FALSE)
+ } else {
+ QMp <- NaN
+ pval <- NaN
+ crit <- NaN
+ }
+ } else {
+ dfs <- NA
+ QMp <- pchisq(QM, df=m, lower.tail=FALSE)
+ pval <- 2*pnorm(abs(zval), lower.tail=FALSE)
+ crit <- qnorm(level/2, lower.tail=FALSE)
+ }
+
+ ci.lb <- c(beta - crit * se)
+ ci.ub <- c(beta + crit * se)
+
+ res <- list(b=beta, beta=beta, se=se, zval=zval, pval=pval, ci.lb=ci.lb, ci.ub=ci.ub)
+
+ class(res) <- c("rma.uni", "rma")
+ return(res)
+}
+
+.is.intercept <- function(x, eps=1e-08)
+ return(all(abs(x - 1) < eps))
+
+.invcalc <- function(X, W, k) {
+ sWX <- sqrt(W) %*% X
+ res.qrs <- qr.solve(sWX, diag(k))
+ return(tcrossprod(res.qrs))
+}
+
+.tr <- function(X)
+ return(sum(diag(X)))
+
+.QE.func <- function(tau2val, Y, vi, X, k, objective, verbose=FALSE, digits=4) {
+ W <- diag(1/(vi + tau2val), nrow=k, ncol=k)
+ stXWX <- .invcalc(X=X, W=W, k=k)
+ P <- W - W %*% X %*% stXWX %*% crossprod(X,W)
+ RSS <- crossprod(Y,P) %*% Y
+ return(RSS - objective)
+}
+
+.set.btt <- function(btt, p, int.incl, X) {
+ if (p > 1) { ### if the model matrix has more than one column
+ if (int.incl) {
+ btt <- seq.int(from=2, to=p) ### and the model has an intercept term, test all coefficients except the intercept
+ } else {
+ btt <- seq_len(p) ### and the model does not have an intercept term, test all coefficients
+ }
+ } else {
+ btt <- 1 ### if the model matrix has a single column, test that single coefficient
+ }
+ return(btt)
+}
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/networks_data.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/networks_data.R
new file mode 100755
index 0000000000000000000000000000000000000000..f957f0fbbac708982f738df40cf166b310da7430
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/networks_data.R
@@ -0,0 +1,994 @@
+#'Exports Gene-Mapping result into a table
+#'@param mSetObj Input name of the created mSet Object
+#'@export
+GetNetworkGeneMappingResultTable<-function(mSetObj=NA){
+ load_rsqlite()
+ mSetObj <- .get.mSet(mSetObj);
+
+ qvec <- mSetObj$dataSet$gene;
+ enIDs <- mSetObj$dataSet$gene.name.map$hit.values;
+
+ match.state<-mSetObj$dataSet$gene.name.map$match.state;
+ # Map enIDs to KEGG orthologs
+ # TO-DO: run function for specific species
+ if(length(qvec) > 0){
+ if(mSetObj$dataSet$q.type.gene == "kos"){
+ # Gene2KOMapping already done in PerformIntegGeneMapping in enrich_integ.R
+ hit.kos <- mSetObj$dataSet$kos.name.map
+ } else{
+ hit.kos <- doGene2KONameMapping(enIDs)
+ }
+ match.state[is.na(hit.kos) & match.state!=0] <- 2
+ match.state[!is.na(hit.kos) & match.state==0] <- 2
+ } else{
+ mSetObj$dataSet$q.type.gene = ""
+ hit.kos = NULL
+ }
+
+ # style for highlighted background for unmatched names
+ pre.style<-NULL;
+ post.style<-NULL;
+
+ # style for no matches
+ if(mSetObj$dataSet$q.type.gene == "name"){
+ no.prestyle<-"<strong style=\"background-color:yellow; font-size=125%; color=\"black\">";
+ no.poststyle<-"</strong>";
+ } else{
+ nokos.prestyle<-"<strong style=\"background-color:lightgrey; font-size=125%; color=\"black\">";
+ nokos.poststyle<-"</strong>";
+ no.prestyle<-"<strong style=\"background-color:red; font-size=125%; color=\"black\">";
+ no.poststyle<-"</strong>";
+ }
+
+ # contruct the result table with cells wrapped in html tags
+ # the unmatched will be highlighted in different background
+ html.res<-matrix("", nrow=length(qvec), ncol=6);
+ csv.res<-matrix("", nrow=length(qvec), ncol=6);
+ colnames(csv.res)<-c("Query", "Entrez", "Symbol", "KO", "Name", "Comment");
+
+ org.code <- mSetObj$org;
+ sqlite.path <- paste0(url.pre, org.code, "_genes.sqlite");
+ con <- .get.sqlite.con(sqlite.path); ;
+ gene.db <- dbReadTable(con, "entrez")
+
+ hit.inx <- match(enIDs, gene.db[, "gene_id"]);
+ hit.values<-mSetObj$dataSet$gene.name.map$hit.values;
+ mSetObj$dataSet$gene.name.map$hit.inx <- hit.inx;
+ mSetObj$dataSet$gene.name.map$hit.kos <- hit.kos;
+ hit.kos[is.na(hit.kos)] <- "";
+
+ if(length(qvec) > 0){
+ for (i in 1:length(qvec)){
+ if(match.state[i]==1){
+ pre.style<-"";
+ post.style="";
+ }else if(match.state[i]==2){
+ pre.style<-nokos.prestyle;
+ post.style<-nokos.poststyle;
+ }else{ # no matches
+ pre.style<-no.prestyle;
+ post.style<-no.poststyle;
+ }
+ hit <-gene.db[hit.inx[i], ,drop=F];
+
+ html.res[i, ]<-c(paste(pre.style, qvec[i], post.style, sep=""),
+ paste(ifelse(match.state[i]==0 || is.na(hit$gene_id),"-", paste("<a href=http://www.ncbi.nlm.nih.gov/gene/", hit$gene_id, " target='_blank'>",hit$gene_id,"</a>", sep="")), sep=""),
+ paste(ifelse(match.state[i]==0 || is.na(hit$symbol), "-", paste("<a href=http://www.ncbi.nlm.nih.gov/gene/", hit$gene_id, " target='_blank'>", hit$symbol,"</a>", sep="")), sep=""),
+ paste(ifelse(is.na(hit.kos[i]), "-", paste("<a href=http://www.ncbi.nlm.nih.gov/gene/", hit$gene_id, " target='_blank'>", hit.kos[i],"</a>", sep="")), sep=""),
+ paste(ifelse(match.state[i]==0 || is.na(hit$name),"-", paste("<a href=http://www.ncbi.nlm.nih.gov/gene/", hit$gene_id, " target='_blank'>",hit$name,"</a>", sep="")), sep=""),
+ ifelse(match.state[i]!=1,"View",""));
+ csv.res[i, ]<-c(qvec[i],
+ ifelse(match.state[i]==0, "NA", hit$gene_id),
+ ifelse(match.state[i]==0, "NA", hit$symbol),
+ ifelse(is.na(hit.kos[i]), "NA", hit.kos[i]),
+ ifelse(match.state[i]==0, "NA", hit$name),
+ match.state[i]);
+ }
+ }
+
+ # store the value for report
+ mSetObj$dataSet$gene.map.table <- csv.res;
+
+ fast.write.csv(csv.res, file="gene_name_map.csv", row.names=F);
+ dbDisconnect(con);
+
+ if(.on.public.web){
+ .set.mSet(mSetObj)
+ return(as.vector(html.res));
+ }else{
+ return(.set.mSet(mSetObj));
+ }
+}
+
+#'Prepare data for network exploration
+#'@description Function for the network explorer module, prepares user's data for network exploration.
+#'@param mSetObj Input name of the created mSet Object
+#'@export
+PrepareNetworkData <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # prepare gene list
+ if(!is.null(mSetObj$dataSet$gene.mat)){
+ gene.mat <- mSetObj$dataSet$gene.mat;
+ enIDs <- mSetObj$dataSet$gene.name.map$hit.values;
+ kos <- mSetObj$dataSet$gene.name.map$hit.kos;
+ rownames(gene.mat) <- enIDs;
+
+ na.inx <- is.na(kos);
+ gene.mat.clean <- gene.mat[!na.inx, ,drop=F];
+ kos.clean <- kos[!na.inx]
+
+ gene.names <- rownames(gene.mat.clean)
+ gene.mat.clean <- RemoveDuplicates(gene.mat.clean);
+ if(nrow(gene.mat.clean) < length(kos.clean)){
+ mSetObj$dataSet$gene.name.map$hit.kos <- kos.clean[!duplicated(gene.names)]
+ } else{
+ mSetObj$dataSet$gene.name.map$hit.kos <- kos.clean
+ }
+ AddMsg(paste("A total of ", nrow(gene.mat.clean), "unique genes were uploaded."));
+
+ if(!exists("pathinteg.imps", where = mSetObj$dataSet)){
+ mSetObj$dataSet$pathinteg.imps <- list();
+ }
+ mSetObj$dataSet$pathinteg.imps$gene.mat <- gene.mat.clean;
+ done <- 1;
+ }
+
+ # prepare kos list
+ if(!is.null(mSetObj$dataSet$gene.mat)){
+ # Handle case when upload type is KOs
+ if(mSetObj$dataSet$q.type.gene == "kos"){
+ rownames(gene.mat) <- kos
+ gene.mat <- RemoveDuplicates(gene.mat);
+ mSetObj$dataSet$gene.name.map$hit.kos <- rownames(gene.mat)
+ AddMsg(paste("A total of ", nrow(gene.mat), "unique KOs were uploaded."));
+
+ if(!exists("pathinteg.imps", where = mSetObj$dataSet)){
+ mSetObj$dataSet$pathinteg.imps <- list();
+ }
+ mSetObj$dataSet$pathinteg.imps$kos.mat <- gene.mat;
+ done <- 1;
+ } else{
+ mSetObj$dataSet$pathinteg.imps$kos.mat <- mSetObj$dataSet$pathinteg.imps$gene.mat;
+ }
+ }
+
+ # prepare compound list
+ if((!is.null(mSetObj$dataSet$cmpd.mat) || (!is.null(mSetObj$dataSet$cmpd)))){
+ nm.map <- GetFinalNameMap(mSetObj);
+ nm.map$kegg <- ifelse(is.na(nm.map$kegg), paste("unmapped", rownames(nm.map), sep = "_"), nm.map$kegg); #also accept unmapped cmpd
+ valid.inx <- !(is.na(nm.map$kegg)| duplicated(nm.map$kegg));
+ cmpd.vec <- nm.map$query[valid.inx];
+ kegg.id <- nm.map$kegg[valid.inx];
+
+ cmpd.mat <- mSetObj$dataSet$cmpd.mat;
+ if(is.null(mSetObj$dataSet$cmpd.mat)){
+ cmpd <- as.matrix(mSetObj$dataSet$cmpd); # when the input is concentration table
+ cmpd.mat <- cbind(cmpd, rep("0", nrow(cmpd)))
+ }
+ hit.inx <- match(cmpd.vec, rownames(cmpd.mat));
+
+ cmpd.mat <- cmpd.mat[hit.inx, ,drop=F];
+ rownames(cmpd.mat) <- kegg.id;
+ cmpd.mat <- RemoveDuplicates(cmpd.mat);
+ AddMsg(paste("A total of ", nrow(cmpd.mat), "unique compounds were found."));
+ mSetObj$dataSet$pathinteg.imps$cmpd.mat <- cmpd.mat;
+ done <- 1;
+ }
+
+ if(.on.public.web){
+ .set.mSet(mSetObj);
+ return(done);
+ }
+ return(.set.mSet(mSetObj));
+}
+
+#'Prepare user's query for mapping KEGG Global Metabolic Network
+#'@description This function prepares the user's data for the
+#'KEGG Global Metabolic Network
+#'@param mSetObj Input name of the created mSet Object
+#'@author Othman Soufan, Jeff Xia \email{jeff.xia@mcgill.ca}, {othman.soufan@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+PrepareQueryJson <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # Map query matched KOs with the KO database
+ kos <- mSetObj$dataSet$gene.name.map$hit.kos
+ expr.mat <- mSetObj$dataSet$pathinteg.imps$kos.mat
+ kos <- cbind(kos, expr.mat)
+ # Retreive compounds information
+ cmpds.expr <- mSetObj$dataSet$pathinteg.imps$cmpd.mat
+ cmpds <- cbind(rownames(cmpds.expr), cmpds.expr)
+
+ enrich.type <- "hyper";
+
+ # Perform gene enrichment
+ gene.mat <- list()
+ if(length(kos) > 0){
+ dataSet.gene <- PerformMapping(kos, "ko")
+ if(length(dataSet.gene)==0){
+ return(0);
+ }
+
+ if(enrich.type == "hyper"){
+ exp.vec <- dataSet.gene$data[,1]; # drop dim for json
+ }else{
+ # for global test, all KO measured should be highlighted
+ genemat <- as.data.frame(t(otu_table(dataSet.gene$norm.phyobj)));
+ exp.vec <- rep(2, ncol(genemat));
+ names(exp.vec) <- colnames(genemat);
+ }
+ gene.mat <- MapKO2KEGGEdges(exp.vec);
+ }
+
+ # Perform compound enrichment
+ cmpd.mat <- list()
+ if(length(cmpds) > 1){
+ dataSet.cmpd <- PerformMapping(cmpds, "cmpd")
+ if(length(dataSet.cmpd)==0){
+ return(0);
+ }
+
+ if(enrich.type == "hyper"){
+ exp.vec <- dataSet.cmpd$data[,1]; # drop dim for json
+ }else{
+ # for global test, all KO measured should be highlighted
+ genemat <- as.data.frame(t(otu_table(dataSet.cmpd$norm.phyobj)));
+ exp.vec <- rep(2, ncol(genemat));
+ names(exp.vec) <- colnames(genemat);
+ }
+ cmpd.mat <- MapCmpd2KEGGNodes(exp.vec);
+ }
+
+ # TO-DO: Refactor the following part of code for better readability
+ if(length(cmpd.mat) != 0 && length(gene.mat) != 0){
+ edge.mat <- as.data.frame(rbind(as.matrix(cmpd.mat), as.matrix(gene.mat)));
+ dataSet <<- MergeDatasets(dataSet.cmpd, dataSet.gene);
+ idtype <<- "gene&cmpd";
+ } else if(length(cmpd.mat) != 0){
+ edge.mat <- cmpd.mat;
+ dataSet <<- dataSet.cmpd;
+ idtype <<- "cmpd";
+ } else{
+ edge.mat <- gene.mat;
+ dataSet <<- dataSet.gene;
+ idtype <<- "gene";
+ }
+
+ row.names(edge.mat) <- eids <- rownames(edge.mat);
+ query.ko <- edge.mat[,1];
+ net.orig <- edge.mat[,2];
+ query.res <- edge.mat[,3];# abundance
+ names(query.res) <- eids; # named by edge
+
+ json.mat <- RJSONIO::toJSON(query.res, .na='null');
+ sink("network_query.json");
+ cat(json.mat);
+ sink();
+
+ return(.set.mSet(mSetObj));
+
+}
+
+PrepareQueryJsonOld <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # Map query matched KOs with the KO database
+ kos <- mSetObj$dataSet$gene.name.map$hit.kos
+ expr.mat <- mSetObj$dataSet$pathinteg.imps$kos.mat
+ kos <- cbind(kos, expr.mat)
+ # Retreive compounds information
+ cmpds.expr <- mSetObj$dataSet$pathinteg.imps$cmpd.mat
+ cmpds <- cbind(rownames(cmpds.expr), cmpds.expr)
+
+ enrich.type <- "hyper";
+
+ # Perform gene enrichment
+ gene.mat <- list()
+ if(length(kos) > 0){
+ dataSet.gene <- PerformMapping(kos, "ko")
+ if(length(dataSet.gene)==0){
+ return(0);
+ }
+
+ if(enrich.type == "hyper"){
+ exp.vec <- dataSet.gene$data[,1]; # drop dim for json
+ }else{
+ # for global test, all KO measured should be highlighted
+ genemat <- as.data.frame(t(otu_table(dataSet.gene$norm.phyobj)));
+ exp.vec <- rep(2, ncol(genemat));
+ names(exp.vec) <- colnames(genemat);
+ }
+ gene.mat <- MapKO2KEGGEdgesOld(exp.vec);
+ }
+
+ # Perform compound enrichment
+ cmpd.mat <- list()
+ if(length(cmpds) > 1){
+ dataSet.cmpd <- PerformMapping(cmpds, "cmpd")
+ if(length(dataSet.cmpd)==0){
+ return(0);
+ }
+
+ if(enrich.type == "hyper"){
+ exp.vec <- dataSet.cmpd$data[,1]; # drop dim for json
+ }else{
+ # for global test, all KO measured should be highlighted
+ genemat <- as.data.frame(t(otu_table(dataSet.cmpd$norm.phyobj)));
+ exp.vec <- rep(2, ncol(genemat));
+ names(exp.vec) <- colnames(genemat);
+ }
+ cmpd.mat <- MapCmpd2KEGGNodesOld(exp.vec);
+ }
+
+ # TO-DO: Refactor the following part of code for better readability
+ if(length(cmpd.mat) != 0 && length(gene.mat) != 0){
+ edge.mat <- as.data.frame(rbind(as.matrix(cmpd.mat), as.matrix(gene.mat)));
+ dataSet <<- MergeDatasets(dataSet.cmpd, dataSet.gene);
+ idtype <<- "gene&cmpd";
+ } else if(length(cmpd.mat) != 0){
+ edge.mat <- cmpd.mat;
+ dataSet <<- dataSet.cmpd;
+ idtype <<- "cmpd";
+ } else{
+ edge.mat <- gene.mat;
+ dataSet <<- dataSet.gene;
+ idtype <<- "gene";
+ }
+
+ row.names(edge.mat) <- eids <- rownames(edge.mat);
+ query.ko <- edge.mat[,1];
+ net.orig <- edge.mat[,2];
+ query.res <- edge.mat[,3];# abundance
+ names(query.res) <- eids; # named by edge
+
+ json.mat <- RJSONIO::toJSON(query.res, .na='null');
+ sink("network_query.json");
+ cat(json.mat);
+ sink();
+
+ return(.set.mSet(mSetObj));
+
+}
+
+
+# Utility function for PrepareNetworkData
+doGene2KONameMapping <- function(enIDs){
+
+ if(.on.public.web){
+ ko.dic <- .readDataTable("../../libs/network/ko_dic_new.csv");
+ }else{
+ ko.dic <- .readDataTable("https://www.metaboanalyst.ca/resources/libs/network/ko_dic_new.csv");
+ }
+
+ #TO-DO: map based on specific selection of a species
+ ko.dic.enIDs <- as.integer(ko.dic[, "Entrez_hsa"])
+ ko.dic.enIDs[is.na(ko.dic.enIDs)] <- -1
+ hit.inx <- match(as.integer(enIDs), ko.dic.enIDs);
+ kos <- ko.dic[hit.inx, "KO"];
+
+ # if not gene symbol, use id by itself
+ na.inx <- is.na(kos);
+ kos[na.inx] <- NA #enIDs[na.inx];
+
+ return(kos);
+}
+
+# Utility function for Save2KEGGJSON
+MatchQueryOnKEGGMap <- function(query, ko.map){
+ hits <- lapply(query,
+ function(x) {
+ as.character(unique(ko.map$edge[ko.map$queryid%in%unlist(x)]));
+ }
+ );
+
+ return(hits)
+}
+
+# Utility function for PerformKOEnrichAnalysis_List
+# for KO01100
+Save2KEGGJSON <- function(hits.query, res.mat, file.nm, hits.all){
+ resTable <- data.frame(Pathway=rownames(res.mat), res.mat);
+ AddMsg("Functional enrichment analysis was completed");
+
+ if(!exists("ko.edge.map")){
+
+ if(.on.public.web){
+ ko.edge.path <- paste("../../libs/network/ko_edge.csv", sep="");
+ ko.edge.map <- .readDataTable(ko.edge.path);
+ }else{
+ ko.edge.path <- paste("https://www.metaboanalyst.ca/resources/libs/network/ko_edge.csv", sep="");
+ download.file(ko.edge.path, destfile = "ko_edge.csv", method="libcurl", mode = "wb")
+ ko.edge.map <- .readDataTable("ko_edge.csv");
+ }
+ ko.edge.map <- ko.edge.map[ko.edge.map$net=="ko01100",]; #only one map
+ ko.edge.map <<- ko.edge.map;
+ }
+
+ hits.edge <- list();
+ hits.node <- list();
+ hits.edge.all <- list();
+ hits.node.all <- list();
+
+ if(idtype == "gene"){
+ ko.map <- ko.edge.map;
+ colnames(ko.map) <- c("queryid", "edge", "net")
+ hits.edge <- MatchQueryOnKEGGMap(hits.query, ko.map)
+ hits.inx <- unlist(lapply(hits.edge, length))>0;
+
+ #find matches for all queries without applying pathway filtering
+ hits.edge.all <- MatchQueryOnKEGGMap(hits.all, ko.map)
+ hits.inx.all <- unlist(lapply(hits.edge.all, length))>0;
+
+ }else if(idtype == "cmpd"){
+ ko.map <- ko.node.map.global;
+ colnames(ko.map) <- c("queryid", "edge", "net")
+ hits.node <- MatchQueryOnKEGGMap(hits.query, ko.map)
+ hits.inx <- unlist(lapply(hits.node, length))>0;
+
+ #find matches for all queries without applying pathway filtering
+ hits.node.all <- MatchQueryOnKEGGMap(hits.all, ko.map)
+ hits.inx.all <- unlist(lapply(hits.node.all, length))>0;
+ }else{
+ # gene&cmpd
+ ko.map1 <- ko.edge.map;
+ colnames(ko.map1) <- c("queryid", "edge", "net"); rownames(ko.map1)<-NULL;
+ hits.edge <- MatchQueryOnKEGGMap(hits.query, ko.map1)
+ #find matches for all queries without applying pathway filtering
+ hits.edge.all <- MatchQueryOnKEGGMap(hits.all, ko.map1)
+
+ ko.map2 <- ko.node.map.global;
+ colnames(ko.map2) <- c("queryid", "edge", "net"); rownames(ko.map2)<-NULL;
+ hits.node <- MatchQueryOnKEGGMap(hits.query, ko.map2)
+ #find matches for all queries without applying pathway filtering
+ hits.node.all <- MatchQueryOnKEGGMap(hits.all, ko.map2)
+
+ ko.map <- rbind(ko.map1, ko.map2)
+ # TO-DO: combine results hits.edge and hits.node without applying again lapply over hits.query
+ hits.both <- MatchQueryOnKEGGMap(hits.query, ko.map)
+ hits.inx <- unlist(lapply(hits.both, length))>0;
+
+ #find matches for all queries without applying pathway filtering
+ hits.both <- MatchQueryOnKEGGMap(hits.all, ko.map)
+ hits.inx.all <- unlist(lapply(hits.both, length))>0;
+ }
+
+ # only keep hits with edges in the map
+ hits.query <- hits.query[hits.inx]; hits.all <- hits.all[hits.inx.all];
+ resTable <- resTable[hits.inx, ];
+
+ # write json
+ fun.pval = resTable$Pval; if(length(fun.pval) ==1) { fun.pval <- matrix(fun.pval) };
+ hit.num = resTable$Hits; if(length(hit.num) ==1) { hit.num <- matrix(hit.num) };
+ fun.ids <- as.vector(current.setids[names(hits.query)]); if(length(fun.ids) ==1) { fun.ids <- matrix(fun.ids) };
+
+ #clean non-metabolic pathways
+ rm.ids <- which(is.na(fun.ids))
+ if(length(rm.ids) != 0){
+ fun.ids <- fun.ids[-rm.ids]
+ fun.pval <- fun.pval[-rm.ids]
+ hit.num <- hit.num[-rm.ids]
+ hits.query <- hits.query[-rm.ids]
+ }
+
+ expr = as.list(dataSet$data)
+ names(expr) <- rownames(dataSet$data)
+ json.res <- list(
+ expr.mat = expr,
+ hits.query = hits.query,
+ hits.edge = hits.edge,
+ hits.node = hits.node,
+ hits.all = hits.all,
+ hits.edge.all = hits.edge.all,
+ hits.node.all = hits.node.all,
+ path.id = fun.ids,
+ fun.pval = fun.pval,
+ hit.num = hit.num
+ );
+ json.mat <- RJSONIO::toJSON(json.res, .na='null');
+ json.nm <- paste(file.nm, ".json", sep="");
+ sink(json.nm)
+ cat(json.mat);
+ sink();
+
+ # write csv
+ fun.hits <<- hits.query;
+ fun.pval <<- resTable[,5];
+ hit.num <<- resTable[,4];
+ csv.nm <- paste(file.nm, ".csv", sep="");
+ fast.write.csv(resTable, file=csv.nm, row.names=F);
+}
+
+Save2KEGGJSONOld <- function(hits.query, res.mat, file.nm, hits.all){
+ resTable <- data.frame(Pathway=rownames(res.mat), res.mat);
+ AddMsg("Functional enrichment analysis was completed");
+
+ if(!exists("ko.edge.map")){
+
+ if(.on.public.web){
+ ko.edge.path <- paste("../../libs/network/old/ko_edge.csv", sep="");
+ ko.edge.map <- .readDataTable(ko.edge.path);
+ }else{
+ ko.edge.path <- paste("https://www.metaboanalyst.ca/resources/libs/network/old/ko_edge.csv", sep="");
+ download.file(ko.edge.path, destfile = "ko_edge.csv", method="libcurl", mode = "wb")
+ ko.edge.map <- .readDataTable("ko_edge.csv");
+ }
+ ko.edge.map <- ko.edge.map[ko.edge.map$net=="ko01100",]; #only one map
+ ko.edge.map <<- ko.edge.map;
+ }
+
+ hits.edge <- list();
+ hits.node <- list();
+ hits.edge.all <- list();
+ hits.node.all <- list();
+
+ if(idtype == "gene"){
+ ko.map <- ko.edge.map;
+ colnames(ko.map) <- c("queryid", "edge", "net")
+ hits.edge <- MatchQueryOnKEGGMap(hits.query, ko.map)
+ hits.inx <- unlist(lapply(hits.edge, length))>0;
+
+ #find matches for all queries without applying pathway filtering
+ hits.edge.all <- MatchQueryOnKEGGMap(hits.all, ko.map)
+ hits.inx.all <- unlist(lapply(hits.edge.all, length))>0;
+
+ }else if(idtype == "cmpd"){
+ ko.map <- ko.node.map.global;
+ colnames(ko.map) <- c("queryid", "edge", "net")
+ hits.node <- MatchQueryOnKEGGMap(hits.query, ko.map)
+ hits.inx <- unlist(lapply(hits.node, length))>0;
+
+ #find matches for all queries without applying pathway filtering
+ hits.node.all <- MatchQueryOnKEGGMap(hits.all, ko.map)
+ hits.inx.all <- unlist(lapply(hits.node.all, length))>0;
+ }else{
+ # gene&cmpd
+ ko.map1 <- ko.edge.map;
+ colnames(ko.map1) <- c("queryid", "edge", "net"); rownames(ko.map1)<-NULL;
+ hits.edge <- MatchQueryOnKEGGMap(hits.query, ko.map1)
+ #find matches for all queries without applying pathway filtering
+ hits.edge.all <- MatchQueryOnKEGGMap(hits.all, ko.map1)
+
+ ko.map2 <- ko.node.map.global;
+ colnames(ko.map2) <- c("queryid", "edge", "net"); rownames(ko.map2)<-NULL;
+ hits.node <- MatchQueryOnKEGGMap(hits.query, ko.map2)
+ #find matches for all queries without applying pathway filtering
+ hits.node.all <- MatchQueryOnKEGGMap(hits.all, ko.map2)
+
+ ko.map <- rbind(ko.map1, ko.map2)
+ # TO-DO: combine results hits.edge and hits.node without applying again lapply over hits.query
+ hits.both <- MatchQueryOnKEGGMap(hits.query, ko.map)
+ hits.inx <- unlist(lapply(hits.both, length))>0;
+
+ #find matches for all queries without applying pathway filtering
+ hits.both <- MatchQueryOnKEGGMap(hits.all, ko.map)
+ hits.inx.all <- unlist(lapply(hits.both, length))>0;
+ }
+
+ # only keep hits with edges in the map
+ hits.query <- hits.query[hits.inx]; hits.all <- hits.all[hits.inx.all];
+ resTable <- resTable[hits.inx, ];
+
+ # write json
+ fun.pval = resTable$Pval; if(length(fun.pval) ==1) { fun.pval <- matrix(fun.pval) };
+ hit.num = resTable$Hits; if(length(hit.num) ==1) { hit.num <- matrix(hit.num) };
+ fun.ids <- as.vector(current.setids[names(hits.query)]); if(length(fun.ids) ==1) { fun.ids <- matrix(fun.ids) };
+
+ #clean non-metabolic pathways
+ rm.ids <- which(is.na(fun.ids))
+ if(length(rm.ids) != 0){
+ fun.ids <- fun.ids[-rm.ids]
+ fun.pval <- fun.pval[-rm.ids]
+ hit.num <- hit.num[-rm.ids]
+ hits.query <- hits.query[-rm.ids]
+ }
+
+ expr = as.list(dataSet$data)
+ names(expr) <- rownames(dataSet$data)
+ json.res <- list(
+ expr.mat = expr,
+ hits.query = hits.query,
+ hits.edge = hits.edge,
+ hits.node = hits.node,
+ hits.all = hits.all,
+ hits.edge.all = hits.edge.all,
+ hits.node.all = hits.node.all,
+ path.id = fun.ids,
+ fun.pval = fun.pval,
+ hit.num = hit.num
+ );
+ json.mat <- RJSONIO::toJSON(json.res, .na='null');
+ json.nm <- paste(file.nm, ".json", sep="");
+ sink(json.nm)
+ cat(json.mat);
+ sink();
+
+ # write csv
+ fun.hits <<- hits.query;
+ fun.pval <<- resTable[,5];
+ hit.num <<- resTable[,4];
+ csv.nm <- paste(file.nm, ".csv", sep="");
+ fast.write.csv(resTable, file=csv.nm, row.names=F);
+}
+
+#'Utility function for PerformKOEnrichAnalysis_KO01100
+#'@param category Module or pathway
+LoadKEGGKO_lib<-function(category){
+
+ if(category == "module"){
+ kegg.anot <- .get.my.lib("ko_modules.qs", "network");
+ current.setlink <- kegg.anot$link;
+ current.mset <- kegg.anot$sets$"Pathway module";
+ }else{
+ kegg.anot <- .get.my.lib("ko_pathways.qs", "network");
+ current.setlink <- kegg.anot$link;
+ current.mset <- kegg.anot$sets$Metabolism;
+ }
+ # now need to update the msets to contain only those in ko01100 map
+ if(!exists("ko.edge.map")){
+ if(.on.public.web){
+ ko.edge.path <- paste("../../libs/network/ko_edge.csv", sep="");
+ ko.edge.map <<- .readDataTable(ko.edge.path);
+ }else{
+ ko.edge.path <- paste("https://www.metaboanalyst.ca/resources/libs/network/ko_edge.csv", sep="");
+ download.file(ko.edge.path, destfile = "ko_edge.csv", method="libcurl", mode = "wb")
+ ko.edge.map <<- .readDataTable("ko_edge.csv");
+ }
+ }
+
+ kos.01100 <- ko.edge.map$gene[ko.edge.map$net == "ko01100"];
+ current.mset <- lapply(current.mset,
+ function(x) {
+ as.character(unique(x[x %in% kos.01100]));
+ }
+ );
+ # remove those empty ones
+ mset.ln <- lapply(current.mset, length);
+ current.mset <- current.mset[mset.ln > 0];
+ set.ids<- names(current.mset);
+ names(set.ids) <- names(current.mset) <- kegg.anot$term[set.ids];
+
+ current.setlink <<- current.setlink;
+ current.setids <<- set.ids;
+ current.geneset <<- current.mset;
+}
+
+LoadKEGGKO_libOld<-function(category){
+
+ if(category == "module"){
+ kegg.anot <- .get.my.lib("ko_modules.qs", "network");
+ current.setlink <- kegg.anot$link;
+ current.mset <- kegg.anot$sets$"Pathway module";
+ }else{
+ kegg.anot <- .get.my.lib("ko_pathways.qs", "network");
+ current.setlink <- kegg.anot$link;
+ current.mset <- kegg.anot$sets$Metabolism;
+ }
+ # now need to update the msets to contain only those in ko01100 map
+ if(!exists("ko.edge.map")){
+ if(.on.public.web){
+ ko.edge.path <- paste("../../libs/network/old/ko_edge.csv", sep="");
+ ko.edge.map <<- .readDataTable(ko.edge.path);
+ }else{
+ ko.edge.path <- paste("https://www.metaboanalyst.ca/resources/libs/network/old/ko_edge.csv", sep="");
+ download.file(ko.edge.path, destfile = "ko_edge.csv", method="libcurl", mode = "wb")
+ ko.edge.map <<- .readDataTable("ko_edge.csv");
+ }
+ }
+
+ kos.01100 <- ko.edge.map$gene[ko.edge.map$net == "ko01100"];
+ current.mset <- lapply(current.mset,
+ function(x) {
+ as.character(unique(x[x %in% kos.01100]));
+ }
+ );
+ # remove those empty ones
+ mset.ln <- lapply(current.mset, length);
+ current.mset <- current.mset[mset.ln > 0];
+ set.ids<- names(current.mset);
+ names(set.ids) <- names(current.mset) <- kegg.anot$term[set.ids];
+
+ current.setlink <<- current.setlink;
+ current.setids <<- set.ids;
+ current.geneset <<- current.mset;
+}
+
+# Utility function for SearchNetDB
+.preparePhenoListSeeds <- function(mSetObj, table.nm){
+
+ if(.on.public.web){
+ libs.path <<- "../../libs/";
+ }else{
+ libs.path <<- "https://www.metaboanalyst.ca/resources/libs/";
+ }
+
+ table.nm <<- table.nm;
+ # Preparing dataset variables
+ mSetObj <- .get.mSet(mSetObj);
+ # Retreive compounds information
+ cmpds <- rownames(mSetObj$dataSet$pathinteg.imps$cmpd.mat);
+ seed.compounds <- cmpds;
+ seed.expr.compounds <- as.vector(mSetObj$dataSet$pathinteg.imps$cmpd.mat[,1]);
+
+ # Retreive genes information
+ genes <- rownames(mSetObj$dataSet$pathinteg.imps$gene.mat);
+ # Prepare gene seeds for the graph when user upload no genes
+ if(length(genes) == 0){
+ seed.genes <- c();
+ seed.expr.genes <- c();
+ } else {
+ seed.genes <- genes;
+ seed.expr.genes <- as.vector(mSetObj$dataSet$pathinteg.imps$gene.mat[,1]);
+ }
+
+ # Change default seeds information (i.e. genes) to chemicals if needed
+ if((table.nm == "metabo_phenotypes") || (table.nm == "metabo_metabolites")){
+ seed.graph <<- seed.compounds;
+ seed.expr <<- seed.expr.compounds;
+ } else {
+ seed.graph <<- c(seed.compounds, seed.genes);
+ seed.expr <<- c(seed.expr.compounds, seed.expr.genes);
+ }
+
+ list(
+ genes = genes,
+ cmpds = cmpds
+ );
+}
+
+#'Utility function
+#'@description Returns matched KO in the same order (NA if no match)
+#'@param ko.vec Input the vector containing KOs
+#'@param type Input the type
+doKOFiltering <- function(ko.vec, type){
+ if(.on.public.web){
+ ko.dic <- .readDataTable("../../libs/network/ko_dic_new.csv");
+ }else{
+ ko.dic <- .readDataTable("https://www.metaboanalyst.ca/resources/libs/network/ko_dic_new.csv");
+ }
+ hit.inx <- match(ko.vec, ko.dic$KO);
+ return(ko.dic$KO[hit.inx]);
+}
+
+#'Utility function for PrepareQueryJson
+#'@param kos Input the KOs
+#'@param net Input the name of the network
+MapKO2KEGGEdges<- function(kos, net="ko01100"){
+ if(!exists("ko.edge.map")){
+ if(.on.public.web){
+ ko.edge.path <- paste("../../libs/network/ko_edge.csv", sep="");
+ ko.edge.map <<- .readDataTable(ko.edge.path);
+ }else{
+ ko.edge.path <- paste("https://www.metaboanalyst.ca/resources/libs/network/ko_edge.csv", sep="");
+ ko.edge.map <<- .readDataTable(ko.edge.path);
+ }
+ }
+ all.hits <- ko.edge.map$gene %in% names(kos) & ko.edge.map$net == net;
+ my.map <- ko.edge.map[all.hits, ];
+ q.map <- data.frame(gene=names(kos), expr=as.numeric(kos));
+
+ # first merge to get ko abundance to each edge
+ dat <- merge(my.map, q.map, by="gene");
+
+ # now merge duplicated edge to sum
+ dup.inx <- duplicated(dat[,2]);
+ dat <- dat[!dup.inx,];
+ rownames(dat) <- dat[,2];
+
+ return(dat[,-2]);
+}
+
+MapKO2KEGGEdgesOld<- function(kos, net="ko01100"){
+ if(!exists("ko.edge.map")){
+ if(.on.public.web){
+ ko.edge.path <- paste("../../libs/network/old/ko_edge.csv", sep="");
+ ko.edge.map <<- .readDataTable(ko.edge.path);
+ }else{
+ ko.edge.path <- paste("https://www.metaboanalyst.ca/resources/libs/network/old/ko_edge.csv", sep="");
+ ko.edge.map <<- .readDataTable(ko.edge.path);
+ }
+ }
+ all.hits <- ko.edge.map$gene %in% names(kos) & ko.edge.map$net == net;
+ my.map <- ko.edge.map[all.hits, ];
+ q.map <- data.frame(gene=names(kos), expr=as.numeric(kos));
+
+ # first merge to get ko abundance to each edge
+ dat <- merge(my.map, q.map, by="gene");
+
+ # now merge duplicated edge to sum
+ dup.inx <- duplicated(dat[,2]);
+ dat <- dat[!dup.inx,];
+ rownames(dat) <- dat[,2];
+
+ return(dat[,-2]);
+}
+
+#'Utility function for PrepareQueryJson
+#'@param cmpds Input the compounds
+#'@param net Input the network name
+MapCmpd2KEGGNodes <- function(cmpds, net="ko01100"){
+
+ lib <- "hsa_kegg.qs" # TO-DO: change for other species
+ if(!exists("ko.node.map.global")){
+ # Read original library files for a list of pathways with assigned compounds to each
+
+ if(.on.public.web){
+ pathway.lib <- qs::qread(paste("../../libs/mummichog/", lib, sep=""));
+ }else{
+ if(!file.exists(lib)){
+ path.url <- paste("https://www.metaboanalyst.ca/resources/libs/mummichog/", lib, sep="")
+ download.file(path.url, destfile = lib, method="libcurl", mode = "wb")
+ pathway.lib <- qs::qread(lib);
+ }else{
+ pathway.lib <- qs::qread(lib);
+ }
+ }
+
+ pathways <- pathway.lib$pathways;
+
+ # Store universe for enrichment analysis
+ names(pathways$cpds) <- pathways$name
+ current.cmpd.set <<- pathways$cpds;
+
+ # Read pathway names and ids in the target pathway map (e.g. ko01100)
+
+ if(.on.public.web){
+ ko.pathway.names <- .readDataTable(paste("../../libs/network/ko01100_compounds_ids.csv", sep=""));
+ }else{
+ ko.pathway.names <- .readDataTable(paste("https://www.metaboanalyst.ca/resources/libs/network/ko01100_compounds_ids.csv", sep=""));
+ }
+
+ #ko.node.map <- do.call(rbind, lapply(1:length(pathways$name), function(i) cbind(unlist(pathways$cpds[i]), pathways$name[i])));
+ #ko.node.matches <- ko.pathway.names[match(ko.node.map[,2], ko.pathway.names$name),2]
+ # Replace pathway names with ids
+ #ko.node.map[,2] <- ko.node.matches
+ # Clean missing cases
+ #ko.node.map <- ko.node.map[!is.na(ko.node.matches),]
+ #ko.node.map.global <<- data.frame(cmpd = ko.node.map[,1], edge = ko.node.map[,2], net = rep("ko01100", nrow(ko.node.map)))
+ ko.node.map.global <<- data.frame(cmpd = ko.pathway.names[,1], edge = ko.pathway.names[,2], net = rep("ko01100", nrow(ko.pathway.names)))
+ }
+
+ all.hits <- ko.node.map.global$cmpd %in% names(cmpds) & ko.node.map.global$net == net;
+ my.map <- ko.node.map.global[all.hits, ];
+ q.map <- data.frame(cmpd=names(cmpds), expr=as.numeric(cmpds));
+
+ # first merge to get cmpd abundance to each edge
+ dat <- merge(my.map, q.map, by="cmpd");
+
+ # now merge duplicated edge to sum
+ dup.inx <- duplicated(dat[,2]);
+ dat <- dat[!dup.inx,];
+ rownames(dat) <- dat[,2];
+
+ return(dat[,-2]);
+}
+
+MapCmpd2KEGGNodesOld <- function(cmpds, net="ko01100"){
+
+ lib <- "hsa_kegg.qs" # TO-DO: change for other species
+ if(!exists("ko.node.map.global")){
+ # Read original library files for a list of pathways with assigned compounds to each
+
+ if(.on.public.web){
+ pathway.lib <- qs::qread(paste("../../libs/mummichog/", lib, sep=""));
+ }else{
+ if(!file.exists(lib)){
+ path.url <- paste("https://www.metaboanalyst.ca/resources/libs/mummichog/", lib, sep="")
+ download.file(path.url, destfile = lib, method="libcurl", mode = "wb")
+ pathway.lib <- qs::qread(lib);
+ }else{
+ pathway.lib <- qs::qread(lib);
+ }
+ }
+
+ pathways <- pathway.lib$pathways;
+
+ # Store universe for enrichment analysis
+ names(pathways$cpds) <- pathways$name
+ current.cmpd.set <<- pathways$cpds;
+
+ # Read pathway names and ids in the target pathway map (e.g. ko01100)
+
+ if(.on.public.web){
+ ko.pathway.names <- .readDataTable(paste("../../libs/network/old/ko01100_compounds_ids.csv", sep=""));
+ }else{
+ ko.pathway.names <- .readDataTable(paste("https://www.metaboanalyst.ca/resources/libs/network/old/ko01100_compounds_ids.csv", sep=""));
+ }
+
+ #ko.node.map <- do.call(rbind, lapply(1:length(pathways$name), function(i) cbind(unlist(pathways$cpds[i]), pathways$name[i])));
+ #ko.node.matches <- ko.pathway.names[match(ko.node.map[,2], ko.pathway.names$name),2]
+ # Replace pathway names with ids
+ #ko.node.map[,2] <- ko.node.matches
+ # Clean missing cases
+ #ko.node.map <- ko.node.map[!is.na(ko.node.matches),]
+ #ko.node.map.global <<- data.frame(cmpd = ko.node.map[,1], edge = ko.node.map[,2], net = rep("ko01100", nrow(ko.node.map)))
+ ko.node.map.global <<- data.frame(cmpd = ko.pathway.names[,1], edge = ko.pathway.names[,2], net = rep("ko01100", nrow(ko.pathway.names)))
+ }
+
+ all.hits <- ko.node.map.global$cmpd %in% names(cmpds) & ko.node.map.global$net == net;
+ my.map <- ko.node.map.global[all.hits, ];
+ q.map <- data.frame(cmpd=names(cmpds), expr=as.numeric(cmpds));
+
+ # first merge to get cmpd abundance to each edge
+ dat <- merge(my.map, q.map, by="cmpd");
+
+ # now merge duplicated edge to sum
+ dup.inx <- duplicated(dat[,2]);
+ dat <- dat[!dup.inx,];
+ rownames(dat) <- dat[,2];
+
+ return(dat[,-2]);
+}
+
+#'Utility function for PrepareQueryJson
+#'geneIDs is text one string, need to make to vector
+#'@param inputIDs Input list of IDs
+#'@param type Input the type of IDs
+PerformMapping <- function(inputIDs, type){
+
+ dataSet <- list();
+ dataSet$orig <- inputIDs;
+
+ data.mat <- as.matrix(inputIDs);
+
+ if(dim(data.mat)[2] == 1){ # add 1
+ data.only <- 1; # if only a list of ids are provided with abundance or confidence scores
+ data.mat <- cbind(data.mat, rep(1, nrow(data.mat)));
+ }else {
+ data.only <- 0;
+ data.mat <- data.mat[,1:2];
+ }
+
+ # Hanlde case when only 1 id is provided
+ if(!is.matrix(data.mat)){
+ data.mat <- as.matrix(t(data.mat))
+ }
+
+ rownames(data.mat) <- data.mat[,1];
+ data.mat <- data.mat[,-1, drop=F];
+ dataSet$id.orig <- data.mat;
+ dataSet$data.only <- data.only;
+ data.mat <- RemoveDuplicates(data.mat, "sum", quiet=F);
+ dataSet$id.uniq <- data.mat;
+
+ # now get input that are in the lib
+ if(type == "ko"){
+ kos <- doKOFiltering(rownames(data.mat), type);
+ if(sum(!is.na(kos)) < 2){
+ AddErrMsg("Less than two hits found in the database. ");
+ dataSet <- list();
+ return(dataSet);
+ }
+ rownames(data.mat) <- kos;
+ gd.inx <- (!is.na(kos)) & data.mat[,1] > -Inf; # TO-DO: change -Inf to specific value based on type of uploaded scores
+ data.mat <- data.mat[gd.inx, ,drop=F];
+
+ AddMsg(paste("A total of unqiue", nrow(data.mat), "KO genes were mapped to KEGG network!"));
+ }
+ # TO-DO: check if there is a need to do compound filtering here (e.g. doKeggCmpdFiltering)
+
+ dataSet$id.mapped <- dataSet$data <- data.mat;
+
+ return(dataSet);
+}
+
+#'Utility function for PrepareQueryJson
+#'@param dataSet1 Input the first dataset
+#'@param dataSet2 Input the second dataset
+MergeDatasets <- function(dataSet1, dataSet2){
+
+ dataSet <- list();
+ dataSet$orig <- c(dataSet1$orig, dataSet2$orig);
+ dataSet$id.orig <- rbind(dataSet1$id.orig, dataSet2$id.orig)
+ dataSet$id.uniq <- rbind(dataSet1$id.uniq, dataSet2$id.uniq)
+ dataSet$data <- rbind(dataSet1$data, dataSet2$data)
+ dataSet$id.mapped <- rbind(dataSet1$id.mapped, dataSet2$id.mapped)
+
+ return(dataSet);
+}
+
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/networks_enrich.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/networks_enrich.R
new file mode 100755
index 0000000000000000000000000000000000000000..4779fc54a400099163cb12ad0490f7cf3f2e181d
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/networks_enrich.R
@@ -0,0 +1,557 @@
+
+#'Performs KO enrichment analysis based on the KO01100 map
+#'@description This function performs KO enrichment analysis based on the KO01100 map
+#'and saves the .JSON file
+#'@param mSetObj Input name of the created mSet Object
+#'@param category Input the option to perform enrichment analysis, "pathway"
+#'@param file.nm Input name of file to save
+#'@author Othman Soufan, Jeff Xia \email{jeff.xia@mcgill.ca}, {othman.soufan@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+PerformKOEnrichAnalysis_KO01100 <- function(mSetObj=NA, category, file.nm){
+
+ mSetObj <- .get.mSet(mSetObj);
+ LoadKEGGKO_lib(category);
+ #if(enrich.type == "hyper"){ else PerformKOEnrichAnalysis_Table
+ PerformKOEnrichAnalysis_List(file.nm);
+
+ if(.on.public.web == FALSE){
+ return(.set.mSet(mSetObj));
+ }
+}
+
+#'Perform mapping of user's data to interaction network
+#'@description This function performs mapping of user's data to the internal network
+#' to create a network from the seed nodes
+#'@param mSetObj Input name of the created mSet Object
+#'@param db.type Input the database type
+#'@param table.nm Input the organism code for the sqlite table (ppi). For chemical type, the
+#'table.nm is drugbank of ctd
+#'@param require.exp Logical, only used for the STRING database
+#'@param min.score Input the minimal score, only used for the STRING database
+#'@author Othman Soufan, Jeff Xia \email{jeff.xia@mcgill.ca}, {othman.soufan@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'@import RSQLite
+SearchNetDB <- function(mSetObj=NA, db.type, table.nm, require.exp=TRUE, min.score = 900){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(.on.public.web){
+ load_rsqlite()
+ }
+
+ result.list <- .preparePhenoListSeeds(mSetObj, table.nm);
+ genes <- result.list$genes;
+ protein.vec <- seed.graph;
+ cmpds <- result.list$cmpds;
+
+ network.type <<- table.nm
+
+ # now do the database search
+
+ if(db.type == "pheno"){
+ res <- QueryPhenoSQLite(table.nm, genes, cmpds, min.score);
+ if(nrow(res)==0){ return(c(0,0)); }
+
+ if(table.nm == "gene_metabolites"){
+ src <- "entrez"; src.nm <- "symbol";
+ src.evidence <- "protein"
+ target <- "ctdid"; target.nm <- "name";
+ target.evidence <- "stitch"
+ } else if(table.nm == "metabo_phenotypes"){
+ src <- "ctdid"; src.nm <- "name";
+ target <- "omimid"; target.nm <- "phenoname";
+ evidence <- "pmid"
+ } else if(table.nm == "metabo_metabolites"){
+ src <- "ctdid1"; src.nm <- "name1";
+ src.evidence <- "stitch1"
+ target <- "ctdid2"; target.nm <- "name2";
+ target.evidence <- "stitch2"
+ } else if(table.nm == "gene_phenotypes"){
+ src <- "entrez"; src.nm <- "symbol";
+ target <- "omimid"; target.nm <- "phenoname";
+ } else if(table.nm == "global"){
+ src <- "id1"; src.nm <- "name1";
+ src.evidence <- "evidsrc"
+ target <- "id2"; target.nm <- "name2";
+ target.evidence <- "evidtar"
+ }
+
+ if(table.nm == "metabo_phenotypes"){
+ edge.res <- data.frame(Source=res[,src],Target=res[,target], Evidence=res[,evidence]);
+ } else {
+ edge.res <- data.frame(Source=res[,src],Target=res[,target]);
+ }
+ row.names(edge.res) <- 1:nrow(res);
+ fast.write.csv(edge.res, file="orig_edge_list.csv",row.names=FALSE);
+
+ node.ids <- c(res[,src], res[,target])
+ node.nms <- c(res[,src.nm], res[,target.nm]);
+
+ if(table.nm == "metabo_metabolites" || table.nm == "gene_metabolites" || table.nm == "global"){
+ node.evidence <- c(res[,src.evidence], res[,target.evidence]);
+ } else{
+ node.evidence <- ""
+ }
+ }
+
+ # Retrieve gene full names
+ genes.names.idx <- match(node.ids, mSetObj$dataSet$gene.map.table[,"Entrez"])
+ genes.names <- mSetObj$dataSet$gene.map.table[genes.names.idx,"Name"]
+
+ if(node.evidence != "" && !is.null(genes.names)){
+ # Evidence is related to the STITCH database accessions for chemicals/proteins
+ node.res <- data.frame(Id=node.ids, Label=node.nms, GeneNames=genes.names, Evidence=node.evidence);
+ } else if (node.evidence != "") {
+ node.res <- data.frame(Id=node.ids, Label=node.nms, Evidence=node.evidence);
+ } else if (!is.null(genes.names) ){
+ node.res <- data.frame(Id=node.ids, Label=node.nms, GeneNames=genes.names);
+ } else {
+ node.res <- data.frame(Id=node.ids, Label=node.nms);
+ }
+ node.res <- node.res[!duplicated(node.res$Id),];
+ nodeListu <<- node.res
+ fast.write.csv(node.res, file="orig_node_list.csv", row.names=FALSE);
+
+ pheno.net <<- list(
+ db.type=db.type,
+ order=1,
+ seeds=protein.vec,
+ table.nm=table.nm,
+ node.data = node.res,
+ edge.data = edge.res,
+ require.exp = require.exp,
+ min.score = min.score
+ );
+
+ if(.on.public.web){
+ return(c(nrow(node.res), nrow(res)));
+ }else{
+ return(.set.mSet(mSetObj));
+ }
+}
+
+# Utility function for SearchNetDB
+# table name is org code, id.type is column name
+#'@import RSQLite
+QueryPhenoSQLite <- function(table.nm, genes, cmpds, min.score){
+
+ if(.on.public.web){
+ sqlite.path <- paste0(url.pre, "MetPriCNet.sqlite");
+ pheno.db <- .get.sqlite.con(sqlite.path);
+ }else{
+ download.file("https://www.metaboanalyst.ca/resources/libs/network/MetPriCNet.sqlite", "MetPriCNet.sqlite")
+ pheno.db <- dbConnect(SQLite(), "MetPriCNet.sqlite");
+ }
+
+ if(table.nm == "global"){
+ # Handle gene_metabolites
+ table.nm <- "gene_metabolites";
+ if((length(genes) > 0) && (length(cmpds) > 0)){
+ genes.query <- paste(shQuote(genes),collapse=",");
+ cmpds.query <- paste(shQuote(cmpds),collapse=",");
+ statement <- paste("SELECT * FROM ", table.nm, " WHERE entrez IN (",genes.query,") AND ctdid IN (",cmpds.query,") AND score >= ",min.score, sep="");
+ } else if(length(genes) > 0){
+ genes.query <- paste(shQuote(genes),collapse=",");
+ statement <- paste("SELECT * FROM ", table.nm, " WHERE entrez IN (",genes.query,") AND score >= ",min.score, sep="");
+ } else{
+ cmpds.query <- paste(shQuote(cmpds),collapse=",");
+ statement <- paste("SELECT * FROM ", table.nm, " WHERE ctdid IN (",cmpds.query,") AND score >= ",min.score, sep="");
+ }
+ phenotable <- dbSendQuery(pheno.db, statement);
+ genemetab.res <- fetch(phenotable, n=-1); # get all records
+ genemetab.res <- genemetab.res[,1:6]
+ names(genemetab.res) <- c("id1", "id2", "name1", "name2", "evidsrc", "evidtar")
+
+ # Handle metab_phenotypes
+ table.nm <- "metabo_phenotypes";
+ cmpds.query <- paste(shQuote(cmpds),collapse=",");
+ statement <- paste("SELECT * FROM ", table.nm, " WHERE ctdid IN (",cmpds.query,") AND score >= ",min.score, sep="");
+ phenotable <- dbSendQuery(pheno.db, statement);
+ metabpheno.res <- fetch(phenotable, n=-1); # get all records
+ evidsrc <- genemetab.res[match(metabpheno.res[,1], genemetab.res[,2]), 6]
+ metabpheno.res <- cbind(metabpheno.res[,1:4], evidsrc, metabpheno.res[,7])
+ names(metabpheno.res) <- c("id1", "id2", "name1", "name2", "evidsrc", "evidtar")
+
+ # Handle genes_phenotypes
+ table.nm <- "gene_phenotypes";
+ genes.query <- paste(shQuote(genes),collapse=",");
+ statement <- paste("SELECT * FROM ", table.nm, " WHERE entrez IN (",genes.query,") AND score >= ",min.score, sep="");
+ phenotable <- dbSendQuery(pheno.db, statement);
+ genespheno.res <- fetch(phenotable, n=-1); # get all records
+ genespheno.res <- cbind(genespheno.res[,1:4], rep(NA, nrow(genespheno.res)), rep(NA, nrow(genespheno.res)))
+ names(genespheno.res) <- c("id1", "id2", "name1", "name2", "evidsrc", "evidtar");
+ # Combine all
+ pheno.dic <- rbind(genemetab.res, metabpheno.res, genespheno.res)
+
+ } else{
+ if(table.nm == "gene_metabolites"){
+ if((length(genes) > 0) && (length(cmpds) > 0)){
+ genes.query <- paste(shQuote(genes),collapse=",");
+ cmpds.query <- paste(shQuote(cmpds),collapse=",");
+ statement <- paste("SELECT * FROM ", table.nm, " WHERE entrez IN (",genes.query,") AND ctdid IN (",cmpds.query,") AND score >= ",min.score, sep="");
+ } else if(length(genes) > 0){
+ genes.query <- paste(shQuote(genes),collapse=",");
+ statement <- paste("SELECT * FROM ", table.nm, " WHERE entrez IN (",genes.query,") AND score >= ",min.score, sep="");
+ } else{
+ cmpds.query <- paste(shQuote(cmpds),collapse=",");
+ statement <- paste("SELECT * FROM ", table.nm, " WHERE ctdid IN (",cmpds.query,") AND score >= ",min.score, sep="");
+ }
+ } else if(table.nm == "metabo_phenotypes"){
+ cmpds.query <- paste(shQuote(cmpds),collapse=",");
+ statement <- paste("SELECT * FROM ", table.nm, " WHERE ctdid IN (",cmpds.query,") AND score >= ",min.score, sep="");
+ } else if(table.nm == "metabo_metabolites"){
+ cmpds.query <- paste(shQuote(cmpds),collapse=",");
+ statement <- paste("SELECT * FROM ", table.nm, " WHERE ctdid1 IN (",cmpds.query,") AND score >= ",min.score, sep="");
+ } else if(table.nm == "gene_phenotypes"){
+ genes.query <- paste(shQuote(genes),collapse=",");
+ statement <- paste("SELECT * FROM ", table.nm, " WHERE entrez IN (",genes.query,") AND score >= ",min.score, sep="");
+ }
+
+ phenotable <- dbSendQuery(pheno.db, statement);
+ pheno.dic <- fetch(phenotable, n=-1); # get all records
+
+ }
+ dbDisconnect(pheno.db);
+ return(pheno.dic);
+}
+
+# Perform DSPC network analysis
+#'@import gdata
+#'@import gplots
+#'@import huge
+#'@import ppcor
+#'@import ctc
+PerformDSPC <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ result.list <- .preparePhenoListSeeds(mSetObj, "metabo_metabolites");
+ genes <- result.list$genes;
+ protein.vec <- seed.graph;
+ cmpds <- result.list$cmpds;
+ require(gdata)
+ require(gplots)
+ require(huge)
+ require(ppcor)
+ require(ctc)
+ dat <- mSetObj$dataSet$norm;
+ node.ids <- cmpds;
+ node.nms <- mSetObj$dataSet$orig.var.nms;
+ DGlasso.fit <- DGlasso(dat, alpha=.01, FDR.type='BH');
+ coeff <- DGlasso.fit$coeff;
+ pval <- DGlasso.fit$pvalue;
+ qval <- DGlasso.fit$qvalue;
+ coeff <- signif(coeff, digits = 3);
+ pval <- signif(pval, digits = 3);
+ qval <- signif(qval, digits = 3);
+ res <- GetSourceTarget(node.ids);
+ dspc.res <- cbind(res, coeff, pval, qval);
+
+ node.res <- data.frame(Id=node.ids, Label=node.nms);
+ node.res <- node.res[!duplicated(node.res$Id),];
+ fast.write.csv(node.res, file="orig_node_list.csv", row.names=FALSE);
+
+ edge.res <- data.frame(Source=dspc.res[,"source"],Target=dspc.res[,"target"],Coefficient=dspc.res[,"coeff"],Pval=dspc.res[,"pval"],Adj_Pval=dspc.res[,"qval"]);
+ row.names(edge.res) <- 1:nrow(res);
+ fast.write.csv(edge.res, file="orig_edge_list.csv",row.names=FALSE);
+ nodeListu <<- node.res;
+
+
+ pheno.net <<- list(
+ order=1,
+ seeds=node.ids,
+ table.nm="dspc",
+ node.data = node.res,
+ edge.data = edge.res,
+ require.exp = "TRUE",
+ min.score = 900
+ );
+
+ if(.on.public.web){
+ return(c(nrow(node.res), nrow(res)));
+ }else{
+ return(.set.mSet(mSetObj));
+ }
+
+
+}
+
+# Utility function for PerformDSPC
+#'@import glasso
+DGlasso = function(X, alpha = 0.05, lambda = NULL, FDRctrl = FALSE, FDR.type='bonferroni', quiet=TRUE){
+ require(glasso);
+ n = nrow(X)
+ p = ncol(X)
+
+ if (is.null(lambda)){
+ lambda = sqrt(log(p)/n)
+ }
+
+ Sigma.hat_X = var(X)
+
+ if (!quiet){print('fit glasso')}
+ Theta.hat_glasso = glasso(s=Sigma.hat_X, rho=lambda, penalize.diagonal=FALSE)$wi
+ if (!quiet){print('done')}
+
+ if (!quiet){print('calc kronecker product')}
+ # T.hat = as.vector(Theta.hat_glasso)-kronecker(Theta.hat_glasso,Theta.hat_glasso,"*") %*% as.vector(Sigma.hat_X - chol2inv(chol(Theta.hat_glasso)))
+ # reduce memory consumption from O(n^4) to O(n^2) by avoiding kronecker calculation
+ temp.mat = Sigma.hat_X - chol2inv(chol(Theta.hat_glasso))
+ temp.vec = as.vector(Theta.hat_glasso %*% temp.mat %*% t(Theta.hat_glasso))
+ T.hat = as.vector(Theta.hat_glasso) - temp.vec
+ if (!quiet){print('done')}
+
+ T.hat.vec = upperTriangle(matrix(T.hat,nrow = p),diag=FALSE)
+
+ sigma.hat2 = array(0,c(p,p))
+ for (i in 1:p){
+ for (j in 1:p){
+ sigma.hat2[i,j] = Theta.hat_glasso[i,j]^2+Theta.hat_glasso[i,i]*Theta.hat_glasso[j,j]
+ }
+ }
+ sigma.hat2.vec = upperTriangle(sigma.hat2,diag=FALSE)
+
+ test.stat = sqrt(n)*T.hat.vec/sqrt(sigma.hat2.vec)
+ pvals = 2*(pnorm(abs(test.stat), lower.tail=FALSE))
+ adj.p = p.adjust(pvals, FDR.type)
+
+ return(list(coeff=-pmax(pmin(T.hat.vec, 1), -1), pvalue=pvals, qvalue=adj.p))
+}
+
+# Utility function for PerformDSPC
+#'@param metab.list Input the metabolite list
+GetSourceTarget <- function(metab.list) {
+ source = c()
+ target = c()
+ for (i in 2:length(metab.list)) {
+ for (j in 1:(i - 1)) {
+ source = c(source, metab.list[j])
+ target = c(target, metab.list[i])
+ }
+ }
+ source_target <- data.frame("source" = source,
+ "target" = target)
+ return(source_target)
+}
+
+#'Utility function for PerformKOEnrichAnalysis_KO01100
+#'@description Please note: only return hits in map KO01100
+#'@param file.nm Input the file name
+PerformKOEnrichAnalysis_List <- function(file.nm){
+ if(idtype == "cmpd"){
+ current.set <- current.cmpd.set;
+ } else if(idtype == "gene&cmpd"){
+ matchidx <- match(names(current.cmpd.set), names(current.geneset))
+ current.set <- list()
+ # TO-DO: Fix code to handle case if length(current.cmpd.set) > length(current.geneset).
+ # Then, start loop with current.cmpd.set
+ for(i in c(1:length(current.geneset))){
+ if(i %in% matchidx){
+ cidx <- which(matchidx==i)
+ mergels <- c(current.cmpd.set[cidx][[1]], current.geneset[i][[1]])
+ current.set[[names(current.cmpd.set[cidx])]] <- mergels
+ } else{
+ current.set[[names(current.geneset[i])]] <- current.geneset[i][[1]]
+ }
+ }
+ # Add compound sets that did not match
+ cidx <- which(is.na(matchidx))
+ for(i in c(1:length(cidx))){
+ current.set[[names(current.cmpd.set[cidx[i]])]] <- current.cmpd.set[cidx[i]][[1]]
+ }
+ } else{
+ current.set <- current.geneset;
+
+ }
+ current.universe <- unique(unlist(current.set));
+
+ # prepare for the result table
+ set.size<-length(current.set);
+ res.mat<-matrix(0, nrow=set.size, ncol=5);
+ rownames(res.mat)<-names(current.set);
+ colnames(res.mat)<-c("Total", "Expected", "Hits", "Pval", "FDR");
+
+ # prepare query
+ ora.vec <- NULL;
+ exp.vec <- dataSet$data[,1]; # drop dim for json
+ ora.vec <- names(exp.vec);
+
+ # need to cut to the universe covered by the pathways, not all genes
+ hits.inx <- ora.vec %in% current.universe;
+ ora.vec <- ora.vec[hits.inx];
+ #ora.nms <- ora.nms[hits.inx];
+
+ q.size<-length(ora.vec);
+
+ # get the matched query for each pathway
+ hits.query <- lapply(current.set,
+ function(x) {
+ ora.vec[ora.vec%in%unlist(x)];
+ }
+ );
+ names(hits.query) <- names(current.set);
+
+ hit.num<-unlist(lapply(hits.query, function(x){length(x)}), use.names=FALSE);
+
+ # total unique gene number
+ uniq.count <- length(current.universe);
+
+ # unique gene count in each pathway
+ set.size <- unlist(lapply(current.set, length));
+
+ res.mat[,1]<-set.size;
+ res.mat[,2]<-q.size*(set.size/uniq.count);
+ res.mat[,3]<-hit.num;
+
+ # use lower.tail = F for P(X>x)
+ raw.pvals <- phyper(hit.num-1, set.size, uniq.count-set.size, q.size, lower.tail=F);
+ res.mat[,4]<- raw.pvals;
+ res.mat[,5] <- p.adjust(raw.pvals, "fdr");
+
+ # now, clean up result, synchronize with hit.query
+ res.mat <- res.mat[hit.num>0,,drop = F];
+ hits.query <- hits.query[hit.num>0];
+ hits.all <- hits.query
+
+ if(nrow(res.mat)> 1){
+ # order by p value
+ ord.inx<-order(res.mat[,4]);
+ res.mat <- signif(res.mat[ord.inx,],3);
+ hits.query <- hits.query[ord.inx];
+
+ imp.inx <- res.mat[,4] <= 0.01;
+ if(sum(imp.inx) < 10){ # too little left, give the top ones
+ topn <- ifelse(nrow(res.mat) > 10, 10, nrow(res.mat));
+ res.mat <- res.mat[1:topn,];
+ hits.query <- hits.query[1:topn];
+ }else{
+ res.mat <- res.mat[imp.inx,];
+ hits.query <- hits.query[imp.inx];
+ if(sum(imp.inx) > 120){
+ # now, clean up result, synchronize with hit.query
+ res.mat <- res.mat[1:120,];
+ hits.query <- hits.query[1:120];
+ }
+ }
+ }
+
+ Save2KEGGJSON(hits.query, res.mat, file.nm, hits.all);
+ return(1);
+}
+
+PerformKOEnrichAnalysis_ListOld <- function(file.nm){
+ if(idtype == "cmpd"){
+ current.set <- current.cmpd.set;
+ } else if(idtype == "gene&cmpd"){
+ matchidx <- match(names(current.cmpd.set), names(current.geneset))
+ current.set <- list()
+ # TO-DO: Fix code to handle case if length(current.cmpd.set) > length(current.geneset).
+ # Then, start loop with current.cmpd.set
+ for(i in c(1:length(current.geneset))){
+ if(i %in% matchidx){
+ cidx <- which(matchidx==i)
+ mergels <- c(current.cmpd.set[cidx][[1]], current.geneset[i][[1]])
+ current.set[[names(current.cmpd.set[cidx])]] <- mergels
+ } else{
+ current.set[[names(current.geneset[i])]] <- current.geneset[i][[1]]
+ }
+ }
+ # Add compound sets that did not match
+ cidx <- which(is.na(matchidx))
+ for(i in c(1:length(cidx))){
+ current.set[[names(current.cmpd.set[cidx[i]])]] <- current.cmpd.set[cidx[i]][[1]]
+ }
+ } else{
+ current.set <- current.geneset;
+
+ }
+ current.universe <- unique(unlist(current.set));
+
+ # prepare for the result table
+ set.size<-length(current.set);
+ res.mat<-matrix(0, nrow=set.size, ncol=5);
+ rownames(res.mat)<-names(current.set);
+ colnames(res.mat)<-c("Total", "Expected", "Hits", "Pval", "FDR");
+
+ # prepare query
+ ora.vec <- NULL;
+ exp.vec <- dataSet$data[,1]; # drop dim for json
+ ora.vec <- names(exp.vec);
+
+ # need to cut to the universe covered by the pathways, not all genes
+ hits.inx <- ora.vec %in% current.universe;
+ ora.vec <- ora.vec[hits.inx];
+ #ora.nms <- ora.nms[hits.inx];
+
+ q.size<-length(ora.vec);
+
+ # get the matched query for each pathway
+ hits.query <- lapply(current.set,
+ function(x) {
+ ora.vec[ora.vec%in%unlist(x)];
+ }
+ );
+ names(hits.query) <- names(current.set);
+
+ hit.num<-unlist(lapply(hits.query, function(x){length(x)}), use.names=FALSE);
+
+ # total unique gene number
+ uniq.count <- length(current.universe);
+
+ # unique gene count in each pathway
+ set.size <- unlist(lapply(current.set, length));
+
+ res.mat[,1]<-set.size;
+ res.mat[,2]<-q.size*(set.size/uniq.count);
+ res.mat[,3]<-hit.num;
+
+ # use lower.tail = F for P(X>x)
+ raw.pvals <- phyper(hit.num-1, set.size, uniq.count-set.size, q.size, lower.tail=F);
+ res.mat[,4]<- raw.pvals;
+ res.mat[,5] <- p.adjust(raw.pvals, "fdr");
+
+ # now, clean up result, synchronize with hit.query
+ res.mat <- res.mat[hit.num>0,,drop = F];
+ hits.query <- hits.query[hit.num>0];
+ hits.all <- hits.query
+
+ if(nrow(res.mat)> 1){
+ # order by p value
+ ord.inx<-order(res.mat[,4]);
+ res.mat <- signif(res.mat[ord.inx,],3);
+ hits.query <- hits.query[ord.inx];
+
+ imp.inx <- res.mat[,4] <= 0.01;
+ if(sum(imp.inx) < 10){ # too little left, give the top ones
+ topn <- ifelse(nrow(res.mat) > 10, 10, nrow(res.mat));
+ res.mat <- res.mat[1:topn,];
+ hits.query <- hits.query[1:topn];
+ }else{
+ res.mat <- res.mat[imp.inx,];
+ hits.query <- hits.query[imp.inx];
+ if(sum(imp.inx) > 120){
+ # now, clean up result, synchronize with hit.query
+ res.mat <- res.mat[1:120,];
+ hits.query <- hits.query[1:120];
+ }
+ }
+ }
+
+ Save2KEGGJSONOld(hits.query, res.mat, file.nm, hits.all);
+ return(1);
+}
+
+PerformKOEnrichAnalysis_KO01100Old <- function(mSetObj=NA, category, file.nm){
+
+ mSetObj <- .get.mSet(mSetObj);
+ LoadKEGGKO_libOld(category);
+ #if(enrich.type == "hyper"){ else PerformKOEnrichAnalysis_Table
+ PerformKOEnrichAnalysis_ListOld(file.nm);
+
+ if(.on.public.web == FALSE){
+ return(.set.mSet(mSetObj));
+ }
+}
+
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/networks_view.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/networks_view.R
new file mode 100755
index 0000000000000000000000000000000000000000..41e899a99c9689f244a2b1499f613cd05ab855c7
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/networks_view.R
@@ -0,0 +1,1193 @@
+#'Update integrative pathway analysis for new input list
+#'@description used for integrative analysis
+#'as well as general pathways analysis for meta-analysis results
+#'@usage UpdateIntegPathwayAnalysis(mSetObj=NA, qids, file.nm, topo="dc", enrich="hyper", libOpt="integ")
+#'@param mSetObj Input name of the created mSet Object
+#'@param qids Input the query IDs
+#'@param file.nm Input the name of the file
+#'@param topo Select the mode for topology analysis: Degree Centrality ("dc") measures the number of links that connect to a node
+#'(representing either a gene or metabolite) within a pathway; Closeness Centrality ("cc") measures the overall distance from a given node
+#'to all other nodes in a pathway; Betweenness Centrality ("bc")measures the number of shortest paths from all nodes to all the others that pass through a given node within a pathway.
+#'@param enrich Method to perform over-representation analysis (ORA) based on either hypergenometrics analysis ("hyper")
+#' or Fisher's exact method ("fisher").
+#'@param libOpt Select the different modes of pathways, either the gene-metabolite mode ("integ") which allows for joint-analysis
+#' and visualization of both significant genes and metabolites or the gene-centric ("genetic") and metabolite-centric mode ("metab") which allows users
+#' to identify enriched pathways driven by significant genes or metabolites, respectively.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+UpdateIntegPathwayAnalysis <- function(mSetObj=NA, qids, file.nm, topo="dc", enrich="hyper", libOpt="integ"){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ sub.dir <- paste0("kegg/jointpa/",libOpt);
+ destfile <- paste0(mSetObj$org, ".qs");
+ current.kegglib <<- .get.my.lib(destfile, sub.dir);
+ load_igraph();
+
+ qids <- do.call(rbind, strsplit(qids, "; ", fixed=TRUE));
+ idtypes <- unlist(sapply(qids, function(x) substring(x, 1, 1) == "C"))
+ qcmpds <- qids[idtypes]
+ qgenes <- qids[!idtypes]
+
+ set.size <- length(current.kegglib$mset.list);
+ ms.list <- lapply(current.kegglib$mset.list, function(x){strsplit(x, " ", fixed=TRUE)});
+ current.universe <- unique(unlist(ms.list));
+
+ # prepare for the result table
+ res.mat<-matrix(0, nrow=set.size, ncol=7);
+ rownames(res.mat)<-names(current.kegglib$path.ids);
+ colnames(res.mat)<-c("Total", "Expected", "Hits", "P.Value", "Topology", "PVal.Z", "Topo.Z");
+
+ mSetObj$dataSet$pathinteg.method <- libOpt;
+ mSetObj$dataSet$path.mat <- NULL;
+
+ if(libOpt == "genetic"){
+ gene.vec <- paste(mSetObj$org, ":", qgenes, sep="");
+ ora.vec <- gene.vec;
+ ora.vec.ids <- c(qgenes);
+ uniq.count <- current.kegglib$uniq.gene.count;
+ uniq.len <- current.kegglib$gene.counts;
+
+ }else if(libOpt == "metab"){
+ cmpd.vec <- paste("cpd:", qcmpds, sep="");
+ ora.vec <- cmpd.vec;
+ ora.vec.ids <- c(qcmpds);
+ uniq.count <- current.kegglib$uniq.cmpd.count
+ uniq.len <- current.kegglib$cmpd.counts;
+
+ }else{ # integ
+
+ cmpd.vec <- paste("cpd:", qcmpds, sep="");
+ gene.vec <- paste(mSetObj$org, ":", qgenes, sep="");
+ ora.vec <- c(cmpd.vec, gene.vec);
+ ora.vec.ids <- c(qcmpds, qgenes);
+
+ uniq.count <- current.kegglib$uniq.cmpd.count
+ uniq.len <- current.kegglib$cmpd.counts;
+ uniq.count <- uniq.count + current.kegglib$uniq.gene.count;
+ uniq.len <- uniq.len + current.kegglib$gene.counts;
+
+ }
+ # need to cut to the universe covered by the pathways, not all genes
+ ora.vec <- ora.vec[ora.vec %in% current.universe]
+ q.size <- length(ora.vec);
+ # note, we need to do twice one for nodes (for plotting)
+ # one for query for calculating, as one node can be associated with multiple matches
+ # get the matched nodes on each pathway
+ hits.path <- lapply(ms.list, function(x) {unlist(lapply(x, function(var){any(var%in%ora.vec);}),use.names=FALSE)});
+ names(hits.path) <- current.kegglib$path.ids;
+
+ # get the matched query for each pathway
+ hits.query <- lapply(ms.list, function(x) {ora.vec%in%unlist(x);});
+
+ hit.num <- unlist(lapply(hits.query, function(x){sum(x)}), use.names=FALSE);
+
+ if(sum(hit.num) == 0){
+ AddErrMsg("No hits found for your input!");
+ return(0);
+ }
+
+ set.num <- uniq.len;
+ res.mat[,1] <- set.num;
+ res.mat[,2] <- q.size*(set.num/uniq.count);
+ res.mat[,3] <- hit.num;
+
+ # use lower.tail = F for P(X>x)
+ if(enrich=="hyper"){
+ res.mat[,4] <- phyper(hit.num-1, set.num, uniq.count-set.num, q.size, lower.tail=F);
+ }else if(enrich == "fisher"){
+ res.mat[,4] <- GetFisherPvalue(hit.num, q.size, set.num, uniq.count);
+ }else{
+ AddErrMsg(paste("Not defined enrichment method:", enrich));
+ return(0);
+ }
+
+ # toplogy test
+ if(topo == "bc"){
+ imp.list <- current.kegglib$bc;
+ }else if(topo == "dc"){
+ imp.list <- current.kegglib$dc;
+ }else if(topo == "cc"){
+ imp.list <- current.kegglib$cc;
+ }else{
+ AddErrMsg(paste("Not defined topology method:", topo));
+ return(0);
+ }
+
+ # now, perform topological analysis
+ # calculate the sum of importance
+ res.mat[,5] <- mapply(function(x, y){sum(x[y])}, imp.list, hits.path);
+
+ # now add two more columns for the scaled values
+ res.mat[,6] <- scale(-log(res.mat[,4]));
+ res.mat[,7] <- scale(res.mat[,5]);
+
+ # now, clean up result, synchronize with hit.query
+ res.mat <- res.mat[hit.num>0,,drop = F];
+ hits.query <- hits.query[hit.num>0];
+
+ if(nrow(res.mat)> 1){
+ # order by p value
+ ord.inx <- order(res.mat[,4]);
+ res.mat <- signif(res.mat[ord.inx,],3);
+ hits.query <- hits.query[ord.inx];
+
+ imp.inx <- res.mat[,4] <= 0.05;
+ if(sum(imp.inx) < 10){ # too little left, give the top ones
+ topn <- ifelse(nrow(res.mat) > 10, 10, nrow(res.mat));
+ res.mat <- res.mat[1:topn,];
+ hits.query <- hits.query[1:topn];
+ }else{
+ res.mat <- res.mat[imp.inx,];
+ hits.query <- hits.query[imp.inx];
+ if(sum(imp.inx) > 120){
+ # now, clean up result, synchronize with hit.query
+ res.mat <- res.mat[1:120,];
+ hits.query <- hits.query[1:120];
+ }
+ }
+ }
+
+ hits.names <- lapply(hits.query, function(x) ora.vec.ids[which(x == TRUE)]);
+
+ #get gene symbols
+ resTable <- data.frame(Pathway=rownames(res.mat), res.mat);
+
+ fun.anot = hits.names; names(fun.anot) <- resTable[,1];
+ fun.pval = resTable[,5]; if(length(fun.pval) ==1) { fun.pval <- matrix(fun.pval) };
+ hit.num = resTable[,4]; if(length(hit.num) ==1) { hit.num <- matrix(hit.num) };
+ current.setlink <- "http://www.genome.jp/kegg-bin/show_pathway?";
+
+ json.res <- list(
+ fun.link = current.setlink[1],
+ fun.anot = fun.anot,
+ #fun.ids = fun.ids,
+ fun.pval = fun.pval,
+ hit.num = hit.num
+ );
+ json.mat <- RJSONIO::toJSON(json.res, .na='null');
+ json.nm <- paste(file.nm, ".json", sep="");
+
+ sink(json.nm)
+ cat(json.mat);
+ sink();
+
+ # write csv
+ fun.hits <<- hits.query;
+ fun.pval <<- resTable[,5];
+ hit.num <<- resTable[,4];
+ csv.nm <- paste(file.nm, ".csv", sep="");
+ fast.write.csv(resTable, file=csv.nm, row.names=F);
+ return(1);
+}
+
+#'Create igraph from the edgelist saved from graph DB and decompose into subnets
+#'@description Function for the network explorer module, prepares user's data for network exploration.
+#'@param mSetObj Input name of the created mSet Object
+#'@export
+#'@import igraph
+CreateGraph <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(.on.public.web){
+ load_igraph()
+ }
+
+ net.type <- pheno.net$table.nm;
+ node.list <- pheno.net$node.data;
+ edge.list <- pheno.net$edge.data;
+
+ seed.proteins <- pheno.net$seeds;
+ if(net.type == "dspc"){
+ if(nrow(edge.list) < 1000 ){
+ top.percent <- round(nrow(edge.list)*0.2);
+ top.edge <- sort(unique(edge.list$Pval))[1:top.percent]; #default only show top 20% significant edges when #edges<1000
+ }else{ #default only show top 100 significant edges when #edges>1000
+ top.edge <- sort(unique(edge.list$Pval))[1:100];
+ }
+ top.inx <- match(edge.list$Pval, top.edge);
+ topedge.list <- edge.list[!is.na(top.inx), ,drop=F];
+ overall.graph <-simplify(graph_from_data_frame(topedge.list, directed=FALSE, vertices=NULL), edge.attr.comb="first");
+ seed.graph <<- seed.proteins;
+ }else{
+ overall.graph <- simplify(graph.data.frame(edge.list, directed=FALSE, vertices=node.list), remove.multiple=FALSE);
+ # add node expression value
+ #newIDs <- names(seed.expr);
+ newIDs <- seed.graph;
+ match.index <- match(V(overall.graph)$name, newIDs);
+ expr.vals <- seed.expr[match.index];
+ overall.graph <- set.vertex.attribute(overall.graph, "abundance", index = V(overall.graph), value = expr.vals);
+ }
+
+ hit.inx <- seed.proteins %in% node.list[,1];
+ seed.proteins <<- seed.proteins[hit.inx];
+
+ substats <- DecomposeGraph(overall.graph);
+ overall.graph <<- overall.graph;
+
+ #tmp-test-js; mSetObj <- PlotNetwork(mSetObj, network.type);
+
+ if(.on.public.web){
+ mSetObj <- .get.mSet(mSetObj);
+ if(!is.null(substats)){
+ return(c(length(seed.graph), length(seed.proteins), nrow(node.list), nrow(edge.list), length(pheno.comps), substats));
+ }else{
+ return(0);
+ }
+ }else{
+ return(.set.mSet(mSetObj));
+ }
+}
+
+###
+### Utility functions
+###
+
+# Utility function to plot network for analysis report (CreateGraph)
+PlotNetwork <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ img.Name = paste(imgName, "_dpi", dpi, ".", format, sep="");
+
+ if(is.na(width)){
+ w <- 10;
+ }else if(width == 0){
+ w <- 8;
+
+ }else{
+ w <- width;
+ }
+
+ h <- w;
+
+ mSetObj$imgSet$networkplot <- img.Name
+
+ nodeColors <- rep("lightgrey", length(V(overall.graph)))
+ idx.cmpd <- as.vector(sapply(names(V(overall.graph)), function(x) substring(x,0,1) == "C"))
+ idx.genes <- names(V(overall.graph)) %in% mSetObj$dataSet$gene
+ nodeColors[idx.cmpd] <- "orange"
+ nodeColors[idx.genes] <- "#306EFF"
+ V(overall.graph)$color <- nodeColors
+
+ # annotation
+ nms <- V(overall.graph)$name;
+ hit.inx <- match(nms, pheno.net$node.data[,1]);
+ lbls <- pheno.net$node.data[hit.inx,2];
+ V(overall.graph)$name <- as.vector(lbls);
+
+ Cairo::Cairo(file = img.Name, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ plot(overall.graph)
+ text(1,1, "Entrez gene ", col="#306EFF")
+ text(1,0.9, "KEGG compound ", col="orange")
+ if(sum(nodeColors == "lightgrey") > 0){
+ text(1,0.8, "OMIM disease ", col="lightgrey")
+ }
+ dev.off();
+
+ if(.on.public.web==FALSE){
+ return(.set.mSet(mSetObj));
+ }else{
+ .set.mSet(mSetObj);
+ }
+}
+
+PrepareNetwork <- function(net.nm, json.nm){
+ convertIgraph2JSON(net.nm, json.nm);
+ current.net.nm <<- net.nm;
+ return(1);
+}
+
+# from node ID (uniprot) return entrez IDs (one to many)
+GetNodeEntrezIDs <- function(uniprotID){
+ enIDs <- current.anot[uniprotID];
+ enIDs <- paste(enIDs, collapse="||");
+ enIDs;
+}
+
+GetNodeEmblEntrezIDs <- function(emblprotein){
+ enIDs <- current.anot[emblprotein];
+ enIDs <- paste(enIDs, collapse="||");
+ enIDs;
+}
+
+GetNodeIDs <- function(){
+ V(overall.graph)$name;
+}
+
+GetNodeNames <- function(){
+ V(overall.graph)$Label;
+}
+
+GetNodeDegrees <- function(){
+ degree(overall.graph);
+}
+
+GetNodeBetweenness <- function(){
+ round(betweenness(overall.graph, directed=F, normalized=F), 2);
+}
+
+DecomposeGraph <- function(gObj, minNodeNum=3, maxNetNum=10){
+
+ # now decompose to individual connected subnetworks
+ comps <- igraph::decompose.graph(gObj, min.vertices=minNodeNum);
+ if(length(comps) == 0){
+ current.msg <<- paste("No subnetwork was identified with at least", minNodeNum, "nodes!");
+ return(NULL);
+ }
+
+ # first compute subnet stats
+ net.stats <- ComputeSubnetStats(comps);
+ ord.inx <- order(net.stats[,1], decreasing=TRUE);
+ net.stats <- net.stats[ord.inx,];
+ comps <- comps[ord.inx];
+ names(comps) <- rownames(net.stats) <- paste("subnetwork", 1:length(comps), sep="");
+
+ # note, we report stats for all nets (at least 3 nodes);
+ hit.inx <- net.stats$Node >= minNodeNum;
+ comps <- comps[hit.inx];
+
+ # in case too many
+ if(length(comps) > maxNetNum){
+ comps <- comps[1:maxNetNum];
+ }
+
+ # now record
+ pheno.comps <<- comps;
+ net.stats <<- net.stats;
+ sub.stats <- unlist(lapply(comps, vcount));
+ return(sub.stats);
+}
+
+PrepareSubnetDownloads <- function(nm){
+ g <- pheno.comps[[nm]];
+ # need to update graph so that id is compound names rather than ID
+ V(g)$name <- as.character(doID2LabelMapping(V(g)$name));
+ saveNetworkInSIF(g, nm);
+}
+
+ComputeSubnetStats <- function(comps){
+ net.stats <- as.data.frame(matrix(0, ncol = 3, nrow = length(comps)));
+ colnames(net.stats) <- c("Node", "Edge", "Query");
+ for(i in 1:length(comps)){
+ g <- comps[[i]];
+ net.stats[i,] <- c(vcount(g),ecount(g),sum(seed.proteins %in% V(g)$name));
+ }
+ return(net.stats);
+}
+
+ UpdateSubnetStats <- function(){
+ old.nms <- names(pheno.comps);
+ net.stats <- ComputeSubnetStats(pheno.comps);
+ ord.inx <- order(net.stats[,1], decreasing=TRUE);
+ net.stats <- net.stats[ord.inx,];
+ rownames(net.stats) <- old.nms[ord.inx];
+ net.stats <<- net.stats;
+}
+
+GetNetsName <- function(){
+ rownames(net.stats);
+}
+
+GetNetsNameString <- function(){
+ paste(rownames(net.stats), collapse="||");
+}
+
+GetNetsEdgeNum <- function(){
+ as.numeric(net.stats$Edge);
+}
+
+GetNetsNodeNum <- function(){
+ as.numeric(net.stats$Node);
+}
+
+GetNetsQueryNum <- function(){
+ as.numeric(net.stats$Query);
+}
+
+# from to should be valid nodeIDs
+GetShortestPaths <- function(from, to){
+ current.net <- pheno.comps[[current.net.nm]];
+ paths <- igraph::get.all.shortest.paths(current.net, from, to)$res;
+ if(length(paths) == 0){
+ return (paste("No connection between the two nodes!"));
+ }
+
+ path.vec <- vector(mode="character", length=length(paths));
+ for(i in 1:length(paths)){
+ path.inx <- paths[[i]];
+ path.ids <- V(current.net)$name[path.inx];
+ path.sybls <- path.ids;
+ pids <- paste(path.ids, collapse="->");
+ psbls <- paste(path.sybls, collapse="->");
+ path.vec[i] <- paste(c(pids, psbls), collapse=";")
+ }
+
+ if(length(path.vec) > 50){
+ path.vec <- path.vec[1:50];
+ }
+
+ all.paths <- paste(path.vec, collapse="||");
+ return(all.paths);
+}
+
+# exclude nodes in current.net (networkview)
+ExcludeNodes <- function(nodeids, filenm){
+ nodes2rm <- strsplit(nodeids, ";", fixed=TRUE)[[1]];
+ current.net <- pheno.comps[[current.net.nm]];
+ current.net <- igraph::delete.vertices(current.net, nodes2rm);
+
+ # need to remove all orphan nodes
+ bad.vs<-V(current.net)$name[degree(current.net) == 0];
+ current.net <- igraph::delete.vertices(current.net, bad.vs);
+
+ # return all those nodes that are removed
+ nds2rm <- paste(c(bad.vs, nodes2rm), collapse="||");
+
+ # update topo measures
+ node.btw <- as.numeric(igraph::betweenness(current.net));
+ node.dgr <- as.numeric(igraph::degree(current.net));
+ node.exp <- as.numeric(igraph::get.vertex.attribute(current.net, name="abundance", index = V(current.net)));
+ nms <- V(current.net)$name;
+ hit.inx <- match(nms, pheno.net$node.data[,1]);
+ lbls <- pheno.net$node.data[hit.inx,2];
+
+ nodes <- vector(mode="list");
+ for(i in 1:length(nms)){
+ nodes[[i]] <- list(
+ id=nms[i],
+ label=lbls[i],
+ degree=node.dgr[i],
+ between=node.btw[i],
+ expr = node.exp[i]
+ );
+ }
+ # now only save the node pos to json
+ netData <- list(deletes=nds2rm, nodes=nodes);
+ sink(filenm);
+ cat(RJSONIO::toJSON(netData));
+ sink();
+
+ pheno.comps[[current.net.nm]] <<- current.net;
+ UpdateSubnetStats();
+
+ # remember to forget the cached layout, and restart caching, as this is now different object (with the same name)
+ #forget(PerformLayOut_mem);
+ return(filenm);
+}
+
+# support walktrap, infomap and lab propagation
+FindCommunities <- function(method="walktrap", use.weight=FALSE){
+
+ # make sure this is the connected
+ current.net <- pheno.comps[[current.net.nm]];
+ g <- current.net;
+ if(!is.connected(g)){
+ g <- igraph::decompose.graph(current.net, min.vertices=2)[[1]];
+ }
+ total.size <- length(V(g));
+
+ if(use.weight){ # this is only tested for walktrap, should work for other method
+ # now need to compute weights for edges
+ egs <- igraph::get.edges(g, E(g)); #node inx
+ nodes <- V(g)$name;
+ # conver to node id
+ negs <- cbind(nodes[egs[,1]],nodes[egs[,2]]);
+
+ # get min FC change
+ base.wt <- min(abs(seed.expr))/10;
+
+ # check if user only give a gene list without logFC or all same fake value
+ if(length(unique(seed.expr)) == 1){
+ seed.expr <- rep(1, nrow(negs));
+ base.wt <- 0.1; # weight cannot be 0 in walktrap
+ }
+
+ wts <- matrix(base.wt, ncol=2, nrow = nrow(negs));
+ for(i in 1:ncol(negs)){
+ nd.ids <- negs[,i];
+ hit.inx <- match(names(seed.expr), nd.ids);
+ pos.inx <- hit.inx[!is.na(hit.inx)];
+ wts[pos.inx,i]<- seed.expr[!is.na(hit.inx)]+0.1;
+ }
+ nwt <- apply(abs(wts), 1, function(x){mean(x)^2})
+ }
+
+ if(method == "walktrap"){
+ fc <- igraph::walktrap.community(g);
+ }else if(method == "infomap"){
+ fc <- igraph::infomap.community(g);
+ }else if(method == "labelprop"){
+ fc <- igraph::label.propagation.community(g);
+ }else{
+ print(paste("Unknown method:", method));
+ return ("NA||Unknown method!");
+ }
+
+ if(length(fc) == 0 || modularity(fc) == 0){
+ return ("NA||No communities were detected!");
+ }
+
+ # only get communities
+ communities <- igraph::communities(fc);
+ community.vec <- vector(mode="character", length=length(communities));
+ gene.community <- NULL;
+ qnum.vec <- NULL;
+ pval.vec <- NULL;
+ rowcount <- 0;
+ nms <- V(g)$name;
+ hit.inx <- match(nms, pheno.net$node.data[,1]);
+ sybls <- pheno.net$node.data[hit.inx,2];
+ names(sybls) <- V(g)$name;
+ for(i in 1:length(communities)){
+ # update for igraph 1.0.1
+ path.ids <- communities[[i]];
+ psize <- length(path.ids);
+ if(psize < 5){
+ next; # ignore very small community
+ }
+ hits <- seed.proteins %in% path.ids;
+ qnums <- sum(hits);
+ if(qnums == 0){
+ next; # ignor community containing no queries
+ }
+
+ rowcount <- rowcount + 1;
+ pids <- paste(path.ids, collapse="->");
+ #path.sybls <- V(g)$Label[path.inx];
+ path.sybls <- sybls[path.ids];
+ com.mat <- cbind(path.ids, path.sybls, rep(i, length(path.ids)));
+ gene.community <- rbind(gene.community, com.mat);
+ qnum.vec <- c(qnum.vec, qnums);
+
+ # calculate p values (comparing in- out- degrees)
+ #subgraph <- induced.subgraph(g, path.inx);
+ subgraph <- igraph::induced.subgraph(g, path.ids);
+ in.degrees <- igraph::degree(subgraph);
+ #out.degrees <- degree(g, path.inx) - in.degrees;
+ out.degrees <- igraph::degree(g, path.ids) - in.degrees;
+ ppval <- wilcox.test(in.degrees, out.degrees)$p.value;
+ ppval <- signif(ppval, 3);
+ pval.vec <- c(pval.vec, ppval);
+
+ # calculate community score
+ community.vec[rowcount] <- paste(c(psize, qnums, ppval, pids), collapse=";");
+ }
+
+ ord.inx <- order(pval.vec, decreasing=F);
+ community.vec <- community.vec[ord.inx];
+ qnum.vec <- qnum.vec[ord.inx];
+ ord.inx <- order(qnum.vec, decreasing=T);
+ community.vec <- community.vec[ord.inx];
+
+ all.communities <- paste(community.vec, collapse="||");
+ colnames(gene.community) <- c("Id", "Label", "Module");
+ fast.write.csv(gene.community, file="module_table.csv", row.names=F);
+ return(all.communities);
+}
+
+community.significance.test <- function(graph, vs, ...) {
+ subgraph <- igraph::induced.subgraph(graph, vs)
+ in.degrees <- igraph::degree(subgraph)
+ out.degrees <- igraph::degree(graph, vs) - in.degrees
+ wilcox.test(in.degrees, out.degrees, ...)
+}
+
+###################################
+# Adapted from netweavers package
+###################
+#'@import RColorBrewer
+convertIgraph2JSON <- function(net.nm, filenm){
+ net.nm<<-net.nm;
+ filenm<<-filenm;
+
+ table.nm <- pheno.net$table.nm;
+ g <- pheno.comps[[net.nm]];
+ # annotation
+ nms <- V(g)$name;
+ hit.inx <- match(nms, pheno.net$node.data[,1]);
+ lbls <- pheno.net$node.data[hit.inx,2];
+ gene.names <- pheno.net$node.data[hit.inx,3];
+
+ if("Evidence" %in% colnames(pheno.net$node.data)){
+ evidence.ids <- pheno.net$node.data[hit.inx,4];
+ } else {
+ evidence.ids <- rep("", length(gene.names));
+ }
+
+ # get edge data
+ edge.mat <- igraph::get.edgelist(g);
+ edge.evidence <- igraph::edge_attr(g, "Evidence");
+ edge.coeff <- igraph::edge_attr(g, "Coefficient");
+ edge.pval <- igraph::edge_attr(g, "Pval");
+ edge.qval <- igraph::edge_attr(g, "Adj_Pval");
+ if(table.nm=="dspc"){
+ edge.sizes <- as.numeric(rescale2NewRange((-log10(edge.pval)), 0.5, 10));
+ edge.sizes.qval <- as.numeric(rescale2NewRange((-log10(edge.qval)), 0.5, 10));
+ edge.sizes.coeff <- as.numeric(rescale2NewRange(edge.coeff, 0.5, 10));
+ }
+
+ if(!is.null(edge.evidence)){
+ edge.mat <- cbind(id=1:nrow(edge.mat), source=edge.mat[,1], target=edge.mat[,2], evidence=edge.evidence);
+ } else if(!is.null(edge.coeff)){
+ edge.mat <- cbind(id=1:nrow(edge.mat), source=edge.mat[,1], target=edge.mat[,2], coeff=edge.coeff, pval=edge.pval, qval=edge.qval, esize_pval=edge.sizes, esize_qval=edge.sizes.qval, esize_coeff=edge.sizes.coeff);
+ }else{
+ edge.mat <- cbind(id=1:nrow(edge.mat), source=edge.mat[,1], target=edge.mat[,2]);
+ }
+
+ # now get coords
+ #pos.xy <- PerformLayOut_mem(net.nm, "Default");
+ pos.xy <- PerformLayOut(net.nm, "Default");
+ # get the note data
+ node.btw <- as.numeric(igraph::betweenness(g));
+ node.dgr <- as.numeric(igraph::degree(g));
+ node.exp <- as.numeric(igraph::get.vertex.attribute(g, name="abundance", index = V(g)));
+
+ # node size to degree values
+ if(vcount(g)>500){
+ min.size = 1;
+ }else if(vcount(g)>200){
+ min.size = 2;
+ }else{
+ min.size = 3;
+ }
+ node.sizes <- as.numeric(rescale2NewRange((log10(node.dgr))^2, min.size, 9));
+ edge.sizes <- 1;
+ centered = T;
+ notcentered = F;
+ coeff <- 0;
+
+ if(table.nm != "dspc"){
+ # update node color based on betweenness
+ topo.val <- log10(node.btw+1);
+ topo.colsb <- ComputeColorGradient(topo.val, "black", notcentered);
+ topo.colsw <- ComputeColorGradient(topo.val, "white", notcentered);
+
+ # color based on expression
+ bad.inx <- is.na(node.exp) | node.exp==0;
+ if(!all(bad.inx)){
+ exp.val <- node.exp;
+ node.colsb.exp <- ComputeColorGradient(exp.val, "black", centered);
+ node.colsw.exp <- ComputeColorGradient(exp.val, "white", centered);
+ node.colsb.exp[bad.inx] <- "#d3d3d3";
+ node.colsw.exp[bad.inx] <- "#c6c6c6";
+ # node.colsw.exp[bad.inx] <- "#66CCFF";
+ }else{
+ node.colsb.exp <- rep("#d3d3d3",length(node.exp));
+ node.colsw.exp <- rep("#c6c6c6",length(node.exp));
+ }
+}
+
+ if(table.nm == "global"){
+ # now update for bipartite network
+ # setup shape (gene circle, other squares)
+ # Circles for genes
+ shapes <- rep("circle", length(nms));
+ # Squares for phenotypes
+ mir.inx <- nms %in% edge.mat[,"target"];
+ shapes[mir.inx] <- "square";
+ # Diamond for metabolites
+ cmpds.node <- as.vector(sapply(nms, function(x) substr(x, 1, 1) == "C"))
+ shapes[cmpds.node] <- "diamond"
+ node.sizes[mir.inx] <- node.sizes[mir.inx] + 0.5;
+ # update mir node color
+ node.colsw.exp[mir.inx] <- topo.colsw[mir.inx] <- "#306EFF"; # dark blue
+ node.colsb.exp[mir.inx] <- topo.colsb[mir.inx] <- "#98F5FF";
+ } else if (table.nm == "dspc"){
+ # Diamond for metabolites
+ # can distinguish known and unknown metabolites using different shapes L.C.
+ shapes <- rep("diamond", length(nms));
+ topo.colsb <- rep("#98F5FF",length(nms));
+ topo.colsw <- rep("#306EFF",length(nms)); # dark blue
+ node.colsb.exp <- rep("#d3d3d3",length(node.exp));
+ node.colsw.exp <- rep("#c6c6c6",length(node.exp));
+ } else {
+ # now update for bipartite network
+ # setup shape (gene circle, other squares)
+ shapes <- rep("circle", length(nms));
+ if(pheno.net$db.type != 'ppi' && table.nm != "metabo_metabolites"){ # the other part miRNA or TF will be in square
+ mir.inx <- nms %in% edge.mat[,"target"];
+ shapes[mir.inx] <- "square";
+ node.sizes[mir.inx] <- node.sizes[mir.inx] + 0.5;
+
+ # update mir node color
+ node.colsw.exp[mir.inx] <- topo.colsw[mir.inx] <- "#306EFF"; # dark blue
+ node.colsb.exp[mir.inx] <- topo.colsb[mir.inx] <- "#98F5FF";
+ }
+ }
+
+ # now create the json object
+ nodes <- vector(mode="list");
+ for(i in 1:length(node.sizes)){
+ # TODO: avoid which here and just attach HMDB matched IDs to the list of Compound nodes
+ hmdb.id <- mSet$dataSet$map.table[which(mSet$dataSet$map.table[,1] == nms[i]), 3]
+
+ nodes[[i]] <- list(
+ id=nms[i],
+ idnb = i,
+ hmdb=hmdb.id,
+ label=lbls[i],
+ evidence=evidence.ids[i],
+ genename=gene.names[i],
+ x = pos.xy[i,1],
+ y = pos.xy[i,2],
+ size=node.sizes[i],
+ type=shapes[i],
+ colorb=topo.colsb[i],
+ colorw=topo.colsw[i],
+ attributes=list(
+ expr = node.exp[i],
+ expcolb=node.colsb.exp[i],
+ expcolw=node.colsw.exp[i],
+ degree=node.dgr[i],
+ between=node.btw[i])
+ );
+ }
+
+ # save node table
+ nd.tbl <- data.frame(Id=nms, Label=lbls, Degree=node.dgr, Betweenness=round(node.btw,2));
+ # order
+ ord.inx <- order(nd.tbl[,3], nd.tbl[,4], decreasing = TRUE)
+ nd.tbl <- nd.tbl[ord.inx, ];
+ fast.write.csv(nd.tbl, file="node_table.csv", row.names=FALSE);
+
+ # covert to json
+ netData <- list(nodes=nodes, edges=edge.mat);
+ sink(filenm);
+ cat(RJSONIO::toJSON(netData));
+ sink();
+}
+
+# also save to GraphML
+ExportNetwork <- function(fileName){
+ current.net <- pheno.comps[[current.net.nm]];
+ igraph::write.graph(current.net, file=fileName, format="graphml");
+}
+
+ExtractModule<- function(nodeids){
+ set.seed(8574);
+ nodes <- strsplit(nodeids, ";", fixed=TRUE)[[1]];
+
+ g <- pheno.comps[[current.net.nm]];
+ # try to see if the nodes themselves are already connected
+ hit.inx <- V(g)$name %in% nodes;
+ gObj <- igraph::induced.subgraph(g, V(g)$name[hit.inx]);
+
+ # now find connected components
+ comps <- igraph::decompose.graph(gObj, min.vertices=1);
+
+ if(length(comps) == 1){ # nodes are all connected
+ g <- comps[[1]];
+ }else{
+ # extract modules
+ paths.list <-list();
+ sd.len <- length(nodes);
+ for(pos in 1:sd.len){
+ paths.list[[pos]] <- igraph::get.shortest.paths(g, nodes[pos], nodes[-(1:pos)])$vpath;
+ }
+ nds.inxs <- unique(unlist(paths.list));
+ nodes2rm <- V(g)$name[-nds.inxs];
+ g <- simplify(igraph::delete.vertices(g, nodes2rm));
+ }
+ nodeList <- igraph::get.data.frame(g, "vertices");
+ if(nrow(nodeList) < 3){
+ return ("NA");
+ }
+
+ module.count <- module.count + 1;
+ module.nm <- paste("module", module.count, sep="");
+ colnames(nodeList) <- c("Id", "Label");
+ ndFileNm = paste(module.nm, "_node_list.csv", sep="");
+ fast.write.csv(nodeList, file=ndFileNm, row.names=F, quote=F);
+
+ edgeList <- igraph::get.data.frame(g, "edges");
+ edgeList <- cbind(rownames(edgeList), edgeList);
+ colnames(edgeList) <- c("Id", "Source", "Target");
+ edgFileNm = paste(module.nm, "_edge_list.csv", sep="");
+ fast.write.csv(edgeList, file=edgFileNm, row.names=F, quote=F);
+
+ filenm <- paste(module.nm, ".json", sep="");
+
+ # record the module
+ pheno.comps[[module.nm]] <<- g;
+ UpdateSubnetStats();
+
+ module.count <<- module.count;
+
+ convertIgraph2JSON(module.nm, filenm);
+ return (filenm);
+}
+
+PerformLayOut <- function(net.nm, algo){
+ g <- pheno.comps[[net.nm]];
+ vc <- vcount(g);
+ if(algo == "Default"){
+ if(vc > 3000) {
+ pos.xy <- igraph::layout.lgl(g, maxiter = 100);
+ }else if(vc > 2000) {
+ pos.xy <- igraph::layout.lgl(g, maxiter = 150);
+ }else if(vc > 1000) {
+ pos.xy <- igraph::layout.lgl(g, maxiter = 200);
+ }else if(vc < 150){
+ pos.xy <- igraph::layout.kamada.kawai(g);
+ }else{
+ pos.xy <- igraph::layout.fruchterman.reingold(g);
+ }
+ }else if(algo == "FrR"){
+ pos.xy <- igraph::layout.fruchterman.reingold(g);
+ }else if(algo == "circle"){
+ pos.xy <- igraph::layout.circle(g);
+ }else if(algo == "random"){
+ pos.xy <- igraph::layout.random(g);
+ }else if(algo == "lgl"){
+ if(vc > 3000) {
+ pos.xy <- igraph::layout.lgl(g, maxiter = 100);
+ }else if(vc > 2000) {
+ pos.xy <- igraph::layout.lgl(g, maxiter = 150);
+ }else {
+ pos.xy <- igraph::layout.lgl(g, maxiter = 200);
+ }
+ }else if(algo == "gopt"){
+ # this is a slow one
+ if(vc > 3000) {
+ maxiter = 50;
+ }else if(vc > 2000) {
+ maxiter = 100;
+ }else if(vc > 1000) {
+ maxiter = 200;
+ }else{
+ maxiter = 500;
+ }
+ pos.xy <- igraph::layout.graphopt(g, niter=maxiter);
+ }
+ pos.xy;
+}
+
+UpdateNetworkLayout <- function(algo, filenm){
+ current.net <- pheno.comps[[current.net.nm]];
+ #pos.xy <- PerformLayOut_mem(current.net.nm, algo);
+ pos.xy <- PerformLayOut(current.net.nm, algo);
+ nms <- V(current.net)$name;
+ nodes <- vector(mode="list");
+ for(i in 1:length(nms)){
+ nodes[[i]] <- list(
+ id=nms[i],
+ x=pos.xy[i,1],
+ y=pos.xy[i,2]
+ );
+ }
+ # now only save the node pos to json
+ netData <- list(nodes=nodes);
+ sink(filenm);
+ cat(RJSONIO::toJSON(netData));
+ sink();
+ return(filenm);
+}
+
+
+doID2LabelMapping <- function(entrez.vec){
+
+ hit.inx <- match(entrez.vec, nodeListu[, "Id"]);
+ symbols <- nodeListu[hit.inx, "Label"];
+
+ # if not gene symbol, use id by itself
+ na.inx <- is.na(symbols);
+ symbols[na.inx] <- entrez.vec[na.inx];
+ return(symbols);
+}
+
+# new range [a, b]
+rescale2NewRange <- function(qvec, a, b){
+ q.min <- min(qvec);
+ q.max <- max(qvec);
+ if(length(qvec) < 50){
+ a <- a*2;
+ }
+ if(q.max == q.min){
+ new.vec <- rep(8, length(qvec));
+ }else{
+ coef.a <- (b-a)/(q.max-q.min);
+ const.b <- b - coef.a*q.max;
+ new.vec <- coef.a*qvec + const.b;
+ }
+ return(new.vec);
+}
+
+# re-arrange one vector elements according to another vector values
+# usually src is character vector to be arranged
+# target is numberic vector of same length
+sync2vecs <- function(src.vec, tgt.vec){
+ if(length(src.vec) != length(tgt.vec)){
+ print("must be of the same length!");
+ return();
+ }
+ ord.inx <- match(rank(tgt.vec, ties.method="random"), 1:length(tgt.vec));
+ src.vec[ord.inx];
+}
+
+# given a data with duplicates, dups is the one with duplicates
+RemoveDuplicatesNetwork <- function(data, lvlOpt, quiet=T){
+
+ all.nms <- rownames(data);
+ colnms <- colnames(data);
+ dup.inx <- duplicated(all.nms);
+ dim.orig <- dim(data);
+ data <- apply(data, 2, as.numeric); # force to be all numeric
+ dim(data) <- dim.orig; # keep dimension (will lost when only one item)
+ rownames(data) <- all.nms;
+ colnames(data) <- colnms;
+ if(sum(dup.inx) > 0){
+ uniq.nms <- all.nms[!dup.inx];
+ uniq.data <- data[!dup.inx,,drop=F];
+
+ dup.nms <- all.nms[dup.inx];
+ uniq.dupnms <- unique(dup.nms);
+ uniq.duplen <- length(uniq.dupnms);
+
+ for(i in 1:uniq.duplen){
+ nm <- uniq.dupnms[i];
+ hit.inx.all <- which(all.nms == nm);
+ hit.inx.uniq <- which(uniq.nms == nm);
+
+ # average the whole sub matrix
+ if(lvlOpt == "mean"){
+ uniq.data[hit.inx.uniq, ]<- apply(data[hit.inx.all,,drop=F], 2, mean, na.rm=T);
+ }else if(lvlOpt == "median"){
+ uniq.data[hit.inx.uniq, ]<- apply(data[hit.inx.all,,drop=F], 2, median, na.rm=T);
+ }else if(lvlOpt == "max"){
+ uniq.data[hit.inx.uniq, ]<- apply(data[hit.inx.all,,drop=F], 2, max, na.rm=T);
+ }else{ # sum
+ uniq.data[hit.inx.uniq, ]<- apply(data[hit.inx.all,,drop=F], 2, sum, na.rm=T);
+ }
+ }
+ if(!quiet){
+ current.msg <<- paste(current.msg, paste("A total of ", sum(dup.inx), " of duplicates were replaced by their ", lvlOpt, ".", sep=""), collapse="\n");
+ }
+ return(uniq.data);
+ }else{
+ if(!quiet){
+ current.msg <<- paste(current.msg, "All IDs are unique.", collapse="\n");
+ }
+ return(data);
+ }
+}
+
+generate_breaks = function(x, n, center = F){
+ if(center){
+ m = max(abs(c(min(x, na.rm = T), max(x, na.rm = T))))
+ res = seq(-m, m, length.out = n + 1)
+ }
+ else{
+ res = seq(min(x, na.rm = T), max(x, na.rm = T), length.out = n + 1)
+ }
+ return(res)
+}
+
+ComputeColorGradient <- function(nd.vec, background="black", centered){
+ #if(sum(nd.vec<0, na.rm=TRUE) > 0){
+ #centered <- T;
+ #}else{
+ #centered <- F;
+ #}
+ color <- GetColorGradient(background, centered);
+ breaks <- generate_breaks(nd.vec, length(color), center = centered);
+ return(scale_vec_colours(nd.vec, col = color, breaks = breaks));
+}
+
+GetColorGradient <- function(background, center){
+ if(background == "black"){
+ if(center){
+ return(c(colorRampPalette(c("#31A231", "#5BC85B", "#90EE90", "#C1FFC1"))(50), colorRampPalette(c("#FF9DA6", "#FF7783", "#E32636", "#BD0313"))(50)));
+ }else{
+ return(colorRampPalette(rev(heat.colors(9)))(100));
+ }
+ }else{ # white background
+ if(center){
+ return(c(colorRampPalette(c("#137B13", "#31A231", "#5BC85B", "#90EE90"))(50), colorRampPalette(c("#FF7783", "#E32636", "#BD0313", "#96000D"))(50)));
+ }else{
+ # return(colorRampPalette(c("grey", "orange", "red", "darkred"))(100));
+ # return(colorRampPalette(c("#80d0f0", rainbow(8, start=0.8, end=1)))(100));
+ return(colorRampPalette(hsv(h = seq(0.72, 1, 0.035), s = 0.72, v = 1))(100));
+ }
+ }
+}
+
+scale_vec_colours = function(x, col = rainbow(10), breaks = NA){
+ breaks <- sort(unique(breaks));
+ return(col[as.numeric(cut(x, breaks = breaks, include.lowest = T))])
+}
+
+# for a given graph, obtain the smallest subgraphs that contain
+# all the seed nodes. This is acheived by iteratively remove
+# the marginal nodes (degree = 1) that are not in the seeds
+GetMinConnectedGraphs <- function(max.len = 200){
+ # need to test
+ set.seed(8574);
+ # first get shortest paths for all pair-wise seeds
+ my.seeds <- seed.proteins;
+ sd.len <- length(my.seeds);
+ paths.list <-list();
+
+ # first trim overall.graph to remove no-seed nodes of degree 1
+ dgrs <- degree(overall.graph);
+ keep.inx <- dgrs > 1 | (names(dgrs) %in% my.seeds);
+ nodes2rm <- V(overall.graph)$name[!keep.inx];
+ overall.graph <- simplify(delete.vertices(overall.graph, nodes2rm));
+
+ # need to restrict the operation b/c get.shortest.paths is very time consuming
+ # for top max.len highest degrees
+ if(sd.len > max.len){
+ hit.inx <- names(dgrs) %in% my.seeds;
+ sd.dgrs <- dgrs[hit.inx];
+ sd.dgrs <- rev(sort(sd.dgrs));
+ # need to synchronize all (seed.proteins) and top seeds (my.seeds)
+ seed.proteins <- names(sd.dgrs);
+ if(max.len>table(hit.inx)[["TRUE"]]){
+ sd.len <- table(hit.inx)[["TRUE"]];
+ }else{
+ sd.len <- max.len;
+ }
+ my.seeds <- seed.proteins[1:sd.len];
+ current.msg <<- paste("The minimum connected network was computed using the top", sd.len, "seed proteins in the network based on their degrees.");
+ }else{
+ current.msg <<- paste("The minimum connected network was computed using all seed proteins in the network.");
+ }
+ # now calculate the shortest paths for
+ # each seed vs. all other seeds (note, to remove pairs already calculated previously)
+ for(pos in 1:sd.len){
+ paths.list[[pos]] <- get.shortest.paths(overall.graph, my.seeds[pos], seed.proteins[-(1:pos)])$vpath;
+ }
+ nds.inxs <- unique(unlist(paths.list));
+ nodes2rm <- V(overall.graph)$name[-nds.inxs];
+ g <- simplify(delete.vertices(overall.graph, nodes2rm));
+
+ nodeList <- get.data.frame(g, "vertices");
+ colnames(nodeList) <- c("Id", "Label");
+ fast.write(nodeList, file="orig_node_list.csv", row.names=F);
+
+ edgeList <- get.data.frame(g, "edges");
+ edgeList <- cbind(rownames(edgeList), edgeList);
+ colnames(edgeList) <- c("Id", "Source", "Target");
+ fast.write(edgeList, file="orig_edge_list.csv", row.names=F);
+
+ path.list <- NULL;
+ substats <- DecomposeGraph(g);
+ net.stats<<-net.stats
+ if(!is.null(substats)){
+ overall.graph <<- g;
+ return(c(length(seed.genes),length(seed.proteins), nrow(nodeList), nrow(edgeList), length(ppi.comps), substats));
+ }else{
+ return(0);
+ }
+}
+
+FilterMirNetByList <- function(ids, id.type, remove){
+ # need to fix this function
+ lines <- strsplit(ids, "\r|\n|\r\n")[[1]];
+ lines<- sub("^[[:space:]]*(.*?)[[:space:]]*$", "\\1", lines, perl=TRUE);
+ nms.vec = unique(unlist(dataSet$mir.res[, c(1,2,3,4)]))
+ # need to first convert to correct id used in the graph
+ hit.inx <- nms.vec %in% lines;
+ nodes2rm = nms.vec[hit.inx]
+
+ if(remove== "true"){
+ nodes2rm <- nodes2rm[nodes2rm %in% V(mir.graph)$name]; # make sure they are in the igraph object
+ }else{
+ nodes2rm <- V(mir.graph)$name[!(V(mir.graph)$name %in% nodes2rm)]; # make sure they are in the igraph object
+ }
+ mir.graph <- simplify(delete.vertices(mir.graph, nodes2rm));
+ current.msg <<- paste("A total of", length(nodes2rm) , "was reduced.");
+ substats <- DecomposeMirGraph(mir.graph, 2);
+ if(!is.null(substats)){
+ mir.graph <<- mir.graph;
+ return(c(nrow(dataSet$mir.orig), length(unique(dataSet$mir.filtered[,1])), length(unique(dataSet$mir.filtered[,3])), ecount(mir.graph), length(mir.nets), substats));
+ }else{
+ return(0);
+ }
+}
+
+FilterNetByCor <- function(min.pval, min.qval, neg.coeff1, neg.coeff2, pos.coeff1, pos.coeff2){
+ mSetObj <- .get.mSet(mSetObj);
+ min.pval<<-min.pval;
+ min.qval<<-min.qval;
+ neg.coeff1<<-neg.coeff1;
+ neg.coeff2<<-neg.coeff2;
+ pos.coeff1<<-pos.coeff1;
+ pos.coeff2<<-pos.coeff2;
+ edge.list <- pheno.net$edge.data;
+ if(min.pval > 0){
+ edge.list.filter <- edge.list[which(edge.list$Pval < min.pval),];
+ }
+ if(min.qval > 0){
+ edge.list.filter <- edge.list[which(edge.list$Adj_Pval < min.qval),];
+ }
+ if(neg.coeff1 > -1 || neg.coeff2 < 0 || pos.coeff1 > 0 || pos.coeff2 < 1){
+ edge.list.filter.neg <- edge.list[which(edge.list$Coefficient > neg.coeff1 & edge.list$Coefficient < neg.coeff2),];
+ edge.list.filter.pos <- edge.list[which(edge.list$Coefficient > pos.coeff1 & edge.list$Coefficient < pos.coeff2),];
+ edge.list.filter <- rbind(edge.list.filter.neg, edge.list.filter.pos);
+ }
+ overall.graph <-simplify(graph_from_data_frame(edge.list.filter, directed=FALSE, vertices=NULL), edge.attr.comb="first");
+ current.msg <<- paste("A total of", nrow(edge.list)-nrow(edge.list.filter) , "edges was reduced.");
+ substats <- DecomposeGraph(overall.graph);
+ if(.on.public.web){
+ mSetObj <- .get.mSet(mSetObj);
+ if(!is.null(substats)){
+ overall.graph <<- overall.graph;
+ return(c(length(seed.proteins),length(seed.proteins), vcount(overall.graph), ecount(overall.graph), length(pheno.comps), substats));
+ }else{
+ return(0);
+ }
+ }else{
+ return(.set.mSet(mSetObj));
+ }
+}
+
+FilterBipartiNet <- function(mSetObj=NA, nd.type, min.dgr, min.btw){
+ # need to fix
+ nd.type<<-nd.type;
+ min.dgr<<-min.dgr;
+ min.btw<<-min.btw;
+ mSetObj <- .get.mSet(mSetObj);
+
+ all.nms <- V(overall.graph)$name;
+ edge.mat <- get.edgelist(overall.graph);
+ dgrs <- degree(overall.graph);
+ nodes2rm.dgr <- nodes2rm.btw <- NULL;
+
+ if(nd.type == "gene"){
+ hit.inx <- all.nms %in% edge.mat[,1];
+ }else if(nd.type=="other"){
+ hit.inx <- all.nms %in% edge.mat[,2];
+ }else{ # all
+ hit.inx <- rep(TRUE, length(all.nms));
+ }
+
+ if(min.dgr > 0){
+ rm.inx <- dgrs <= min.dgr & hit.inx;
+ nodes2rm.dgr <- V(overall.graph)$name[rm.inx];
+ }
+ if(min.btw > 0){
+ btws <- betweenness(overall.graph);
+ rm.inx <- btws <= min.btw & hit.inx;
+ nodes2rm.btw <- V(overall.graph)$name[rm.inx];
+ }
+
+ nodes2rm <- unique(c(nodes2rm.dgr, nodes2rm.btw));
+ overall.graph <- simplify(delete.vertices(overall.graph, nodes2rm));
+ current.msg <<- paste("A total of", length(nodes2rm) , "was reduced.");
+ substats <- DecomposeGraph(overall.graph);
+ if(.on.public.web){
+ mSetObj <- .get.mSet(mSetObj);
+ if(!is.null(substats)){
+ overall.graph <<- overall.graph;
+ return(c(length(seed.graph),length(seed.proteins), vcount(overall.graph), ecount(overall.graph), length(pheno.comps), substats));
+ }else{
+ return(0);
+ }
+ }else{
+ return(.set.mSet(mSetObj));
+ }
+}
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/others_lipomics.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/others_lipomics.R
new file mode 100755
index 0000000000000000000000000000000000000000..cec8d79eb111e232421c4878ad66dfb5fff396f7
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/others_lipomics.R
@@ -0,0 +1,257 @@
+#'Lipid analysis pipeliner
+#'@description Lipid analysis pipeliner
+#'@param inFile Input the file to read in
+#'@param iso Default is set to "y"
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+analyze.lipids <- function(inFile, iso='y'){
+ data <- .readDataTable(inFile);
+ computeConc(data, iso);
+}
+
+#'Lipid analysis
+#'@description The upper limit for each combination is considered to be
+#'the minimal of the fatty acid concentration (nmol fatty acid/gram of sample)
+#'X is the lopomics data obtained above
+#'the result is the saved as separate files for each lipid class
+#'@param X Input the data
+#'@param iso Default is set to "y"
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+computeConc<-function(X, iso="y"){
+
+ dg.inx<-X[,2]=='DG';
+ pc.inx<-X[,2]=='PC';
+ pe.inx<-X[,2]=='PE';
+ tg.inx<-X[,2]=='TG'
+
+ if(iso=='y'){
+ if(sum(dg.inx)>0){
+ calculateConcISO(X[dg.inx,-2], 'DG', 2, "DG_uplimit.csv", "DG_prob.csv");
+ }
+ if(sum(pc.inx)>0){
+ calculateConcISO(X[pc.inx,-2], 'PC', 2, "PC_uplimit.csv", "PC_prob.csv");
+ }
+ if(sum(pe.inx)>0){
+ calculateConcISO(X[pe.inx,-2], 'PE', 2, "PE_uplimit.csv", "PE_prob.csv");
+ }
+ if(sum(tg.inx)>0){
+ calculateConcISO(X[tg.inx,-2], 'TG', 3, "TG_uplimit.csv", "TG_prob.csv");
+ }
+ }else{
+ if(sum(dg.inx)>0){
+ calculateConcNoISO(X[dg.inx,-2], 'DG', 2, "DG_uplimit.csv", "DG_prob.csv");
+ }
+ if(sum(pc.inx)>0){
+ calculateConcNoISO(X[pc.inx,-2], 'PC', 2, "PC_uplimit.csv", "PC_prob.csv");
+ }
+ if(sum(pe.inx)>0){
+ calculateConcNoISO(X[pe.inx,-2], 'PE', 2, "PE_uplimit.csv", "PE_prob.csv");
+ }
+ if(sum(tg.inx)>0){
+ calculateConcNoISO(X[tg.inx,-2], 'TG', 3, "TG_uplimit.csv", "TG_prob.csv");
+ }
+ }
+}
+
+#'Calculate Concentration ISO
+#'@description Assuming independent random distribution of FA, the most probable frequency
+#'will be the product of the each component. Note: the data is concentration,
+#'we need to get frequncies - percentage w.r.t the total nmol.
+#'the result is the saved as separate files for each lipid class
+#'data for each FA class, first col is sample name
+#'@param dat Input the data
+#'@param cls.name Input the class names
+#'@param cls.num Input the number of classes
+#'@param min.file Input the min file
+#'@param prob.file Input the prob file
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+calculateConcISO<-function(dat, cls.name, cls.num, min.file, prob.file){
+ lip.nms<-names(dat[,-1]);
+ conc.mat<-data.matrix(dat[,-1]);
+ conc.sum<-apply(conc.mat, 1, sum);
+ percent.mat<-sweep(conc.mat, 1, conc.sum, FUN="/");
+ len.col<-ncol(conc.mat);
+ if(cls.num==2){
+ if(cls.name=='DG'){
+ len<-len.col*(len.col+1)/2; # triangle matrix
+ }else{
+ len<-len.col*len.col; # for PC/PE, AB/BA is not isomer
+ }
+ nm.vec<-vector(mode="character", length=len);
+ min.mat<-matrix(0, nrow=len, ncol=nrow(conc.mat));
+ prob.mat<-matrix(0, nrow=len, ncol=nrow(conc.mat));
+
+ }else if(cls.num==3){
+ len<-len.col*(len.col+1)*(len.col+2)/6; # triangle cube = triangle matrix*height
+ nm.vec<-vector(mode="character", length=len);
+ min.mat<-matrix(0, nrow=len, ncol=nrow(conc.mat));
+ prob.mat<-matrix(0, nrow=len, ncol=nrow(conc.mat));
+ }else{
+ warning("not supported class number");
+ return();
+ }
+ colnames(min.mat)<-dat[,1];
+ colnames(prob.mat)<-dat[,1];
+ col.count <- 0;
+ for(i in 1:nrow(conc.mat)){
+ conc<-as.numeric(conc.mat[i,]);
+ prct<-as.numeric(percent.mat[i,]);
+ col.count<-col.count+1;
+ row.count <- 0;
+ for(m in 1:length(conc)){
+ for(n in m:length(conc)){
+ if(cls.num==3){
+ for(l in n:length(conc)){
+ row.count<-row.count+1;
+ prob.mat[row.count,col.count]<-sum(as.numeric(conc.mat[i,]))*(prct[m]*prct[n]*prct[l]);
+ suffix<-NULL;
+ if(m==n){
+ if(l==n){ # all same
+ minC<-conc[m]/3;
+ }else{
+ minC<-min(conc[m]/2, conc[l])
+ suffix<-"[iso3]";
+ }
+ }else if(m==l || l==n){
+ minC<-min(conc[m]/2, conc[n])
+ suffix<-"[iso3]";
+ }else{
+ minC<-min(conc[m], conc[n], conc[l]);
+ suffix<-"[iso6]";
+ }
+ min.mat[row.count,col.count]<-minC;
+ if(i==1){
+ nm.vec[row.count]<-paste(cls.name, "(", lip.nms[m],"/", lip.nms[n], "/", lip.nms[l],")", suffix, sep="");
+ }
+ }
+ }else{
+ suffix<-NULL;
+ if(m==n){
+ minC<-conc[m]/2;
+ }else{
+ minC<-min(conc[m], conc[n]);
+ suffix<-"[iso2]";
+ }
+ probC<-sum(as.numeric(conc.mat[i,]))*(prct[m]*prct[n]);
+
+ if(cls.name=='DG'){
+ row.count<-row.count+1;
+ min.mat[row.count,col.count]<-minC;
+ prob.mat[row.count,col.count]<-probC;
+ if(i==1){
+ nm.vec[row.count]<-paste(cls.name, "(", lip.nms[m],"/", lip.nms[n], "/0:0)", suffix, sep="");
+ }
+ }else{ # PE/PC don't have iso, need specify
+ row.count<-row.count+1;
+ min.mat[row.count,col.count]<-minC;
+ prob.mat[row.count,col.count]<-probC;
+ if(i==1){
+ nm.vec[row.count]<-paste(cls.name, "(", lip.nms[m],"/", lip.nms[n], ")", sep="");
+ }
+ if(m!=n){ # don't switch position is m and n are the same
+ row.count<-row.count+1;
+ min.mat[row.count,col.count]<-minC;
+ prob.mat[row.count,col.count]<-probC;
+ if(i==1){
+ nm.vec[row.count]<-paste(cls.name, "(", lip.nms[n],"/", lip.nms[m], ")", sep="");
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ rownames(min.mat)<-nm.vec;
+ min.mat<-cbind(min.mat, "Average" = apply(min.mat, 1, mean), "SD" = apply(min.mat, 1, sd));
+ rownames(prob.mat)<-nm.vec;
+ prob.mat<-cbind(prob.mat, "Average" = apply(prob.mat, 1, mean), "SD" = apply(prob.mat, 1, sd));
+ fast.write.csv(min.mat, file=min.file);
+ fast.write.csv(prob.mat, file=prob.file);
+}
+
+calculateConcNoISO<-function(dat, cls.name, cls.num, min.file, prob.file){
+ lip.nms<-names(dat[,-1]);
+ conc.mat<-data.matrix(dat[,-1]);
+ conc.sum<-apply(conc.mat, 1, sum);
+ percent.mat<-sweep(conc.mat, 1, conc.sum, FUN="/");
+ len.col<-ncol(conc.mat);
+ if(cls.num==2){
+ len<-len.col^2; # triangle matrix
+ nm.vec<-vector(mode="character", length=len);
+ min.mat<-matrix(0, nrow=len, ncol=nrow(conc.mat));
+ prob.mat<-matrix(0, nrow=len, ncol=nrow(conc.mat));
+ }else if(cls.num==3){
+ len<-len.col^3; # triangle cube = triangle matrix*height
+ nm.vec<-vector(mode="character", length=len);
+ min.mat<-matrix(0, nrow=len, ncol=nrow(conc.mat));
+ prob.mat<-matrix(0, nrow=len, ncol=nrow(conc.mat));
+ }else{
+ warning("not supported class number");
+ return();
+ }
+ colnames(min.mat)<-dat[,1];
+ colnames(prob.mat)<-dat[,1];
+ col.count <- 0;
+ for(i in 1:nrow(conc.mat)){
+ conc<-as.numeric(conc.mat[i,]);
+ prct<-as.numeric(percent.mat[i,]);
+ col.count<-col.count+1;
+ row.count <- 0;
+ for(m in 1:length(conc)){
+ for(n in 1:length(conc)){
+ if(cls.num==3){
+ for(l in 1:length(conc)){
+ row.count<-row.count+1;
+ prob.mat[row.count,col.count]<-sum(as.numeric(conc.mat[i,]))*(prct[m]*prct[n]*prct[l]);
+ suffix<-NULL;
+ if(m==n){
+ if(l==n){ # all same
+ minC<-conc[m]/3;
+ }else{
+ minC<-min(conc[m]/2, conc[l])
+ }
+ }else if(m==l){
+ minC<-min(conc[m]/2, conc[n])
+ }else{
+ minC<-min(conc[m], conc[n], conc[l]);
+ }
+ min.mat[row.count,col.count]<-minC;
+ nm.vec[row.count]<-paste(cls.name, "(", lip.nms[m],"/", lip.nms[n], "/", lip.nms[l],")", sep="");
+ }
+ }else{
+ if(m==n){
+ minC<-conc[m]/2;
+ }else{
+ minC<-min(conc[m], conc[n]);
+ }
+
+ if(cls.name=='DG'){
+ row.count<-row.count+1;
+ min.mat[row.count,col.count]<-minC;
+ prob.mat[row.count,col.count]<-sum(as.numeric(conc.mat[i,]))*(prct[m]*prct[n]);
+ nm.vec[row.count]<-paste(cls.name, "(", lip.nms[m],"/", lip.nms[n], "/0:0)", sep="");
+ }else{ # PE/PC don't have iso, need specify
+ row.count<-row.count+1;
+ min.mat[row.count,col.count]<-minC;
+ prob.mat[row.count,col.count]<-sum(as.numeric(conc.mat[i,]))*(prct[m]*prct[n]);
+ nm.vec[row.count]<-paste(cls.name, "(", lip.nms[m],"/", lip.nms[n], ")", sep="");
+ }
+ }
+ }
+ }
+ }
+ rownames(min.mat)<-nm.vec;
+ min.mat<-cbind(min.mat, "Average" = apply(min.mat, 1, mean), "SD" = apply(min.mat, 1, sd));
+ rownames(prob.mat)<-nm.vec;
+ prob.mat<-cbind(prob.mat, "Average" = apply(prob.mat, 1, mean), "SD" = apply(prob.mat, 1, sd));
+ fast.write.csv(min.mat, file=min.file);
+ fast.write.csv(prob.mat, file=prob.file);
+}
\ No newline at end of file
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/parameters_db.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/parameters_db.R
new file mode 100755
index 0000000000000000000000000000000000000000..540fb31524039f87eff277b54a9e68978932f9b8
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/parameters_db.R
@@ -0,0 +1,1824 @@
+# Parameter Function
+#' Set parameters for peak profiling and parameters optimization
+#' @description This function sets all the parameters used for downstream
+#' pre-processing of user's raw MS data based on specific LC-MS platform or parameters optimization.
+#' The database will be under an real-time update based on the progress in this field.
+#' @param platform Character, specify the LC-MS platform used in pratice, including "UPLC-Q/E",
+#' "UPLC-Q/TOF","UPLC-T/TOF","UPLC-Ion_Trap","UPLC-Orbitrap","UPLC-G2S","HPLC-Q/TOF","HPLC-Ion_Trap","HPLC-Orbitrap","HPLC-S/Q".
+#' Default is "general", which is a more common option for all platform. If the platform is not listed above, please use this one.
+#' @param Peak_method Character, specify the algorithm to perform peak detection. "centwave"
+#' to use the CentWave algorithm, and "matchedFilter" to use the MatchedFilter algorithm.
+#' @param RT_method Character, specify the algorithm to perform tetention time alignment, including "loess" and "obiwarp".
+#' Default is "loess".
+#' @param ppm Numeric, specify the mass error in ppm.
+#' @param min_peakwidth Numeric, specify the minimum peak width in seconds.Only work for 'centWave'.
+#' @param max_peakwidth Numeric, specify the maximum peak width in seconds.Only work for 'centWave'.
+#' @param snthresh Numeric, specify the signal to noise threshold.
+#' @param mzdiff Numeric, specify the minimum m/z difference for signals to be considered as
+#' different features when retention times are overlapping.
+#' @param bw Numeric, specify the band width (sd or half width at half maximum) of gaussian
+#' smoothing kernel to be applied during peak grouping.
+#' @param noise Numeric, specify the noise level for peaking picking.Only work for 'centWave'.
+#' @param prefilter Numeric, specify the scan number threshold for prefilter.Only work for 'centWave'.
+#' @param value_of_prefilter Numeric, specify the scan abundance threshold for prefilter. Only work for 'centWave'.
+#' @param fwhm numeric specifying the full width at half maximum of matched filtration gaussian model peak. Only work for 'matchedFilter'.
+#' @param steps numeric defining the number of bins to be merged before filtration. Only work for 'matchedFilter'.
+#' @param sigma numeric specifying the standard deviation (width) of the matched filtration model peak. Only work for 'matchedFilter'.
+#' @param profStep numeric defining the bin size (in mz dimension) to be used for the profile matrix generation. Only work for 'obiwarp'.
+#' @param minFraction Numeric, specify fraction of samples in each group that contain the feature for it to be grouped.
+#' @param minSamples Numeric, specify minimum number of sample(s) in each group that contain the feature for it to be included.
+#' @param maxFeatures Numeric, specify the maximum number of features to be identified.
+#' @param ... Other parameters, including max,extra,span,smooth,family,fitgauss, verbose.columns,mzCenterFun,integrate. Usually don't
+#' need to change.
+#' @author Zhiqiang Pang \email{zhiqiang.pang@mail.mcgill.ca}, Jasmine Chong \email{jasmine.chong@mail.mcgill.ca},
+#' Mai Yamamoto \email{yamamoto.mai@mail.mcgill.ca}, and Jeff Xia \email{jeff.xia@mcgill.ca}
+#' McGill University, Canada
+#' License: GNU GPL (>= 2)
+#' @export
+
+SetPeakParam <- function(platform = "general",Peak_method = "centWave",RT_method = "loess",
+ mzdiff,snthresh,bw,
+ ppm,min_peakwidth,max_peakwidth,noise,prefilter,value_of_prefilter,
+ fwhm,steps,sigma,
+ profStep,minFraction,minSamples,maxFeatures,
+ max,extra,span,smooth,family,fitgauss,
+ verbose.columns,mzCenterFun,integrate,
+ ...){
+ peakParams <- list()
+ if (missing(platform)){
+ platform<-"general"
+ } else{
+ match.arg(arg = platform ,choices = c("general","UPLC-Q/E","UPLC-Q/TOF","UPLC-T/TOF",
+ "UPLC-Ion_Trap","UPLC-Orbitrap","UPLC-G2S",
+ "HPLC-Q/TOF","HPLC-Ion_Trap","HPLC-Orbitrap",
+ "HPLC-S/Q"))
+ }
+ ### Platform Selection--UPLC----
+ if (platform=="UPLC-Q/E"){
+ if (missing(Peak_method)){
+ peakParams$Peak_method <- "centWave"
+ } else{
+ peakParams$Peak_method <- Peak_method;
+ };
+ if (missing(RT_method)){
+ peakParams$RT_method <- "peakgroup"
+ } else{
+ peakParams$RT_method <- RT_method;
+ };
+ ## Parameters for Peakpicking
+ if (Peak_method=="centWave"){
+ if (missing(ppm)){
+ peakParams$ppm <- 5;
+ } else{
+ peakParams$ppm <- ppm;
+ };
+ if (missing(min_peakwidth)){
+ peakParams$min_peakwidth <- 5;
+ } else{
+ peakParams$min_peakwidth <- min_peakwidth;
+ };
+ if (missing(max_peakwidth)){
+ peakParams$max_peakwidth <- 20;
+ } else{
+ peakParams$max_peakwidth <- max_peakwidth;
+ };
+ if (missing(mzdiff)){
+ peakParams$mzdiff <- 0.01;
+ } else{
+ peakParams$mzdiff <- mzdiff;
+ };
+ if (missing(snthresh)){
+ peakParams$snthresh <- 4;
+ } else{
+ peakParams$snthresh <- snthresh;
+ };
+ if (missing(noise)){
+ peakParams$noise <- 0;
+ } else{
+ peakParams$noise <- noise
+ };
+ if (missing(prefilter)){
+ peakParams$prefilter <- 3;
+ } else{
+ peakParams$prefilter <- prefilter
+ };
+ if (missing(value_of_prefilter)){
+ peakParams$value_of_prefilter <- 100;
+ } else{
+ peakParams$value_of_prefilter <- value_of_prefilter
+ };
+ }
+ if (Peak_method=="matchedFilter"){
+ if (missing(fwhm)){
+ peakParams$fwhm <- 30;
+ } else{
+ peakParams$fwhm <- fwhm
+ };
+ if (missing(sigma)){
+ peakParams$sigma <- 12.74;
+ } else{
+ peakParams$sigma <- sigma
+ };
+ if (missing(steps)){
+ peakParams$steps <- 2;
+ } else{
+ peakParams$steps <- steps
+ };
+ if (missing(max)){
+ peakParams$max <- 10;
+ } else{
+ peakParams$max <- max
+ };
+ if (missing(snthresh)){
+ peakParams$snthresh <- 10;
+ } else{
+ peakParams$snthresh <- snthresh
+ };
+ if (missing(mzdiff)){
+ peakParams$mzdiff <- 0.01;
+ } else{
+ peakParams$mzdiff <- mzdiff;
+ };
+ };
+ ## Parameters for Grouping-Density Method Only
+ if (missing(bw)){
+ peakParams$bw <- 30;
+ } else{
+ peakParams$bw <- bw;
+ };
+ if (missing(minFraction)){
+ peakParams$minFraction <- 0.5;
+ } else{
+ peakParams$minFraction <- minFraction
+ };
+ if (missing(minSamples)){
+ peakParams$minSamples <- 1;
+ } else{
+ peakParams$minSamples <- minSamples
+ };
+ if (missing(maxFeatures)){
+ peakParams$maxFeatures <- 100;
+ } else{
+ peakParams$maxFeatures <- maxFeatures
+ };
+ if (missing(fitgauss)){
+ peakParams$fitgauss<-FALSE
+ } else {
+ peakParams$fitgauss<-fitgauss
+ };
+ if (missing(verbose.columns)){
+ peakParams$verbose.columns<-FALSE
+ } else {
+ peakParams$verbose.columns<-verbose.columns
+ };
+ if (missing(mzCenterFun)){
+ peakParams$mzCenterFun<-"wMean"
+ } else {
+ peakParams$mzCenterFun<-mzCenterFun
+ };
+ if (missing(integrate)){
+ peakParams$integrate<-1
+ } else {
+ peakParams$integrate<-integrate
+ }
+ ## Parameters for RT correction
+ if (RT_method=="loess"){
+ if (missing(extra)){
+ peakParams$extra <- 1;
+ } else{
+ peakParams$extra <- extra
+ };
+ if (missing(span)){
+ peakParams$span <- 0.4;
+ } else{
+ peakParams$span <- span
+ };
+ if (missing(smooth)){
+ peakParams$smooth <- "loess";
+ } else{
+ peakParams$smooth <- smooth
+ };
+ if (missing(family)){
+ peakParams$family <- "gaussian";
+ } else{
+ peakParams$family <- family
+ };
+ }
+ if (RT_method=="obiwarp"){
+ if (missing(profStep)){
+ peakParams$profStep <- 1;
+ } else{
+ peakParams$profStep <- profStep
+ };
+ # Set profStep only here, profStep equals binsize
+ # other parameters use default
+ }
+ }
+ if (platform=="UPLC-Q/TOF"){
+ if (missing(Peak_method)){
+ peakParams$Peak_method <- "centWave"
+ } else{
+ peakParams$Peak_method <- Peak_method;
+ };
+ if (missing(RT_method)){
+ peakParams$RT_method <- "peakgroup"
+ } else{
+ peakParams$RT_method <- RT_method;
+ };
+ ## Parameters for Peakpicking
+ if (Peak_method=="centWave"){
+ if (missing(ppm)){
+ peakParams$ppm <- 15;
+ } else{
+ peakParams$ppm <- ppm;
+ };
+ if (missing(min_peakwidth)){
+ peakParams$min_peakwidth <- 5;
+ } else{
+ peakParams$min_peakwidth <- min_peakwidth;
+ };
+ if (missing(max_peakwidth)){
+ peakParams$max_peakwidth <- 20;
+ } else{
+ peakParams$max_peakwidth <- max_peakwidth;
+ };
+ if (missing(mzdiff)){
+ peakParams$mzdiff <- 0.01;
+ } else{
+ peakParams$mzdiff <- mzdiff;
+ };
+ if (missing(snthresh)){
+ peakParams$snthresh <- 6;
+ } else{
+ peakParams$snthresh <- snthresh;
+ };
+ if (missing(noise)){
+ peakParams$noise <- 1000;
+ } else{
+ peakParams$noise <- noise
+ };
+ if (missing(prefilter)){
+ peakParams$prefilter <- 3;
+ } else{
+ peakParams$prefilter <- prefilter
+ };
+ if (missing(value_of_prefilter)){
+ peakParams$value_of_prefilter <- 100;
+ } else{
+ peakParams$value_of_prefilter <- value_of_prefilter
+ };
+ }
+ if (Peak_method=="matchedFilter"){
+ if (missing(fwhm)){
+ peakParams$fwhm <- 30;
+ } else{
+ peakParams$fwhm <- fwhm
+ };
+ if (missing(sigma)){
+ peakParams$sigma <- 12.74;
+ } else{
+ peakParams$sigma <- sigma
+ };
+ if (missing(steps)){
+ peakParams$steps <- 2;
+ } else{
+ peakParams$steps <- steps
+ };
+ if (missing(max)){
+ peakParams$max <- 10;
+ } else{
+ peakParams$max <- max
+ };
+ if (missing(snthresh)){
+ peakParams$snthresh <- 10;
+ } else{
+ peakParams$snthresh <- snthresh
+ };
+ if (missing(mzdiff)){
+ peakParams$mzdiff <- 0.01;
+ } else{
+ peakParams$mzdiff <- mzdiff;
+ };
+ };
+ ## Parameters for Grouping-Density Method Only
+ if (missing(bw)){
+ peakParams$bw <- 30;
+ } else{
+ peakParams$bw <- bw;
+ };
+ if (missing(minFraction)){
+ peakParams$minFraction <- 0.5;
+ } else{
+ peakParams$minFraction <- minFraction
+ };
+ if (missing(minSamples)){
+ peakParams$minSamples <- 1;
+ } else{
+ peakParams$minSamples <- minSamples
+ };
+ if (missing(maxFeatures)){
+ peakParams$maxFeatures <- 100;
+ } else{
+ peakParams$maxFeatures <- maxFeatures
+ };
+ if (missing(fitgauss)){
+ peakParams$fitgauss<-FALSE
+ } else {
+ peakParams$fitgauss<-fitgauss
+ };
+ if (missing(verbose.columns)){
+ peakParams$verbose.columns<-FALSE
+ } else {
+ peakParams$verbose.columns<-verbose.columns
+ };
+ if (missing(mzCenterFun)){
+ peakParams$mzCenterFun<-"wMean"
+ } else {
+ peakParams$mzCenterFun<-mzCenterFun
+ };
+ if (missing(integrate)){
+ peakParams$integrate<-1
+ } else {
+ peakParams$integrate<-integrate
+ }
+ ## Parameters for RT correction
+ if (RT_method=="loess"){
+ if (missing(extra)){
+ peakParams$extra <- 1;
+ } else{
+ peakParams$extra <- extra
+ };
+ if (missing(span)){
+ peakParams$span <- 0.4;
+ } else{
+ peakParams$span <- span
+ };
+ if (missing(smooth)){
+ peakParams$smooth <- "loess";
+ } else{
+ peakParams$smooth <- smooth
+ };
+ if (missing(family)){
+ peakParams$family <- "gaussian";
+ } else{
+ peakParams$family <- family
+ };
+ }
+ if (RT_method=="obiwarp"){
+ if (missing(profStep)){
+ peakParams$profStep <- 1;
+ } else{
+ peakParams$profStep <- profStep
+ };
+ # Set profStep only here, profStep equals binsize
+ # other parameters use default
+ }
+ }
+ if (platform=="UPLC-T/TOF"){
+ if (missing(Peak_method)){
+ peakParams$Peak_method <- "centWave"
+ } else{
+ peakParams$Peak_method <- Peak_method;
+ };
+ if (missing(RT_method)){
+ peakParams$RT_method <- "peakgroup"
+ } else{
+ peakParams$RT_method <- RT_method;
+ };
+ ## Parameters for Peakpicking
+ if (Peak_method=="centWave"){
+ if (missing(ppm)){
+ peakParams$ppm <- 15;
+ } else{
+ peakParams$ppm <- ppm;
+ };
+ if (missing(min_peakwidth)){
+ peakParams$min_peakwidth <- 5;
+ } else{
+ peakParams$min_peakwidth <- min_peakwidth;
+ };
+ if (missing(max_peakwidth)){
+ peakParams$max_peakwidth <- 20;
+ } else{
+ peakParams$max_peakwidth <- max_peakwidth;
+ };
+ if (missing(mzdiff)){
+ peakParams$mzdiff <- 0.01;
+ } else{
+ peakParams$mzdiff <- mzdiff;
+ };
+ if (missing(snthresh)){
+ peakParams$snthresh <- 6;
+ } else{
+ peakParams$snthresh <- snthresh;
+ };
+ if (missing(noise)){
+ peakParams$noise <- 0;
+ } else{
+ peakParams$noise <- noise
+ };
+ if (missing(prefilter)){
+ peakParams$prefilter <- 3;
+ } else{
+ peakParams$prefilter <- prefilter
+ };
+ if (missing(value_of_prefilter)){
+ peakParams$value_of_prefilter <- 100;
+ } else{
+ peakParams$value_of_prefilter <- value_of_prefilter
+ };
+ }
+ if (Peak_method=="matchedFilter"){
+ if (missing(fwhm)){
+ peakParams$fwhm <- 30;
+ } else{
+ peakParams$fwhm <- fwhm
+ };
+ if (missing(sigma)){
+ peakParams$sigma <- 12.74;
+ } else{
+ peakParams$sigma <- sigma
+ };
+ if (missing(steps)){
+ peakParams$steps <- 2;
+ } else{
+ peakParams$steps <- steps
+ };
+ if (missing(max)){
+ peakParams$max <- 10;
+ } else{
+ peakParams$max <- max
+ };
+ if (missing(snthresh)){
+ peakParams$snthresh <- 10;
+ } else{
+ peakParams$snthresh <- snthresh
+ };
+ if (missing(mzdiff)){
+ peakParams$mzdiff <- 0.01;
+ } else{
+ peakParams$mzdiff <- mzdiff;
+ };
+ };
+ ## Parameters for Grouping-Density Method Only
+ if (missing(bw)){
+ peakParams$bw <- 30;
+ } else{
+ peakParams$bw <- bw;
+ };
+ if (missing(minFraction)){
+ peakParams$minFraction <- 0.5;
+ } else{
+ peakParams$minFraction <- minFraction
+ };
+ if (missing(minSamples)){
+ peakParams$minSamples <- 1;
+ } else{
+ peakParams$minSamples <- minSamples
+ };
+ if (missing(maxFeatures)){
+ peakParams$maxFeatures <- 100;
+ } else{
+ peakParams$maxFeatures <- maxFeatures
+ };
+ if (missing(fitgauss)){
+ peakParams$fitgauss<-FALSE
+ } else {
+ peakParams$fitgauss<-fitgauss
+ };
+ if (missing(verbose.columns)){
+ peakParams$verbose.columns<-FALSE
+ } else {
+ peakParams$verbose.columns<-verbose.columns
+ };
+ if (missing(mzCenterFun)){
+ peakParams$mzCenterFun<-"wMean"
+ } else {
+ peakParams$mzCenterFun<-mzCenterFun
+ };
+ if (missing(integrate)){
+ peakParams$integrate<-1
+ } else {
+ peakParams$integrate<-integrate
+ }
+ ## Parameters for RT correction
+ if (RT_method=="loess"){
+ if (missing(extra)){
+ peakParams$extra <- 1;
+ } else{
+ peakParams$extra <- extra
+ };
+ if (missing(span)){
+ peakParams$span <- 0.4;
+ } else{
+ peakParams$span <- span
+ };
+ if (missing(smooth)){
+ peakParams$smooth <- "loess";
+ } else{
+ peakParams$smooth <- smooth
+ };
+ if (missing(family)){
+ peakParams$family <- "gaussian";
+ } else{
+ peakParams$family <- family
+ };
+ }
+ if (RT_method=="obiwarp"){
+ if (missing(profStep)){
+ peakParams$profStep <- 1;
+ } else{
+ peakParams$profStep <- profStep
+ };
+ # Set profStep only here, profStep equals binsize
+ # other parameters use default
+ }
+ }
+ if (platform=="UPLC-Ion_Trap"){
+ if (missing(Peak_method)){
+ peakParams$Peak_method <- "centWave"
+ } else{
+ peakParams$Peak_method <- Peak_method;
+ };
+ if (missing(RT_method)){
+ peakParams$RT_method <- "peakgroup"
+ } else{
+ peakParams$RT_method <- RT_method;
+ };
+ ## Parameters for Peakpicking
+ if (Peak_method=="centWave"){
+ if (missing(ppm)){
+ peakParams$ppm <- 50;
+ } else{
+ peakParams$ppm <- ppm;
+ };
+ if (missing(min_peakwidth)){
+ peakParams$min_peakwidth <- 5;
+ } else{
+ peakParams$min_peakwidth <- min_peakwidth;
+ };
+ if (missing(max_peakwidth)){
+ peakParams$max_peakwidth <- 20;
+ } else{
+ peakParams$max_peakwidth <- max_peakwidth;
+ };
+ if (missing(mzdiff)){
+ peakParams$mzdiff <- 0.01;
+ } else{
+ peakParams$mzdiff <- mzdiff;
+ };
+ if (missing(snthresh)){
+ peakParams$snthresh <- 4;
+ } else{
+ peakParams$snthresh <- snthresh;
+ };
+ if (missing(noise)){
+ peakParams$noise <- 0;
+ } else{
+ peakParams$noise <- noise
+ };
+ if (missing(prefilter)){
+ peakParams$prefilter <- 3;
+ } else{
+ peakParams$prefilter <- prefilter
+ };
+ if (missing(value_of_prefilter)){
+ peakParams$value_of_prefilter <- 100;
+ } else{
+ peakParams$value_of_prefilter <- value_of_prefilter
+ };
+ }
+ if (Peak_method=="matchedFilter"){
+ if (missing(fwhm)){
+ peakParams$fwhm <- 30;
+ } else{
+ peakParams$fwhm <- fwhm
+ };
+ if (missing(sigma)){
+ peakParams$sigma <- 12.74;
+ } else{
+ peakParams$sigma <- sigma
+ };
+ if (missing(steps)){
+ peakParams$steps <- 2;
+ } else{
+ peakParams$steps <- steps
+ };
+ if (missing(max)){
+ peakParams$max <- 10;
+ } else{
+ peakParams$max <- max
+ };
+ if (missing(snthresh)){
+ peakParams$snthresh <- 10;
+ } else{
+ peakParams$snthresh <- snthresh
+ };
+ if (missing(mzdiff)){
+ peakParams$mzdiff <- 0.01;
+ } else{
+ peakParams$mzdiff <- mzdiff;
+ };
+ };
+ ## Parameters for Grouping-Density Method Only
+ if (missing(bw)){
+ peakParams$bw <- 30;
+ } else{
+ peakParams$bw <- bw;
+ };
+ if (missing(minFraction)){
+ peakParams$minFraction <- 0.5;
+ } else{
+ peakParams$minFraction <- minFraction
+ };
+ if (missing(minSamples)){
+ peakParams$minSamples <- 1;
+ } else{
+ peakParams$minSamples <- minSamples
+ };
+ if (missing(maxFeatures)){
+ peakParams$maxFeatures <- 100;
+ } else{
+ peakParams$maxFeatures <- maxFeatures
+ };
+ if (missing(fitgauss)){
+ peakParams$fitgauss<-FALSE
+ } else {
+ peakParams$fitgauss<-fitgauss
+ };
+ if (missing(verbose.columns)){
+ peakParams$verbose.columns<-FALSE
+ } else {
+ peakParams$verbose.columns<-verbose.columns
+ };
+ if (missing(mzCenterFun)){
+ peakParams$mzCenterFun<-"wMean"
+ } else {
+ peakParams$mzCenterFun<-mzCenterFun
+ };
+ if (missing(integrate)){
+ peakParams$integrate<-1
+ } else {
+ peakParams$integrate<-integrate
+ }
+ ## Parameters for RT correction
+ if (RT_method=="loess"){
+ if (missing(extra)){
+ peakParams$extra <- 1;
+ } else{
+ peakParams$extra <- extra
+ };
+ if (missing(span)){
+ peakParams$span <- 0.4;
+ } else{
+ peakParams$span <- span
+ };
+ if (missing(smooth)){
+ peakParams$smooth <- "loess";
+ } else{
+ peakParams$smooth <- smooth
+ };
+ if (missing(family)){
+ peakParams$family <- "gaussian";
+ } else{
+ peakParams$family <- family
+ };
+ }
+ if (RT_method=="obiwarp"){
+ if (missing(profStep)){
+ peakParams$profStep <- 1;
+ } else{
+ peakParams$profStep <- profStep
+ };
+ # Set profStep only here, profStep equals binsize
+ # other parameters use default
+ }
+ }
+ if (platform=="UPLC-Orbitrap"){
+ if (missing(Peak_method)){
+ peakParams$Peak_method <- "centWave"
+ } else{
+ peakParams$Peak_method <- Peak_method;
+ };
+ if (missing(RT_method)){
+ peakParams$RT_method <- "peakgroup"
+ } else{
+ peakParams$RT_method <- RT_method;
+ };
+ ## Parameters for Peakpicking
+ if (Peak_method=="centWave"){
+ if (missing(ppm)){
+ peakParams$ppm <- 2.5;
+ } else{
+ peakParams$ppm <- ppm;
+ };
+ if (missing(min_peakwidth)){
+ peakParams$min_peakwidth <- 5;
+ } else{
+ peakParams$min_peakwidth <- min_peakwidth;
+ };
+ if (missing(max_peakwidth)){
+ peakParams$max_peakwidth <- 20;
+ } else{
+ peakParams$max_peakwidth <- max_peakwidth;
+ };
+ if (missing(mzdiff)){
+ peakParams$mzdiff <- 0.01;
+ } else{
+ peakParams$mzdiff <- mzdiff;
+ };
+ if (missing(snthresh)){
+ peakParams$snthresh <- 10;
+ } else{
+ peakParams$snthresh <- snthresh;
+ };
+ if (missing(noise)){
+ peakParams$noise <- 1000;
+ } else{
+ peakParams$noise <- noise
+ };
+ if (missing(prefilter)){
+ peakParams$prefilter <- 3;
+ } else{
+ peakParams$prefilter <- prefilter
+ };
+ if (missing(value_of_prefilter)){
+ peakParams$value_of_prefilter <- 5000;
+ } else{
+ peakParams$value_of_prefilter <- value_of_prefilter
+ };
+ }
+ if (Peak_method=="matchedFilter"){
+ if (missing(fwhm)){
+ peakParams$fwhm <- 30;
+ } else{
+ peakParams$fwhm <- fwhm
+ };
+ if (missing(sigma)){
+ peakParams$sigma <- 12.74;
+ } else{
+ peakParams$sigma <- sigma
+ };
+ if (missing(steps)){
+ peakParams$steps <- 2;
+ } else{
+ peakParams$steps <- steps
+ };
+ if (missing(max)){
+ peakParams$max <- 10;
+ } else{
+ peakParams$max <- max
+ };
+ if (missing(snthresh)){
+ peakParams$snthresh <- 10;
+ } else{
+ peakParams$snthresh <- snthresh
+ };
+ if (missing(mzdiff)){
+ peakParams$mzdiff <- 0.01;
+ } else{
+ peakParams$mzdiff <- mzdiff;
+ };
+ };
+ ## Parameters for Grouping-Density Method Only
+ if (missing(bw)){
+ peakParams$bw <- 30;
+ } else{
+ peakParams$bw <- bw;
+ };
+ if (missing(minFraction)){
+ peakParams$minFraction <- 0.5;
+ } else{
+ peakParams$minFraction <- minFraction
+ };
+ if (missing(minSamples)){
+ peakParams$minSamples <- 1;
+ } else{
+ peakParams$minSamples <- minSamples
+ };
+ if (missing(maxFeatures)){
+ peakParams$maxFeatures <- 100;
+ } else{
+ peakParams$maxFeatures <- maxFeatures
+ };
+ if (missing(fitgauss)){
+ peakParams$fitgauss<-FALSE
+ } else {
+ peakParams$fitgauss<-fitgauss
+ };
+ if (missing(verbose.columns)){
+ peakParams$verbose.columns<-FALSE
+ } else {
+ peakParams$verbose.columns<-verbose.columns
+ };
+ if (missing(mzCenterFun)){
+ peakParams$mzCenterFun<-"wMean"
+ } else {
+ peakParams$mzCenterFun<-mzCenterFun
+ };
+ if (missing(integrate)){
+ peakParams$integrate<-1
+ } else {
+ peakParams$integrate<-integrate
+ }
+ ## Parameters for RT correction
+ if (RT_method=="loess"){
+ if (missing(extra)){
+ peakParams$extra <- 1;
+ } else{
+ peakParams$extra <- extra
+ };
+ if (missing(span)){
+ peakParams$span <- 0.4;
+ } else{
+ peakParams$span <- span
+ };
+ if (missing(smooth)){
+ peakParams$smooth <- "loess";
+ } else{
+ peakParams$smooth <- smooth
+ };
+ if (missing(family)){
+ peakParams$family <- "gaussian";
+ } else{
+ peakParams$family <- family
+ };
+ }
+ if (RT_method=="obiwarp"){
+ if (missing(profStep)){
+ peakParams$profStep <- 1;
+ } else{
+ peakParams$profStep <- profStep
+ };
+ # Set profStep only here, profStep equals binsize
+ # other parameters use default
+ }
+ }
+ if (platform=="UPLC-G2S"){
+ if (missing(Peak_method)){
+ peakParams$Peak_method <- "centWave"
+ } else{
+ peakParams$Peak_method <- Peak_method;
+ };
+ if (missing(RT_method)){
+ peakParams$RT_method <- "peakgroup"
+ } else{
+ peakParams$RT_method <- RT_method;
+ };
+ ## Parameters for Peakpicking
+ if (Peak_method=="centWave"){
+ if (missing(ppm)){
+ peakParams$ppm <- 15;
+ } else{
+ peakParams$ppm <- ppm;
+ };
+ if (missing(min_peakwidth)){
+ peakParams$min_peakwidth <- 2;
+ } else{
+ peakParams$min_peakwidth <- min_peakwidth;
+ };
+ if (missing(max_peakwidth)){
+ peakParams$max_peakwidth <- 25;
+ } else{
+ peakParams$max_peakwidth <- max_peakwidth;
+ };
+ if (missing(mzdiff)){
+ peakParams$mzdiff <- 0.01;
+ } else{
+ peakParams$mzdiff <- mzdiff;
+ };
+ if (missing(snthresh)){
+ peakParams$snthresh <- 10;
+ } else{
+ peakParams$snthresh <- snthresh;
+ };
+ if (missing(noise)){
+ peakParams$noise <- 1000;
+ } else{
+ peakParams$noise <- noise
+ };
+ if (missing(prefilter)){
+ peakParams$prefilter <- 3;
+ } else{
+ peakParams$prefilter <- prefilter
+ };
+ if (missing(value_of_prefilter)){
+ peakParams$value_of_prefilter <- 500;
+ } else{
+ peakParams$value_of_prefilter <- value_of_prefilter
+ };
+ }
+ if (Peak_method=="matchedFilter"){
+ if (missing(fwhm)){
+ peakParams$fwhm <- 30;
+ } else{
+ peakParams$fwhm <- fwhm
+ };
+ if (missing(sigma)){
+ peakParams$sigma <- 12.74;
+ } else{
+ peakParams$sigma <- sigma
+ };
+ if (missing(steps)){
+ peakParams$steps <- 2;
+ } else{
+ peakParams$steps <- steps
+ };
+ if (missing(max)){
+ peakParams$max <- 10;
+ } else{
+ peakParams$max <- max
+ };
+ if (missing(snthresh)){
+ peakParams$snthresh <- 10;
+ } else{
+ peakParams$snthresh <- snthresh
+ };
+ if (missing(mzdiff)){
+ peakParams$mzdiff <- 0.01;
+ } else{
+ peakParams$mzdiff <- mzdiff;
+ };
+ };
+ ## Parameters for Grouping-Density Method Only
+ if (missing(bw)){
+ peakParams$bw <- 30;
+ } else{
+ peakParams$bw <- bw;
+ };
+ if (missing(minFraction)){
+ peakParams$minFraction <- 0.5;
+ } else{
+ peakParams$minFraction <- minFraction
+ };
+ if (missing(minSamples)){
+ peakParams$minSamples <- 1;
+ } else{
+ peakParams$minSamples <- minSamples
+ };
+ if (missing(maxFeatures)){
+ peakParams$maxFeatures <- 100;
+ } else{
+ peakParams$maxFeatures <- maxFeatures
+ };
+ if (missing(fitgauss)){
+ peakParams$fitgauss<-FALSE
+ } else {
+ peakParams$fitgauss<-fitgauss
+ };
+ if (missing(verbose.columns)){
+ peakParams$verbose.columns<-FALSE
+ } else {
+ peakParams$verbose.columns<-verbose.columns
+ };
+ if (missing(mzCenterFun)){
+ peakParams$mzCenterFun<-"wMean"
+ } else {
+ peakParams$mzCenterFun<-mzCenterFun
+ };
+ if (missing(integrate)){
+ peakParams$integrate<-1
+ } else {
+ peakParams$integrate<-integrate
+ }
+ ## Parameters for RT correction
+ if (RT_method=="loess"){
+ if (missing(extra)){
+ peakParams$extra <- 1;
+ } else{
+ peakParams$extra <- extra
+ };
+ if (missing(span)){
+ peakParams$span <- 0.4;
+ } else{
+ peakParams$span <- span
+ };
+ if (missing(smooth)){
+ peakParams$smooth <- "loess";
+ } else{
+ peakParams$smooth <- smooth
+ };
+ if (missing(family)){
+ peakParams$family <- "gaussian";
+ } else{
+ peakParams$family <- family
+ };
+ }
+ if (RT_method=="obiwarp"){
+ if (missing(profStep)){
+ peakParams$profStep <- 0.5;
+ } else{
+ peakParams$profStep <- profStep
+ };
+ # Set profStep only here, profStep equals binsize
+ # other parameters use default
+ }
+ }
+ ### Platform Selection--HPLC----
+ if (platform=="HPLC-Q/TOF"){
+ if (missing(Peak_method)){
+ peakParams$Peak_method <- "centWave"
+ } else{
+ peakParams$Peak_method <- Peak_method;
+ };
+ if (missing(RT_method)){
+ peakParams$RT_method <- "peakgroup"
+ } else{
+ peakParams$RT_method <- RT_method;
+ };
+ ## Parameters for Peakpicking
+ if (Peak_method=="centWave"){
+ if (missing(ppm)){
+ peakParams$ppm <- 30;
+ } else{
+ peakParams$ppm <- ppm;
+ };
+ if (missing(min_peakwidth)){
+ peakParams$min_peakwidth <- 10;
+ } else{
+ peakParams$min_peakwidth <- min_peakwidth;
+ };
+ if (missing(max_peakwidth)){
+ peakParams$max_peakwidth <- 60;
+ } else{
+ peakParams$max_peakwidth <- max_peakwidth;
+ };
+ if (missing(mzdiff)){
+ peakParams$mzdiff <- 0.01;
+ } else{
+ peakParams$mzdiff <- mzdiff;
+ };
+ if (missing(snthresh)){
+ peakParams$snthresh <- 6;
+ } else{
+ peakParams$snthresh <- snthresh;
+ };
+ if (missing(noise)){
+ peakParams$noise <- 1000;
+ } else{
+ peakParams$noise <- noise
+ };
+ if (missing(prefilter)){
+ peakParams$prefilter <- 3;
+ } else{
+ peakParams$prefilter <- prefilter
+ };
+ if (missing(value_of_prefilter)){
+ peakParams$value_of_prefilter <- 500;
+ } else{
+ peakParams$value_of_prefilter <- value_of_prefilter
+ };
+ }
+ if (Peak_method=="matchedFilter"){
+ if (missing(fwhm)){
+ peakParams$fwhm <- 30;
+ } else{
+ peakParams$fwhm <- fwhm
+ };
+ if (missing(sigma)){
+ peakParams$sigma <- 12.74;
+ } else{
+ peakParams$sigma <- sigma
+ };
+ if (missing(steps)){
+ peakParams$steps <- 2;
+ } else{
+ peakParams$steps <- steps
+ };
+ if (missing(max)){
+ peakParams$max <- 10;
+ } else{
+ peakParams$max <- max
+ };
+ if (missing(snthresh)){
+ peakParams$snthresh <- 10;
+ } else{
+ peakParams$snthresh <- snthresh
+ };
+ if (missing(mzdiff)){
+ peakParams$mzdiff <- 0.01;
+ } else{
+ peakParams$mzdiff <- mzdiff;
+ };
+ };
+ ## Parameters for Grouping-Density Method Only
+ if (missing(bw)){
+ peakParams$bw <- 30;
+ } else{
+ peakParams$bw <- bw;
+ };
+ if (missing(minFraction)){
+ peakParams$minFraction <- 0.5;
+ } else{
+ peakParams$minFraction <- minFraction
+ };
+ if (missing(minSamples)){
+ peakParams$minSamples <- 1;
+ } else{
+ peakParams$minSamples <- minSamples
+ };
+ if (missing(maxFeatures)){
+ peakParams$maxFeatures <- 100;
+ } else{
+ peakParams$maxFeatures <- maxFeatures
+ };
+ if (missing(fitgauss)){
+ peakParams$fitgauss<-FALSE
+ } else {
+ peakParams$fitgauss<-fitgauss
+ };
+ if (missing(verbose.columns)){
+ peakParams$verbose.columns<-FALSE
+ } else {
+ peakParams$verbose.columns<-verbose.columns
+ };
+ if (missing(mzCenterFun)){
+ peakParams$mzCenterFun<-"wMean"
+ } else {
+ peakParams$mzCenterFun<-mzCenterFun
+ };
+ if (missing(integrate)){
+ peakParams$integrate<-1
+ } else {
+ peakParams$integrate<-integrate
+ }
+ ## Parameters for RT correction
+ if (RT_method=="loess"){
+ if (missing(extra)){
+ peakParams$extra <- 1;
+ } else{
+ peakParams$extra <- extra
+ };
+ if (missing(span)){
+ peakParams$span <- 0.4;
+ } else{
+ peakParams$span <- span
+ };
+ if (missing(smooth)){
+ peakParams$smooth <- "loess";
+ } else{
+ peakParams$smooth <- smooth
+ };
+ if (missing(family)){
+ peakParams$family <- "gaussian";
+ } else{
+ peakParams$family <- family
+ };
+ }
+ if (RT_method=="obiwarp"){
+ if (missing(profStep)){
+ peakParams$profStep <- 1;
+ } else{
+ peakParams$profStep <- profStep
+ };
+ # Set profStep only here, profStep equals binsize
+ # other parameters use default
+ }
+ }
+ if (platform=="HPLC-Ion_Trap"){
+ if (missing(Peak_method)){
+ peakParams$Peak_method <- "centWave"
+ } else{
+ peakParams$Peak_method <- Peak_method;
+ };
+ if (missing(RT_method)){
+ peakParams$RT_method <- "peakgroup"
+ } else{
+ peakParams$RT_method <- RT_method;
+ };
+ ## Parameters for Peakpicking
+ if (Peak_method=="centWave"){
+ if (missing(ppm)){
+ peakParams$ppm <- 50;
+ } else{
+ peakParams$ppm <- ppm;
+ };
+ if (missing(min_peakwidth)){
+ peakParams$min_peakwidth <- 10;
+ } else{
+ peakParams$min_peakwidth <- min_peakwidth;
+ };
+ if (missing(max_peakwidth)){
+ peakParams$max_peakwidth <- 60;
+ } else{
+ peakParams$max_peakwidth <- max_peakwidth;
+ };
+ if (missing(mzdiff)){
+ peakParams$mzdiff <- 0.01;
+ } else{
+ peakParams$mzdiff <- mzdiff;
+ };
+ if (missing(snthresh)){
+ peakParams$snthresh <- 6;
+ } else{
+ peakParams$snthresh <- snthresh;
+ };
+ if (missing(noise)){
+ peakParams$noise <- 1000;
+ } else{
+ peakParams$noise <- noise
+ };
+ if (missing(prefilter)){
+ peakParams$prefilter <- 3;
+ } else{
+ peakParams$prefilter <- prefilter
+ };
+ if (missing(value_of_prefilter)){
+ peakParams$value_of_prefilter <- 100;
+ } else{
+ peakParams$value_of_prefilter <- value_of_prefilter
+ };
+ }
+ if (Peak_method=="matchedFilter"){
+ if (missing(fwhm)){
+ peakParams$fwhm <- 30;
+ } else{
+ peakParams$fwhm <- fwhm
+ };
+ if (missing(sigma)){
+ peakParams$sigma <- 12.74;
+ } else{
+ peakParams$sigma <- sigma
+ };
+ if (missing(steps)){
+ peakParams$steps <- 2;
+ } else{
+ peakParams$steps <- steps
+ };
+ if (missing(max)){
+ peakParams$max <- 10;
+ } else{
+ peakParams$max <- max
+ };
+ if (missing(snthresh)){
+ peakParams$snthresh <- 10;
+ } else{
+ peakParams$snthresh <- snthresh
+ };
+ if (missing(mzdiff)){
+ peakParams$mzdiff <- 0.01;
+ } else{
+ peakParams$mzdiff <- mzdiff;
+ };
+ };
+ ## Parameters for Grouping-Density Method Only
+ if (missing(bw)){
+ peakParams$bw <- 30;
+ } else{
+ peakParams$bw <- bw;
+ };
+ if (missing(minFraction)){
+ peakParams$minFraction <- 0.5;
+ } else{
+ peakParams$minFraction <- minFraction
+ };
+ if (missing(minSamples)){
+ peakParams$minSamples <- 1;
+ } else{
+ peakParams$minSamples <- minSamples
+ };
+ if (missing(maxFeatures)){
+ peakParams$maxFeatures <- 100;
+ } else{
+ peakParams$maxFeatures <- maxFeatures
+ };
+ if (missing(fitgauss)){
+ peakParams$fitgauss<-FALSE
+ } else {
+ peakParams$fitgauss<-fitgauss
+ };
+ if (missing(verbose.columns)){
+ peakParams$verbose.columns<-FALSE
+ } else {
+ peakParams$verbose.columns<-verbose.columns
+ };
+ if (missing(mzCenterFun)){
+ peakParams$mzCenterFun<-"wMean"
+ } else {
+ peakParams$mzCenterFun<-mzCenterFun
+ };
+ if (missing(integrate)){
+ peakParams$integrate<-1
+ } else {
+ peakParams$integrate<-integrate
+ }
+ ## Parameters for RT correction
+ if (RT_method=="loess"){
+ if (missing(extra)){
+ peakParams$extra <- 1;
+ } else{
+ peakParams$extra <- extra
+ };
+ if (missing(span)){
+ peakParams$span <- 0.4;
+ } else{
+ peakParams$span <- span
+ };
+ if (missing(smooth)){
+ peakParams$smooth <- "loess";
+ } else{
+ peakParams$smooth <- smooth
+ };
+ if (missing(family)){
+ peakParams$family <- "gaussian";
+ } else{
+ peakParams$family <- family
+ };
+ }
+ if (RT_method=="obiwarp"){
+ if (missing(profStep)){
+ peakParams$profStep <- 1;
+ } else{
+ peakParams$profStep <- profStep
+ };
+ # Set profStep only here, profStep equals binsize
+ # other parameters use default
+ }
+ }
+ if (platform=="HPLC-Orbitrap"){
+ if (missing(Peak_method)){
+ peakParams$Peak_method <- "centWave"
+ } else{
+ peakParams$Peak_method <- Peak_method;
+ };
+ if (missing(RT_method)){
+ peakParams$RT_method <- "peakgroup"
+ } else{
+ peakParams$RT_method <- RT_method;
+ };
+ ## Parameters for Peakpicking
+ if (Peak_method=="centWave"){
+ if (missing(ppm)){
+ peakParams$ppm <- 3;
+ } else{
+ peakParams$ppm <- ppm;
+ };
+ if (missing(min_peakwidth)){
+ peakParams$min_peakwidth <- 10;
+ } else{
+ peakParams$min_peakwidth <- min_peakwidth;
+ };
+ if (missing(max_peakwidth)){
+ peakParams$max_peakwidth <- 60;
+ } else{
+ peakParams$max_peakwidth <- max_peakwidth;
+ };
+ if (missing(mzdiff)){
+ peakParams$mzdiff <- 0.01;
+ } else{
+ peakParams$mzdiff <- mzdiff;
+ };
+ if (missing(snthresh)){
+ peakParams$snthresh <- 6;
+ } else{
+ peakParams$snthresh <- snthresh;
+ };
+ if (missing(noise)){
+ peakParams$noise <- 1000;
+ } else{
+ peakParams$noise <- noise
+ };
+ if (missing(prefilter)){
+ peakParams$prefilter <- 3;
+ } else{
+ peakParams$prefilter <- prefilter
+ };
+ if (missing(value_of_prefilter)){
+ peakParams$value_of_prefilter <- 100;
+ } else{
+ peakParams$value_of_prefilter <- value_of_prefilter
+ };
+ }
+ if (Peak_method=="matchedFilter"){
+ if (missing(fwhm)){
+ peakParams$fwhm <- 30;
+ } else{
+ peakParams$fwhm <- fwhm
+ };
+ if (missing(sigma)){
+ peakParams$sigma <- 12.74;
+ } else{
+ peakParams$sigma <- sigma
+ };
+ if (missing(steps)){
+ peakParams$steps <- 2;
+ } else{
+ peakParams$steps <- steps
+ };
+ if (missing(max)){
+ peakParams$max <- 10;
+ } else{
+ peakParams$max <- max
+ };
+ if (missing(snthresh)){
+ peakParams$snthresh <- 10;
+ } else{
+ peakParams$snthresh <- snthresh
+ };
+ if (missing(mzdiff)){
+ peakParams$mzdiff <- 0.01;
+ } else{
+ peakParams$mzdiff <- mzdiff;
+ };
+ };
+ ## Parameters for Grouping-Density Method Only
+ if (missing(bw)){
+ peakParams$bw <- 30;
+ } else{
+ peakParams$bw <- bw;
+ };
+ if (missing(minFraction)){
+ peakParams$minFraction <- 0.5;
+ } else{
+ peakParams$minFraction <- minFraction
+ };
+ if (missing(minSamples)){
+ peakParams$minSamples <- 1;
+ } else{
+ peakParams$minSamples <- minSamples
+ };
+ if (missing(maxFeatures)){
+ peakParams$maxFeatures <- 100;
+ } else{
+ peakParams$maxFeatures <- maxFeatures
+ };
+ if (missing(fitgauss)){
+ peakParams$fitgauss<-FALSE
+ } else {
+ peakParams$fitgauss<-fitgauss
+ };
+ if (missing(verbose.columns)){
+ peakParams$verbose.columns<-FALSE
+ } else {
+ peakParams$verbose.columns<-verbose.columns
+ };
+ if (missing(mzCenterFun)){
+ peakParams$mzCenterFun<-"wMean"
+ } else {
+ peakParams$mzCenterFun<-mzCenterFun
+ };
+ if (missing(integrate)){
+ peakParams$integrate<-1
+ } else {
+ peakParams$integrate<-integrate
+ }
+ ## Parameters for RT correction
+ if (RT_method=="loess"){
+ if (missing(extra)){
+ peakParams$extra <- 1;
+ } else{
+ peakParams$extra <- extra
+ };
+ if (missing(span)){
+ peakParams$span <- 0.4;
+ } else{
+ peakParams$span <- span
+ };
+ if (missing(smooth)){
+ peakParams$smooth <- "loess";
+ } else{
+ peakParams$smooth <- smooth
+ };
+ if (missing(family)){
+ peakParams$family <- "gaussian";
+ } else{
+ peakParams$family <- family
+ };
+ }
+ if (RT_method=="obiwarp"){
+ if (missing(profStep)){
+ peakParams$profStep <- 1;
+ } else{
+ peakParams$profStep <- profStep
+ };
+ # Set profStep only here, profStep equals binsize
+ # other parameters use default
+ }
+ }
+ if (platform=="HPLC-S/Q"){
+ if (missing(Peak_method)){
+ peakParams$Peak_method <- "centWave"
+ } else{
+ peakParams$Peak_method <- Peak_method;
+ };
+ if (missing(RT_method)){
+ peakParams$RT_method <- "peakgroup"
+ } else{
+ peakParams$RT_method <- RT_method;
+ };
+ ## Parameters for Peakpicking
+ if (Peak_method=="centWave"){
+ if (missing(ppm)){
+ peakParams$ppm <- 30;
+ } else{
+ peakParams$ppm <- ppm;
+ };
+ if (missing(min_peakwidth)){
+ peakParams$min_peakwidth <- 10;
+ } else{
+ peakParams$min_peakwidth <- min_peakwidth;
+ };
+ if (missing(max_peakwidth)){
+ peakParams$max_peakwidth <- 60;
+ } else{
+ peakParams$max_peakwidth <- max_peakwidth;
+ };
+ if (missing(mzdiff)){
+ peakParams$mzdiff <- 0.01;
+ } else{
+ peakParams$mzdiff <- mzdiff;
+ };
+ if (missing(snthresh)){
+ peakParams$snthresh <- 6;
+ } else{
+ peakParams$snthresh <- snthresh;
+ };
+ if (missing(noise)){
+ peakParams$noise <- 1000;
+ } else{
+ peakParams$noise <- noise
+ };
+ if (missing(prefilter)){
+ peakParams$prefilter <- 3;
+ } else{
+ peakParams$prefilter <- prefilter
+ };
+ if (missing(value_of_prefilter)){
+ peakParams$value_of_prefilter <- 100;
+ } else{
+ peakParams$value_of_prefilter <- value_of_prefilter
+ };
+ }
+ if (Peak_method=="matchedFilter"){
+ if (missing(fwhm)){
+ peakParams$fwhm <- 30;
+ } else{
+ peakParams$fwhm <- fwhm
+ };
+ if (missing(sigma)){
+ peakParams$sigma <- 12.74;
+ } else{
+ peakParams$sigma <- sigma
+ };
+ if (missing(steps)){
+ peakParams$steps <- 2;
+ } else{
+ peakParams$steps <- steps
+ };
+ if (missing(max)){
+ peakParams$max <- 10;
+ } else{
+ peakParams$max <- max
+ };
+ if (missing(snthresh)){
+ peakParams$snthresh <- 10;
+ } else{
+ peakParams$snthresh <- snthresh
+ };
+ if (missing(mzdiff)){
+ peakParams$mzdiff <- 0.01;
+ } else{
+ peakParams$mzdiff <- mzdiff;
+ };
+ };
+ ## Parameters for Grouping-Density Method Only
+ if (missing(bw)){
+ peakParams$bw <- 30;
+ } else{
+ peakParams$bw <- bw;
+ };
+ if (missing(minFraction)){
+ peakParams$minFraction <- 0.5;
+ } else{
+ peakParams$minFraction <- minFraction
+ };
+ if (missing(minSamples)){
+ peakParams$minSamples <- 1;
+ } else{
+ peakParams$minSamples <- minSamples
+ };
+ if (missing(maxFeatures)){
+ peakParams$maxFeatures <- 100;
+ } else{
+ peakParams$maxFeatures <- maxFeatures
+ };
+ if (missing(fitgauss)){
+ peakParams$fitgauss<-FALSE
+ } else {
+ peakParams$fitgauss<-fitgauss
+ };
+ if (missing(verbose.columns)){
+ peakParams$verbose.columns<-FALSE
+ } else {
+ peakParams$verbose.columns<-verbose.columns
+ };
+ if (missing(mzCenterFun)){
+ peakParams$mzCenterFun<-"wMean"
+ } else {
+ peakParams$mzCenterFun<-mzCenterFun
+ };
+ if (missing(integrate)){
+ peakParams$integrate<-1
+ } else {
+ peakParams$integrate<-integrate
+ }
+ ## Parameters for RT correction
+ if (RT_method=="loess"){
+ if (missing(extra)){
+ peakParams$extra <- 1;
+ } else{
+ peakParams$extra <- extra
+ };
+ if (missing(span)){
+ peakParams$span <- 0.4;
+ } else{
+ peakParams$span <- span
+ };
+ if (missing(smooth)){
+ peakParams$smooth <- "loess";
+ } else{
+ peakParams$smooth <- smooth
+ };
+ if (missing(family)){
+ peakParams$family <- "gaussian";
+ } else{
+ peakParams$family <- family
+ };
+ }
+ if (RT_method=="obiwarp"){
+ if (missing(profStep)){
+ peakParams$profStep <- 1;
+ } else{
+ peakParams$profStep <- profStep
+ };
+ # Set profStep only here, profStep equals binsize
+ # other parameters use default
+ }
+ }
+ ### Platform Selection--OTHERS----
+ if (platform=="general"){
+ if (missing(Peak_method)){
+ peakParams$Peak_method <- "centWave"
+ } else{
+ peakParams$Peak_method <- Peak_method;
+ };
+ if (missing(RT_method)){
+ peakParams$RT_method <- "peakgroup"
+ } else{
+ peakParams$RT_method <- RT_method;
+ };
+ ## Parameters for Peakpicking
+ if (Peak_method=="centWave"){
+ if (missing(ppm)){
+ peakParams$ppm <- 5;
+ } else{
+ peakParams$ppm <- ppm;
+ };
+ if (missing(min_peakwidth)){
+ peakParams$min_peakwidth <- 5;
+ } else{
+ peakParams$min_peakwidth <- min_peakwidth;
+ };
+ if (missing(max_peakwidth)){
+ peakParams$max_peakwidth <- 30;
+ } else{
+ peakParams$max_peakwidth <- max_peakwidth;
+ };
+ if (missing(mzdiff)){
+ peakParams$mzdiff <- 0.01;
+ } else{
+ peakParams$mzdiff <- mzdiff;
+ };
+ if (missing(snthresh)){
+ peakParams$snthresh <- 10;
+ } else{
+ peakParams$snthresh <- snthresh;
+ };
+ if (missing(noise)){
+ peakParams$noise <- 1000;
+ } else{
+ peakParams$noise <- noise
+ };
+ if (missing(prefilter)){
+ peakParams$prefilter <- 3;
+ } else{
+ peakParams$prefilter <- prefilter
+ };
+ if (missing(value_of_prefilter)){
+ peakParams$value_of_prefilter <- 100;
+ } else{
+ peakParams$value_of_prefilter <- value_of_prefilter
+ };
+ }
+ if (Peak_method=="matchedFilter"){
+ if (missing(fwhm)){
+ peakParams$fwhm <- 30;
+ } else{
+ peakParams$fwhm <- fwhm
+ };
+ if (missing(sigma)){
+ peakParams$sigma <- 12.74;
+ } else{
+ peakParams$sigma <- sigma
+ };
+ if (missing(steps)){
+ peakParams$steps <- 2;
+ } else{
+ peakParams$steps <- steps
+ };
+ if (missing(max)){
+ peakParams$max <- 10;
+ } else{
+ peakParams$max <- max
+ };
+ if (missing(snthresh)){
+ peakParams$snthresh <- 10;
+ } else{
+ peakParams$snthresh <- snthresh
+ };
+ if (missing(mzdiff)){
+ peakParams$mzdiff <- 0.01;
+ } else{
+ peakParams$mzdiff <- mzdiff;
+ };
+ };
+ ## Parameters for Grouping-Density Method Only
+ if (missing(bw)){
+ peakParams$bw <- 10;
+ } else{
+ peakParams$bw <- bw;
+ };
+ if (missing(minFraction)){
+ peakParams$minFraction <- 0.5;
+ } else{
+ peakParams$minFraction <- minFraction
+ };
+ if (missing(minSamples)){
+ peakParams$minSamples <- 1;
+ } else{
+ peakParams$minSamples <- minSamples
+ };
+ if (missing(maxFeatures)){
+ peakParams$maxFeatures <- 100;
+ } else{
+ peakParams$maxFeatures <- maxFeatures
+ };
+ if (missing(fitgauss)){
+ peakParams$fitgauss<-FALSE
+ } else {
+ peakParams$fitgauss<-fitgauss
+ };
+ if (missing(verbose.columns)){
+ peakParams$verbose.columns<-FALSE
+ } else {
+ peakParams$verbose.columns<-verbose.columns
+ };
+ if (missing(mzCenterFun)){
+ peakParams$mzCenterFun<-"wMean"
+ } else {
+ peakParams$mzCenterFun<-mzCenterFun
+ };
+ if (missing(integrate)){
+ peakParams$integrate<-1
+ } else {
+ peakParams$integrate<-integrate
+ }
+ ## Parameters for RT correction
+ if (RT_method=="loess"){
+ if (missing(extra)){
+ peakParams$extra <- 1;
+ } else{
+ peakParams$extra <- extra
+ };
+ if (missing(span)){
+ peakParams$span <- 0.25;
+ } else{
+ peakParams$span <- span
+ };
+ if (missing(smooth)){
+ peakParams$smooth <- "loess";
+ } else{
+ peakParams$smooth <- smooth
+ };
+ if (missing(family)){
+ peakParams$family <- "gaussian";
+ } else{
+ peakParams$family <- family
+ };
+ }
+ if (RT_method=="obiwarp"){
+ if (missing(profStep)){
+ peakParams$profStep <- 1;
+ } else{
+ peakParams$profStep <- profStep
+ };
+ # Set profStep only here, profStep equals binsize
+ # other parameters use default
+ }
+ }
+ #### Other Parameters
+ # None for now !
+ return(peakParams)
+}
+
+
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/parameters_optimization.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/parameters_optimization.R
new file mode 100755
index 0000000000000000000000000000000000000000..574e1b6a5480d2e33e549f196fe3312818f019bf
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/parameters_optimization.R
@@ -0,0 +1,2839 @@
+#' @title Perform Parameters Optimization
+#' @description This function is used to optimize the critical parameters of peak picking and alignment for
+#' the following data processing. It utilizes the trimed data and the internal instrument-specific parameters.
+#' Parallel computing will be performed. The number of cores user want to use could be specified.
+#' @param raw_data MSnExp object, can be the (trimmed) data in memory produced by 'PerformDataTrimming' or the
+#' orignal data read by ImportRawMSData with 'inMemory" mode.
+#' @param param List, Parameters defined by 'SetPeakParam' function.
+#' @param method Character, method of parameters optimization, including "DoE' only. Default is "DoE". Other method
+#' is under development.
+#' @param ncore Numeric, CPU threads number used to perform the parallel based optimization. If thers is memory issue,
+#' please reduce the 'ncore' used here. For default, 2/3 CPU threads of total will be used.
+#' @export
+#' @import MSnbase
+#' @import progress
+#' @import parallel
+#' @author Zhiqiang Pang \email{zhiqiang.pang@mail.mcgill.ca} Jeff Xia \email{jeff.xia@mcgill.ca}
+#' Mcgill University
+#' License: GNU GPL (>= 2)
+
+PerformParamsOptimization<-function(raw_data, param=p0, method="DoE", ncore=4){
+
+ #require(xcms);require(progress);require(parallel);
+ #suppressPackageStartupMessages(require(IPO));
+ #suppressPackageStartupMessages(require(Autotuner));
+
+ start.time<-Sys.time();
+
+ if (missing(param)){
+ stop("Please provide the param with 'SetPeakParam' function !")
+ } else if (missing(raw_data)){
+ stop("Please provide the data of MSnExp format!" )
+ } else if (missing(method)){
+ method<-"DoE";
+ print("DoE Optimization Starting Now!")
+ };
+
+ if (missing(ncore)){
+ ncore<-detectCores();
+ message("'ncore' is absent, will use 2/3 CPU threads of total!")
+ };
+
+
+ # Define the global Parallel cores for Single Core function mode
+ if (ncore == 1){
+ if (.Platform$OS.type=="unix"){
+ register(bpstart(MulticoreParam(ncore)))
+ } else {
+ register(bpstart(SnowParam(ncore)))
+ };
+ }
+
+ ## Optimize the noise and prefilter indexes with AutoTuner
+ if (param[["Peak_method"]] == "centWave"){
+
+ print("Evaluating Noise level...");
+ p2<-Noise_evaluate(raw_data);
+
+ param[["ppm"]]<-round(p2$ppm,2)
+ param[["noise"]]<-round(p2$noise,2);
+ param[["prefilter"]]<-round(p2$prefilter,2);
+ param[["value_of_prefilter"]]<-round(p2$value_of_prefilter,2);
+
+ }
+
+ if (method=="DoE"){
+ p1<-optimize.xcms.doe(raw_data,param=param,ncore=ncore)
+ };
+
+ if (method=="OVAT"){
+ stop("Only DoE is supported for now. Other Optimization Model will be supported later.")
+ p1<-optimize.xcms.ovat(raw_data,param=param,ncore=ncore)
+ };
+
+ end.time<-Sys.time();
+ message("Time Spent In Total:",round((as.numeric(end.time) - as.numeric(start.time))/60, 1),"mins","\n");
+
+ return(p1)
+}
+
+#' @title Overall Funtion for DoE
+#' @description This function is the overall function to handle the starting of the optimization process and
+#' pre-define the parameters' range according to the input of the parameters.
+#' @param raw_data MSnExp object, The trimmed or original data input for optimization.
+#' @param param List, the parameters lists set by 'SetPeakParam' function. The noise, prefilter and ppm values should
+#' be defined by AutoTuner in the previous steps.
+#' @param ncore Numeric, core number used to perform the parallel based optimization.
+#' @import MSnbase
+#' @import progress
+#' @import parallel
+#' @author Zhiqiang Pang \email{zhiqiang.pang@mail.mcgill.ca} Jeff Xia \email{jeff.xia@mcgill.ca}
+#' Mcgill University
+#' License: GNU GPL (>= 2)
+
+optimize.xcms.doe<-function(raw_data, param, ncore=8){
+ #### Parameters Setting for optimization!------
+ if (is.null(param)){
+ stop("Please provide the param with 'SetPeakParam' function !")
+ } else {Parameters<-param};
+
+
+ ## Define the range of the parameters for optimization
+ if (Parameters$Peak_method=="centWave" && Parameters$RT_method=="peakgroup"){
+ ## Keep these Parameters
+ Parameters$value_of_prefilter <- Parameters$value_of_prefilter;
+ ## Parameters for peak picking
+ Parameters$max_peakwidth <- c(Parameters$max_peakwidth*0.5,Parameters$max_peakwidth*2)
+ Parameters$min_peakwidth <- c((Parameters$min_peakwidth)*0.5,(Parameters$min_peakwidth)*2)
+ #Parameters$ppm <- c(Parameters$ppm*0.5,Parameters$ppm*1.5)
+ Parameters$mzdiff <- c(-Parameters$mzdiff*1.2, Parameters$mzdiff*1.2)
+ Parameters$snthresh<-c(Parameters$snthresh*0.75,Parameters$snthresh*5)
+ ## Parameters for Alignment
+ Parameters$bw<-c(Parameters$bw*0.5,Parameters$bw*1.5)
+ } else
+ if (Parameters$Peak_method=="centWave" && Parameters$RT_method=="obiwarp"){
+ ## Keep these Parameters
+ Parameters$value_of_prefilter <- Parameters$value_of_prefilter;
+ ## Parameters for peak picking
+ Parameters$max_peakwidth <- c(Parameters$min_peakwidth*2,Parameters$max_peakwidth*2)
+ Parameters$min_peakwidth <- c(1,(Parameters$min_peakwidth)*2)
+ #Parameters$ppm <- c(1,Parameters$ppm*2);
+ Parameters$mzdiff <- c(-Parameters$mzdiff*2, Parameters$mzdiff*2);
+ Parameters$snthresh<-c(1,Parameters$snthresh*10+1);
+ ## Parameters for Alignment
+ Parameters$bw<-c(Parameters$bw*0.5,Parameters$bw*1.5)
+ } else
+ if (Parameters$Peak_method=="matchedFilter" && Parameters$RT_method=="peakgroup"){
+ ## Parameters for peak picking
+ Parameters$fwhm <- c((Parameters$fwhm)*0.8,(Parameters$fwhm)*1.2)
+ Parameters$sigma <- c(Parameters$sigma*0.8,Parameters$sigma*1.2)
+ Parameters$steps <- c(Parameters$steps-1,Parameters$steps+1)
+ Parameters$mzdiff <- c(-Parameters$mzdiff*2, Parameters$mzdiff*2)
+ Parameters$snthresh<-c(1,Parameters$snthresh*10)
+ ## Parameters for Alignment
+ Parameters$bw<-c(Parameters$bw*0.5,Parameters$bw*1.5)
+ } else
+ if (Parameters$Peak_method=="matchedFilter" && Parameters$RT_method=="obiwarp"){
+ ## Parameters for peak picking
+ Parameters$fwhm <- c((Parameters$fwhm)*0.8,(Parameters$fwhm)*1.2)
+ Parameters$sigma <- c(Parameters$sigma*0.8,Parameters$sigma*1.2)
+ Parameters$steps <- c(Parameters$steps-1,Parameters$steps+1)
+ Parameters$mzdiff <- c(-Parameters$mzdiff*2, Parameters$mzdiff*2)
+ Parameters$snthresh<-c(1,Parameters$snthresh*10)
+ ## Parameters for Alignment
+ Parameters$bw<-c(Parameters$bw*0.5,Parameters$bw*1.5)
+ } else {
+ stop("There must be something wrong about the Peak_method value in your primary params set !")
+ };
+
+ #### Start to Optimize !
+ result <- optimizxcms.doe.peakpicking(object = raw_data, params = Parameters,
+ BPPARAM = bpparam(),
+ nSlaves = ncore, subdir = NULL, plot = F);
+
+ optimizedxcmsObject <- result$best_settings$xset;
+ message("Optimization Finished !");
+
+ ##Parameters Out-put
+ peakParams2<-list();
+ peakParams2$best_parameters<-result[["best_settings"]][["parameters"]];
+ peakParams2$data<-optimizedxcmsObject;
+
+ message("Parameters Optimization Finished !");
+
+ return(peakParams2)
+}
+
+#' @title Core Optimization Function of DoE
+#' @description This function is the core for parameters optimization with Design of Experiment (DoE)
+#' method.
+#' @param objet MSnExp object, the trimmed or the original data.
+#' @param param List, the parameters lists set by 'SetPeakParam' function. The noise, prefilter and ppm values should
+#' be defined by AutoTuner in the previous steps.
+#' @param nSlave Numeric, core number used to perform the parallel based optimization.
+#' @param BPPARAM MulticoreParam method, used to set the parallel method. Default is bpparam().
+#' @param plot Logical, weather to plot the Contours plots of the DoE results.
+#' @import MSnbase
+#' @import progress
+#' @import parallel
+#' @author Zhiqiang Pang \email{zhiqiang.pang@mail.mcgill.ca} Jeff Xia \email{jeff.xia@mcgill.ca}
+#' Mcgill University
+#' License: GNU GPL (>= 2)
+
+optimizxcms.doe.peakpicking <- function(object = NULL, params = params,
+ BPPARAM = bpparam(), nSlaves = 4, plot = F,...) {
+
+ isotopeIdentification = c("IPO")
+ centWave <- is.null(params$fwhm)
+ history <- list()
+ iterator = 1
+ best_range <- 0.25
+
+ object_mslevel<-PeakPicking_prep(object)
+
+ while(iterator < 20) {#Forcely stop to ensure the reasonability!
+ print(paste0("Round:",iterator))
+ message("DoE Running Begin...")
+
+ # Parallel is unstable for matchedFilter Method, force to use only ne core
+ #if (params[["Peak_method"]]=="matchedFilter"){
+ # nSlaves<-1;
+ # message("Parallel for method 'matchedFilter' is unstable, set ncore as 1 !")
+ #}
+
+ mSet_OPT <-
+ ExperimentsCluster_doe(
+ object = object,
+ object_mslevel=object_mslevel,
+ params = params,
+ isotopeIdentification = isotopeIdentification,
+ BPPARAM = BPPARAM,
+ nSlaves = nSlaves
+ )
+
+ ### Normalize the PPS and CV in mSet_OPT
+ PPS.set<-as.numeric(sapply(1:nrow(mSet_OPT[["response"]]),FUN=function(x){
+ mSet_OPT[["response"]][x,5]
+ }));
+
+ CV.set<-as.numeric(sapply(1:nrow(mSet_OPT[["response"]]),FUN=function(x){
+ mSet_OPT[["response"]][x,6]
+ }))
+
+ RCS.set<-as.numeric(sapply(1:nrow(mSet_OPT[["response"]]),FUN=function(x){
+ mSet_OPT[["response"]][x,7]
+ }))
+
+ GS.set<-as.numeric(sapply(1:nrow(mSet_OPT[["response"]]),FUN=function(x){
+ mSet_OPT[["response"]][x,8]
+ }))
+
+ GaussianSI.set<-as.numeric(sapply(1:nrow(mSet_OPT[["response"]]),FUN=function(x){
+ mSet_OPT[["response"]][x,9]
+ }))
+
+ index.set<-list(CV=CV.set,RCS=RCS.set,GS=GS.set,GaussianSI=GaussianSI.set)
+
+ # Normalize the index
+ CV.set.normalized<-(CV.set-min(CV.set))/(max(CV.set)-min(CV.set))
+ RCS.set.normalized<-(RCS.set-min(RCS.set))/(max(RCS.set)-min(RCS.set))
+ GS.set.normalized<-(GS.set-min(GS.set))/(max(GS.set)-min(GS.set))
+ GaussianSI.set.normalized<-GaussianSI.set
+
+ # Calculate QCoE
+ QCoE<-CV.set.normalized*0.2+RCS.set.normalized*0.4+
+ GS.set.normalized*0.4
+ # Calculate QS
+ QS<-PPS.set*QCoE*GaussianSI.set.normalized
+
+ tmp_matrix<-mSet_OPT[["response"]]
+ tmp_matrix<-cbind(tmp_matrix,PPS.set,CV.set.normalized,RCS.set.normalized,GS.set.normalized,
+ GaussianSI.set.normalized,QCoE,QS)
+ mSet_OPT[["response"]]<-tmp_matrix
+
+ message("Round ",iterator," Finished !")
+
+ mSet_OPT <-
+ Statistic_doe(
+ object = object,
+ object_mslevel=object_mslevel,
+ isotopeIdentification = isotopeIdentification,
+ BPPARAM = BPPARAM,
+ subdir = NULL,
+ plot = F,
+ mSet_OPT = mSet_OPT,
+ iterator = iterator,
+ index.set = index.set,
+ useNoise = params[["noise"]]
+ )
+
+ history[[iterator]] <- mSet_OPT
+
+ params <- mSet_OPT$params
+
+ if(!resultIncreased_doe(history)) {
+ message("No Increase Stopping !")
+ maxima <- 0
+ max_index <- 1
+ for(i in 1:length(history)) {
+ if(history[[i]]$max_settings[1] > maxima) {
+ maxima <- history[[i]]$max_settings[1]
+ max_index <- i
+ }
+ }
+
+ xcms_parameters <-
+ as.list(decodeAll(history[[max_index]]$max_settings[-1],
+ history[[max_index]]$params$to_optimize))
+
+ xcms_parameters <- combineParams(xcms_parameters,
+ params$no_optimization)
+
+ if(!is.list(xcms_parameters))
+ xcms_parameters <- as.list(xcms_parameters)
+
+ best_settings <- list()
+ best_settings$parameters <- xcms_parameters
+ best_settings$xset <- history[[max_index]]$xset
+
+ target_value <- history[[max_index]]$QS
+ best_settings$result <- target_value
+ history$best_settings <- best_settings
+
+ message("best parameter settings:")
+ message(paste(rbind(paste(names(xcms_parameters),
+ sep="", ": "),
+ paste(xcms_parameters, sep="", "\n")), sep=""))
+
+ return(history)
+
+ }
+
+ for(i in 1:length(params$to_optimize)) {
+ parameter_setting <- mSet_OPT$max_settings[i+1]
+ bounds <- params$to_optimize[[i]]
+ fact <- names(params$to_optimize)[i]
+
+ min_factor <-
+ ifelse(fact=="min_peakwidth", 3,
+ ifelse(fact=="mzdiff",
+ ifelse(centWave,-0.02, 0.001),
+ ifelse(fact=="step",0.0005,
+ ifelse(fact=="bw",2,
+ ifelse(fact=="snthresh",5,1)))))
+
+ step_factor <-
+ ifelse(is.na(parameter_setting), 1.2,
+ ifelse((abs(parameter_setting) < best_range), 0.8,
+ ifelse(parameter_setting==-1 &
+ decode(-1, params$to_optimize[[i]]) ==
+ min_factor, 0.8, 1)))
+
+ step <- (diff(bounds) / 2) * step_factor
+
+ if(is.na(parameter_setting))
+ parameter_setting <- 0
+
+ new_center <- decode(parameter_setting, bounds)
+
+ if((new_center-min_factor) > step) {
+ new_bounds <- c(new_center - step, new_center + step)
+ } else {
+ new_bounds <- c(min_factor, 2*step+min_factor)
+ }
+
+ names(new_bounds) <- NULL
+
+ if(names(params$to_optimize)[i] == "steps" |
+ names(params$to_optimize)[i] == "prefilter") {
+ params$to_optimize[[i]] <- round(new_bounds, 0)
+ } else {
+ params$to_optimize[[i]] <- new_bounds
+ }
+ }
+
+ if(centWave) {
+
+ if(!is.null(params$to_optimize$min_peakwidth) |
+ !is.null(params$to_optimize$max_peakwidth)) {
+
+ pw_min <-
+ ifelse(is.null(params$to_optimize$min_peakwidth),
+ params$no_optimization$min_peakwidth,
+ max(params$to_optimize$min_peakwidth))
+
+ pw_max <-
+ ifelse(is.null(params$to_optimize$max_peakwidth),
+ params$no_optimization$max_peakwidth,
+ min(params$to_optimize$max_peakwidth))
+
+ if(pw_min >= pw_max) {
+ additional <- abs(pw_min-pw_max) + 1
+
+ if(!is.null(params$to_optimize$max_peakwidth)) {
+ params$to_optimize$max_peakwidth <-
+ params$to_optimize$max_peakwidth + additional
+ } else {
+ params$no_optimization$max_peakwidth <-
+ params$no_optimization$max_peakwidth + additional
+ }
+
+ }
+ }
+
+ }
+
+ params <- attachList(params$to_optimize, params$no_optimization)
+ iterator <- iterator + 1
+
+ }
+
+ params <- attachList(params$to_optimize, params$no_optimization)
+
+ return(history)
+
+}
+
+#' @title Experiment Functions of DoE
+#' @description This function is used to perform the test with Design of Experiment on the parameters dataset.
+#' @param object MSnExp object, the trimmed or the original data.
+#' @param object_mslevel List, the parsed metabolomics scans produced by PeakPicking_prep.
+#' @param isotopeIdentification Character, IsotopeIdentidication method, usually includes 'IPO' and 'CAMERA'.
+#' @param BPPARAM MulticoreParam method, used to set the parallel method. Default is bpparam().
+#' @param nSlave Numeric, core number used to perform the parallel based optimization.
+#' @import MSnbase
+#' @importFrom rsm decode.data ccd rsm
+#' @import progress
+#' @import parallel
+#' @author Zhiqiang Pang \email{zhiqiang.pang@mail.mcgill.ca} Jeff Xia \email{jeff.xia@mcgill.ca}
+#' Mcgill University
+#' License: GNU GPL (>= 2)
+
+ExperimentsCluster_doe <-function(object, object_mslevel,params,
+ isotopeIdentification, BPPARAM = bpparam(),nSlaves=4, ...) {
+
+ # To form a parameters combination table
+ typ_params <- typeCastParams(params)
+
+ if(length(typ_params$to_optimize)>1) {
+ design <- getCcdParameter(typ_params$to_optimize)
+ param_design <- rsm::decode.data(design)
+ } else {
+ design <- data.frame(run.order=1:9, a=seq(-1,1,0.25))
+ colnames(design)[2] <- names(typ_params$to_optimize)
+ param_design <- design
+ param_design[,2] <-
+ seq(min(typ_params$to_optimize[[1]]),
+ max(typ_params$to_optimize[[1]]),
+ diff(typ_params$to_optimize[[1]])/8)
+ }
+
+ param_design <- combineParams(param_design, typ_params$no_optimization)
+
+ design_list <- apply(param_design,1,FUN = function(x){
+ as.list(x)
+ })
+
+ tasks <- 1:nrow(design);
+
+ if (.Platform$OS.type=="windows"){
+ print("Your OS is Windows, there might be unexpected errors.")
+ print("If there is some unexpected bugs, please reduce the 'core' as 1.")
+ }
+
+
+ # Parallel or single core
+ if(nSlaves > 1) {
+
+ # Memory optimization strategy
+ ncount<-object@phenoData@data[["sample_name"]];
+ data.size<-round(as.numeric(object.size(object)/1024/1024),1);
+ if(.Platform$OS.type=="unix" ){
+ memtotal <- try(ceiling(as.numeric(system("awk '/MemTotal/ {print $2}' /proc/meminfo", intern=TRUE))/1024/1024),silent = T)
+ }
+ if(.Platform$OS.type=="windows"){
+ memtotal <- ceiling(as.numeric(gsub("\r","",gsub("TotalVisibleMemorySize=","",system('wmic OS get TotalVisibleMemorySize /Value',intern=TRUE)[3])))/1024/1024)
+ }
+
+ if (class(memtotal) == "try-error"){
+ memtotal <- 8;
+ }
+
+ if(data.size<1){
+ data.size<-0.5
+ }
+
+ if (memtotal/data.size>30){
+ nstepby<-ceiling(memtotal*0.75/(data.size*32))
+ } else if (memtotal/data.size<30 && memtotal/data.size>15){
+ nstepby<-ceiling(memtotal*0.5/(data.size*32))
+ } else {
+ nstepby<-ceiling(memtotal*0.25/(data.size*32))
+ }
+
+ nstep<-ceiling(length(tasks)/nstepby)
+
+ ## Parallel Setting
+ if('snow' %in% rownames(installed.packages())){
+ unloadNamespace("snow")
+ }
+
+ cl_type<-getClusterType()
+ cl <- parallel::makeCluster(nSlaves,type = cl_type)
+ response <- matrix(0, nrow=length(design[[1]]), ncol=9)
+
+ # Parallel space setting
+
+ # parallel::clusterEvalQ(cl, library("MetaboAnlystR"))
+ # Do not need the whole package to memory to reduce the memory burden
+
+ parallel::clusterExport(cl, optimize_function_list, envir = asNamespace("MetaboAnalystR"))
+ # Setting progress bar and start the running loop
+ pb <- progress_bar$new(format = "DoE Running [:bar] :percent Time left: :eta", total = nstep, clear = T, width= 75)
+
+ for (w in 1:nstep){
+ pb$tick();
+
+ value.index<-tasks[c(1:nstepby)+(w-1)*nstepby];
+ if (NA %in% tasks[c(1:nstepby)+(w-1)*nstepby]){
+ value.index<-value.index[-which(is.na(tasks[c(1:nstepby)+(w-1)*nstepby]))]
+ }
+
+ response0 <- parallel::parSapply(
+ cl = cl,
+ X = value.index,
+ FUN = SlaveCluster_doe,
+ Set_parameters = design_list,
+ object = object,
+ object_mslevel=object_mslevel,
+ isotopeIdentification = isotopeIdentification,
+ BPPARAM = BPPARAM,
+ USE.NAMES = FALSE
+ )
+
+ response[value.index,]<-t(response0)
+ }
+
+ parallel::stopCluster(cl)
+ } else {
+ response <-
+ sapply(
+ X = tasks,
+ FUN = SlaveCluster_doe,
+ Set_parameters = design_list,
+ object = object,
+ object_mslevel=object_mslevel,
+ isotopeIdentification = isotopeIdentification,
+ BPPARAM = BPPARAM
+ )
+ response <- t(response)
+ }
+
+ colnames(response) <- c("exp", "num_peaks", "notLLOQP", "num_C13", "PPS","CV","RCS","GS","GaussianSI")
+ response <- response[order(response[,1]),]
+
+ ret <- list()
+ ret$params <- typ_params
+ ret$design <- design
+ ret$response <- response
+ return(ret)
+
+}
+
+#' @title Analyze DoE Result
+#' @param object MSnExp object, the trimmed or the original data.
+#' @param object_mslevel List, the parsed metabolomics scans produced by PeakPicking_prep.
+#' @param isotopeIdentification Character, IsotopeIdentidication method, usually includes 'IPO' and 'CAMERA'.
+#' @param BPPARAM MulticoreParam method, used to set the parallel method. Default is bpparam().
+#' @param mSet_OPT List, the result produced by 'ExperimentsCluster'.
+#' @param subdir Logical, weather to creat a sub-directory (if true) or not (if false).
+#' @param plot Logical, weather to plot the Contours plots of the DoE results.
+#' @param iterator Numeric, the round number of the DoE.
+#' @param index.set List, the indexes set (including PPS, CV, RCS, GS and Gaussian Index) produced by
+#' ExperiemntCluster.
+#' @param useNoise Numeric, the noise level removed to evalute the gaussian peak.
+#' @import MSnbase
+#' @import parallel
+#' @author Zhiqiang Pang \email{zhiqiang.pang@mail.mcgill.ca} Jeff Xia \email{jeff.xia@mcgill.ca}
+#' Mcgill University
+#' License: GNU GPL (>= 2)
+
+Statistic_doe <-function(object, object_mslevel, isotopeIdentification,
+ BPPARAM = bpparam(), mSet_OPT, subdir = NULL ,plot = F,iterator,
+ index.set,useNoise) {
+ message("Model Parsing...")
+
+ # Prepare parameters for model prediction
+ params <- mSet_OPT$params
+ resp <- mSet_OPT$response[, "QS"]
+
+ # Creat the prediction model and get the predicted best results
+ model <- createModel(mSet_OPT$design, params$to_optimize, resp)
+ mSet_OPT$model <- model
+ max_settings <- getMaximumLevels(mSet_OPT$model)
+
+ tmp <- max_settings[1,-1] # first row without response
+ tmp[is.na(tmp)] <- 1 # if Na (i.e. -1, and 1), show +1
+
+ mSet_OPT$max_settings <- max_settings
+ xcms_parameters <-
+ as.list(decodeAll(max_settings[-1], params$to_optimize))
+ xcms_parameters <-
+ combineParams(xcms_parameters, params$no_optimization)
+
+ if(!is.list(xcms_parameters))
+ xcms_parameters <- as.list(xcms_parameters)
+
+
+ # Detect the peak features with the predicted best parameters
+ mSet <- suppressMessages(calculateSet_doe(object = object, object_mslevel=object_mslevel,
+ Set_parameters = xcms_parameters,
+ task = 1, BPPARAM = BPPARAM));
+ xset <- mSet[["xcmsSet"]]
+ # Calculate the various indexes
+
+ mSet_OPT$xset <- xset
+ mSet_OPT$PPS <- calcPPS2(xset, isotopeIdentification)
+ suppressWarnings(mSet_OPT$PPS$CV <- suppressMessages(calcCV(xset)))
+ mSet_OPT$PPS$RCS <-suppressMessages(calcRCS_GSValues(xset)$RCS)
+ mSet_OPT$PPS$GS <-suppressMessages(calcRCS_GSValues(xset)$GS)
+ mSet_OPT$PPS$GaussianSI <-calcGaussianS(mSet,object,useNoise=useNoise)
+
+ ## Normalize the CV, RCS, GS, GaussianSI
+ normalized.CV<-(mSet_OPT$PPS$CV-min(index.set$CV))/(max(index.set$CV)-min(index.set$CV))
+ normalized.RCS<-(mSet_OPT$PPS$RCS-min(index.set$RCS))/(max(index.set$RCS)-min(index.set$RCS))
+ normalized.GS<-(mSet_OPT$PPS$GS-min(index.set$GS))/(max(index.set$GS)-min(index.set$GS))
+ normalized.GaussianSI<-mSet_OPT$PPS$GaussianSI
+
+ ## Calculate the QS for the best combination in current iterator!
+ QCoE<-0.2*(normalized.CV)+0.4*(normalized.GS+normalized.RCS)
+
+ mSet_OPT$QS<-as.numeric(mSet_OPT$PPS[5])*QCoE*normalized.GaussianSI^2
+ message("Model Parsing Done !")
+
+ return(mSet_OPT)
+}
+
+#' @title Core Peak Picking Slave Cluster
+#' @param task Numeric, task order for XCMS paramters table to run the peak picking and alignment.
+#' @param xcmsSet_parameters Matrix, the parameters combination produced automatically according to
+#' the primary parameters input.
+#' @param MSnExp object, the trimmed or the original data.
+#' @param object_mslevel List, the parsed metabolomics scans produced by PeakPicking_prep.
+#' @param isotopeIdentification Character, IsotopeIdentidication method, usually includes 'IPO' and 'CAMERA'.
+#' @param BPPARAM MulticoreParam method, used to set the parallel method. Default is bpparam().
+#' @import MSnbase
+#' @author Zhiqiang Pang \email{zhiqiang.pang@mail.mcgill.ca} Jeff Xia \email{jeff.xia@mcgill.ca}
+#' Mcgill University
+#' License: GNU GPL (>= 2)
+
+SlaveCluster_doe <-function(task, Set_parameters, object, object_mslevel,
+ isotopeIdentification, BPPARAM = bpparam(),...) {
+
+ mSet <-
+ calculateSet_doe(
+ object = object,
+ object_mslevel=object_mslevel,
+ Set_parameters = Set_parameters,
+ task = task,
+ BPPARAM = BPPARAM
+ )
+ print(paste("Finished", task,"/",length(Set_parameters),"in this round !"))
+
+ if (!class(mSet)=="character"){
+ print("Peak Feature Analyzing...")
+
+ xset <- mSet[["xcmsSet"]]
+
+ result <- calcPPS2(xset, isotopeIdentification)
+ result[1] <- task
+
+ tmp_cv<- try(suppressMessages(calcCV(xset)),silent = T);
+ if (class(tmp_cv)=="try-error"){
+ result[6]<-0;
+ } else {
+ result[6]<-tmp_cv
+ };
+
+ tmp_RCS<-try(suppressMessages(calcRCS_GSValues(xset)$RCS),silent = T);
+ if (class(tmp_RCS)=="try-error"){
+ result[7]<-0;
+ } else {
+ result[7]<-tmp_RCS
+ };
+
+ tmp_GS<-try(suppressMessages(calcRCS_GSValues(xset)$GS),
+ silent = T);
+
+ if (class(tmp_GS)=="try-error"){
+ result[8]<-0;
+ } else {
+ result[8]<-tmp_GS
+ };
+
+ tmp_GaussianSI<-try(calcGaussianS(mSet,object,
+ useNoise = as.numeric(Set_parameters[[task]]$noise)),
+ silent = T);
+
+ if (class(tmp_GaussianSI)=="try-error"){
+ result[9]<-0;
+ } else {
+ result[9]<-tmp_GaussianSI
+ };
+
+ names(result)[c(6,7,8,9)]<-c("CV","RCS","GS","GaussianSI")
+
+ rm(xset)
+
+ #result
+ print("Peak Feature Analyzing Done !")
+
+ } else{
+ result<-c(task,0,0,0,0,0,0,0,0)
+ }
+ return(result)
+
+}
+
+#' @title Cluster of Peak Picking and Alignment
+#' @param object MSnExp object, the trimmed or the original data.
+#' @param object_mslevel List, the parsed metabolomics scans produced by PeakPicking_prep.
+#' @param Set_parameters Matrix, the parameters combination produced automatically according to
+#' the primary parameters input.
+#' @param task Numeric, task order for XCMS paramters table to run the peak picking and alignment.
+#' @param BPPARAM MulticoreParam method, used to set the parallel method. Default is bpparam().
+#' @import MSnbase
+#' @author Zhiqiang Pang \email{zhiqiang.pang@mail.mcgill.ca} Jeff Xia \email{jeff.xia@mcgill.ca}
+#' Mcgill University
+#' License: GNU GPL (>= 2)
+
+calculateSet_doe <- function(object, object_mslevel, Set_parameters, task = 1,
+ BPPARAM = bpparam()) {
+
+ if (length(Set_parameters)==22 | length(Set_parameters)==23){
+ param <- updateRawSpectraParam(Set_parameters)
+ } else {
+ param <- updateRawSpectraParam(Set_parameters[[task]])
+ }
+
+ mSet <- calculatePPKs(object, object_mslevel, param, BPPARAM = bpparam())
+ #save(mSet,file = "mSet.rda");
+ #save(param,file="param.rda")
+ mSet <- calculateGPRT(mSet,param)
+
+ return(mSet)
+}
+
+#' @title Peak picking Method
+#' @param object MSnExp object, the trimmed or the original data.
+#' @param object_mslevel List, the parsed metabolomics scans produced by PeakPicking_prep.
+#' @param xcmsSetParameters Matrix, the parameters combination produced automatically according to
+#' @param task Numeric, task order for XCMS paramters table to run the peak picking and alignment.
+#' @param BPPARAM MulticoreParam method, used to set the parallel method. Default is bpparam().
+#' @param msLevel Numeric, to specifiy the msLevel, only 1 permitted for now. 2 will be supported
+#' in the near future.
+#' @import MSnbase
+#' @author Zhiqiang Pang \email{zhiqiang.pang@mail.mcgill.ca} Jeff Xia \email{jeff.xia@mcgill.ca}
+#' Mcgill University
+#' License: GNU GPL (>= 2)
+
+calculatePPKs<-function(object, object_mslevel,param,
+ BPPARAM = bpparam(),msLevel = 1){
+
+ if (param$Peak_method == "centWave" | param$Peak_method == "matchedFilter") {
+ # centWave & matchedFilter
+
+ mSet <- try(PeakPicking_core(object, object_mslevel,
+ param = param,
+ BPPARAM = BPPARAM,
+ msLevel = 1),silent = T)
+
+ } else {
+
+ stop("Other peak picking method cannot be supported for now !")
+
+ }
+}
+
+#' @title Alignment Method
+#' @param mSet mSet object, the data produced by 'calculatePPKs' function.
+#' @param Set_parameters Matrix, the parameters combination produced automatically according to
+#' @param task Numeric, task order for XCMS paramters table to run the peak picking and alignment.
+#' @import MSnbase
+#' @author Zhiqiang Pang \email{zhiqiang.pang@mail.mcgill.ca} Jeff Xia \email{jeff.xia@mcgill.ca}
+#' Mcgill University
+#' License: GNU GPL (>= 2)
+
+calculateGPRT<-function (mSet,param){
+
+ mSet <- try(PerformPeakAlignment(mSet, param),silent = T);
+ gc();
+ mSet <- try(PerformPeakFiling (mSet, param),silent = T);
+ gc();
+ if (class(mSet)=="try-error"){
+ mSet<-"Xset_NA";
+ }
+ return(mSet)
+}
+
+# Left the old here for fix the error later
+calculateGPRT_old<-function(xdata,Set_parameters,task){
+ ## Peak grouping with Density Method
+ gdp <- PeakDensityParam(sampleGroups = rep(1, length(fileNames(xdata))),
+ bw = Set_parameters$bw[task],
+ minFraction = Set_parameters$minFraction[task],
+ minSamples = Set_parameters$minSamples[task],
+ maxFeatures = Set_parameters$maxFeatures[task]);
+ #if (xcmsSetParameters$RT_method[task] == "loess"){
+ grouped_xdata <- try(groupChromPeaks(xdata, param = gdp),silent = T)
+ #} else {
+ # grouped_xdata <- xdata
+ #}
+
+ ## RT Alignment correction
+ if (class(grouped_xdata)=="try-error"){
+ xdata_filled<-"Xset_NA";
+ } else{
+ if(Set_parameters$RT_method[task] == "loess"){
+ rt_xdata <- try(adjustRtime(grouped_xdata,
+ param = PeakGroupsParam(
+ minFraction = Set_parameters$minFraction[task],
+ extraPeaks=Set_parameters$extra[task],
+ span=Set_parameters$span[task],
+ smooth=Set_parameters$smooth[task],
+ family =Set_parameters$family[task])),silent = T)
+ }else{
+ rt_xdata <- try(adjustRtime(grouped_xdata,
+ param = ObiwarpParam(binSize = Set_parameters$profStep[task])),silent = T)
+ }
+ if(!class(rt_xdata)=="try-error"){
+ ## Grouped Again
+ grouped_xdata2 <- groupChromPeaks(rt_xdata, param = gdp)
+ ## Filled the missing peaking forcely
+ xdata_filled <- fillChromPeaks(grouped_xdata2)
+ } else{
+ xdata_filled<-"Xset_NA";
+ }
+
+ }
+ return(xdata_filled)
+}
+
+#' @title Calculate PPS method
+#' @param xset xcmsSet Object, this object is produced by 'calculateSet_doe' function, and transformed
+#' with as(objec,'xcmsSet') function.
+#' @param isotopeIdentification Character, IsotopeIdentidication method, usually includes 'IPO' and 'CAMERA'.
+#' @author Zhiqiang Pang \email{zhiqiang.pang@mail.mcgill.ca} Jeff Xia \email{jeff.xia@mcgill.ca}
+#' Mcgill University
+#' License: GNU GPL (>= 2)
+
+calcPPS2 <- function(xset, isotopeIdentification=c("IPO", "CAMERA"), ...) {
+
+ isotopeIdentification <- match.arg(isotopeIdentification)
+
+ ret <- vector(mode="numeric", 5) #array(0, dim=c(1,5))
+ names(ret) <- c("ExpId", "#peaks", "#NonRP", "#RP", "PPS")
+ if(is.null(xset)) {
+ return(ret)
+ }
+
+ if(nrow(peaks_IPO(xset)) == 0) {
+ return(ret)
+ }
+
+ peak_source <- peaks_IPO(xset)[,c("mz", "rt", "sample", "into", "mzmin",
+ "mzmax", "rtmin", "rtmax"),drop=FALSE]
+ ret[2] <- nrow(peak_source)
+
+ if(isotopeIdentification == "IPO")
+ iso_mat <- findIsotopes.IPO(xset, ...)
+ else
+ iso_mat <- findIsotopes.CAMERA(xset, ...)
+
+ samples <- unique(peak_source[,"sample"])
+ isotope_abundance = 0.01108
+
+ #calculating low intensity peaks
+ for(sample in samples) {
+ non_isos_peaks <- peak_source
+
+ if(nrow(iso_mat) > 0) {
+ non_isos_peaks <- peak_source[-unique(c(iso_mat)),,drop=FALSE]
+ }
+
+ speaks <- non_isos_peaks[non_isos_peaks[,"sample"]==sample,,drop=FALSE]
+ intensities <- speaks[,"into"]
+ na_int <- is.na(intensities)
+ intensities <- intensities[!na_int]
+
+ if(length(intensities)>0) {
+ tmp <- intensities[order(intensities)]
+ int_cutoff <- mean(tmp[1:max(round((length(tmp)/33),0),1)])
+
+ masses <- speaks[!na_int, "mz"]
+ #floor((masses-2*CH3)/CH2) + 2
+ maximum_carbon <- calcMaximumCarbon(masses)
+ carbon_probabilty <- maximum_carbon*isotope_abundance
+
+ iso_int <- intensities * carbon_probabilty
+
+ not_loq_peaks <- sum(iso_int>int_cutoff)
+ ret[3] <- ret[3] + not_loq_peaks
+ }
+ }#end_for_sample
+
+ ret[4] <- length(unique(c(iso_mat)))
+ if(ret[3] == 0) {
+ ret[5] <- (ret[4]+1)^1.5/(ret[3]+1)
+ } else {
+ ret[5] <- ret[4]^1.5/ret[3]
+ }
+
+ return(ret)
+
+}
+
+#' @title Calculatre CV method
+#' @param xset XCMSnExp Object, this object is produced by 'calculateSet_doe' function.
+#' @author Zhiqiang Pang \email{zhiqiang.pang@mail.mcgill.ca} Jeff Xia \email{jeff.xia@mcgill.ca}
+#' Mcgill University
+#' License: GNU GPL (>= 2)
+
+calcCV<-function(xset){
+
+ ncount<-length(xset@phenoData[["sample_name"]])
+
+ table.data<-creatPeakTable(xset);
+
+ table.data$abundance.mean <- apply(table.data[, 9:(8 + ncount)],1, FUN = mean, na.rm = T);
+ table.data$abundance.sd <- apply(table.data[, 9:(8 + ncount)],1, FUN = sd, na.rm = T);
+ table.data$abundance.cv <- (table.data$abundance.sd * 100)/table.data$abundance.mean;
+
+ cv.min<-min(table.data$abundance.cv, na.rm = T);
+ cv.0.25<-as.numeric(quantile(table.data$abundance.cv, probs = 0.25, na.rm = T));
+ cv.med<-median(table.data$abundance.cv, na.rm = T);
+ cv.0.75<-as.numeric(quantile(table.data$abundance.cv, probs = 0.75, na.rm = T));
+ cv.max<-max(table.data$abundance.cv, na.rm = T);
+ cv.score<-1/(0.75*cv.med+0.25*(cv.max-cv.med))
+
+ return(cv.score)
+
+}
+
+#' @title Calculatre RCS and GS method
+#' @param xset XCMSnExp Object, this object is produced by 'calculateSet_doe' function.
+#' @author Zhiqiang Pang \email{zhiqiang.pang@mail.mcgill.ca} Jeff Xia \email{jeff.xia@mcgill.ca}
+#' Mcgill University
+#' License: GNU GPL (>= 2)
+
+calcRCS_GSValues<-function(xset){
+ score.ret<-getRGTVValues(xset)
+ return(list(GS=score.ret[["GS"]],RCS=score.ret[["RCS"]]))
+}
+
+#' @title Calculatre Gaussian Peak Ratio method
+#' @param mSet MetaboAnalystR Object, this object is produced by 'calculateSet_doe' function.
+#' @param object MSnExp object, the trimmed or the original data (Generated by ImportRawMSData function with "inMemory" mode).
+#' @param useNoise Numeric, the noise level removed to evalute the gaussian peak.
+#' @param BPPARAM MulticoreParam method, used to set the parallel method. Default is bpparam().
+#' @export
+#' @author Zhiqiang Pang \email{zhiqiang.pang@mail.mcgill.ca} Jeff Xia \email{jeff.xia@mcgill.ca}
+#' Mcgill University
+#' License: GNU GPL (>= 2)
+
+calcGaussianS<-function(mSet, object, useNoise, BPPARAM = bpparam()){
+
+ if (identical(useNoise, numeric(0))){
+ useNoise <- 0
+ }
+
+ peakmat <- mSet$msFeatureData$chromPeaks
+ peakmat_set <- split.data.frame(peakmat, peakmat[, "sample"])
+ # extract everything
+
+ if(.Platform$OS.type=="unix" ){
+ BPPARAM = MulticoreParam()
+
+ extFUN <- function(z,object,useNoise) {
+ ## Subset the data to the present file keeping only spectra that
+ ## are in the peak range.
+
+ if (nrow(z)>150){z<-z[sort(sample(1:nrow(z),150)),]}
+ currentSample <- suppressMessages(MSnbase::filterRt(
+ MSnbase::filterFile(object, z[1, "sample"]),
+ rt = range(z[, c("rtmin", "rtmax")])))
+
+ corr <- unlist(sapply(seq_len(nrow(z)),FUN = function(i){
+
+ corr <- 0.1
+
+ mzRange <- z[i, c("mzmin", "mzmax")] + c(-0.001, 0.001)
+ rtRange <- z[i, c("rtmin", "rtmax")]
+
+ suppressWarnings(ints <- MSnbase::intensity(
+ MSnbase::filterMz(
+ MSnbase::filterRt(currentSample, rtRange),mzRange)))
+
+ ints[lengths(ints) == 0] <- 0
+ ints <- as.integer(unlist(ints))
+ ints <- ints[!is.na(ints)]
+ ints <- ints[ints > useNoise]
+
+ if (length(ints)) {
+
+ ints <- ints - min(ints)
+ if (max(ints) > 0)
+ ints <- ints / max(ints)
+ fit <- try(nls(y ~ SSgauss(x, mu, sigma, h),
+ data.frame(x = 1:length(ints), y = ints)),
+ silent = TRUE)
+ if (class(fit) == "try-error") {
+ corr <- 0.1
+ } else {
+ ## calculate correlation of eics against gaussian fit
+ if (sum(!is.na(ints - fitted(fit))) > 4 &&
+ sum(!is.na(unique(ints))) > 4 &&
+ sum(!is.na(unique(fitted(fit)))) > 4) {
+ cor <- NULL
+ options(show.error.messages = FALSE)
+ cor <- try(cor.test(ints, fitted(fit),
+ method = "pearson",
+ use = "complete"))
+
+ options(show.error.messages = TRUE)
+ if (!is.null(cor) && cor$p.value <= 0.05){
+ corr <- cor$estimate
+ } else if (!is.null(cor) && cor$p.value > 0.05) {
+ corr <- cor$estimate*0.85 #give a penalty (0.85) due to the unstatistical p value
+ }
+ } else {
+ corr <- 0.1
+ }
+
+
+ }
+ }
+ return(corr)
+ }))
+
+ gaussian.peak.ratio<-nrow(z[corr >= 0.9, , drop = FALSE])/nrow(z)
+
+ return(gaussian.peak.ratio)
+ }
+
+ res <- bplapply(peakmat_set,
+ extFUN,
+ object=object,
+ useNoise=useNoise,
+ BPPARAM = BPPARAM)
+
+
+ }
+
+ if(.Platform$OS.type=="windows"){
+
+
+ # BPPARAM = MulticoreParam() # should be SnowParam(), not sure why does not work for windows
+
+ # Several Other issues existed. So give up parallel in this step for windows
+ extFUN <- function(z,object,useNoise) {
+ ## Subset the data to the present file keeping only spectra that
+ ## are in the peak range.
+
+ if (nrow(z)>150){z<-z[sort(sample(1:nrow(z),150)),]}
+ currentSample <- suppressMessages(MSnbase::filterRt(
+ MSnbase::filterFile(object, z[1, "sample"]),
+ rt = range(z[, c("rtmin", "rtmax")])))
+
+ corr <- unlist(sapply(seq_len(nrow(z)),FUN = function(i){
+
+ corr <- 0.1
+
+ mzRange <- z[i, c("mzmin", "mzmax")] + c(-0.001, 0.001)
+ rtRange <- z[i, c("rtmin", "rtmax")]
+
+ suppressWarnings(ints <- MSnbase::intensity(
+ MSnbase::filterMz(
+ MSnbase::filterRt(currentSample, rtRange),mzRange)))
+
+ ints[lengths(ints) == 0] <- 0
+ ints <- as.integer(unlist(ints))
+ ints <- ints[!is.na(ints)]
+ ints <- ints[ints > useNoise]
+
+ if (length(ints)) {
+
+ ints <- ints - min(ints)
+ if (max(ints) > 0)
+ ints <- ints / max(ints)
+ fit <- try(nls(y ~ SSgauss(x, mu, sigma, h),
+ data.frame(x = 1:length(ints), y = ints)),
+ silent = TRUE)
+ if (class(fit) == "try-error") {
+ corr <- 0.1
+ } else {
+ ## calculate correlation of eics against gaussian fit
+ if (sum(!is.na(ints - fitted(fit))) > 4 &&
+ sum(!is.na(unique(ints))) > 4 &&
+ sum(!is.na(unique(fitted(fit)))) > 4) {
+ cor <- NULL
+ options(show.error.messages = FALSE)
+ cor <- try(cor.test(ints, fitted(fit),
+ method = "pearson",
+ use = "complete"))
+
+ options(show.error.messages = TRUE)
+ if (!is.null(cor) && cor$p.value <= 0.05){
+ corr <- cor$estimate
+ } else if (!is.null(cor) && cor$p.value > 0.05) {
+ corr <- cor$estimate*0.85 #give a penalty (0.85) due to the unstatistical p value
+ }
+ } else {
+ corr <- 0.1
+ }
+
+
+ }
+ }
+ return(corr)
+ }))
+
+ gaussian.peak.ratio<-nrow(z[corr >= 0.9, , drop = FALSE])/nrow(z)
+
+ return(gaussian.peak.ratio)
+ }
+
+ res <- lapply(peakmat_set,
+ extFUN,
+ object=object,
+ useNoise=useNoise)
+
+ res <- unlist(res)
+
+ }
+ return(mean(sapply(res, FUN = function(x){x})))
+}
+
+#' @title Identify whether results improved or not
+#' @param history List, an interal media objects used to save the optimization results of peaks.
+#' @author Zhiqiang Pang \email{zhiqiang.pang@mail.mcgill.ca} Jeff Xia \email{jeff.xia@mcgill.ca}
+#' Mcgill University
+#' License: GNU GPL (>= 2)
+
+resultIncreased_doe <- function(history) {
+
+ index = length(history)
+ if(history[[index]]$PPS["PPS"] == 0 & index == 1)
+ stop(paste("No isotopes have been detected, Please renew the trimed method!"))
+
+ if(index < 2)
+ return(TRUE)
+
+ if(history[[index-1]]$QS >= history[[index]]$QS)
+ return(FALSE)
+
+ return(TRUE)
+
+}
+
+#' @title Noise_evaluation based on Kernal density model
+#' @description This functions handles the evaluation on the data noise (noise and prefilter parameters)
+#' and the identification on the molecule weights deviation evaluation.
+#' @param raw_data MSnExp object, the (trimmed) data in memory produced by 'PerformDataTrimming'.
+#' @export
+#' @import MSnbase
+#' @import progress
+#' @references McLean C (2020). Autotuner: Automated parameter selection for untargeted metabolomics data processing
+#' @author Zhiqiang Pang \email{zhiqiang.pang@mail.mcgill.ca} Jeff Xia \email{jeff.xia@mcgill.ca}
+#' Mcgill University
+#' License: GNU GPL (>= 2)
+
+Noise_evaluate <- function (raw_data){
+
+ mSet<-list()
+ mSet$time <- mSet$intensity <- list()
+
+ mSet$time <- split(MSnbase::rtime(raw_data),fromFile(raw_data))
+ mSet$intensity <- split(MSnbase::tic(raw_data),fromFile(raw_data))
+
+ signals <- suppressMessages(lapply(mSet$intensity,
+ FUN = function(y) {
+
+ # correct for possible NA values in data
+
+
+ lag <- 25;threshold<- 3.1;influence <- 0.1
+
+
+ signals <- rep(0,length(y))
+ filteredY <- y[seq_len(lag)]
+ avgFilter <- NULL
+ stdFilter <- NULL
+ avgFilter[lag] <- mean(y[seq_len(lag)])
+ stdFilter[lag] <- sd(y[seq_len(lag)])
+
+ for (i in (lag+1):length(y)){
+ if (abs(y[i]-avgFilter[i-1]) > threshold*stdFilter[i-1]) {
+ if (y[i] > avgFilter[i-1]) {
+ signals[i] <- 1;
+ } else {
+ signals[i] <- -1;
+ }
+ filteredY[i] <- influence*y[i]+(1-influence)*filteredY[i-1]
+ } else {
+ signals[i] <- 0
+ filteredY[i] <- y[i]
+ }
+ avgFilter[i] <- mean(filteredY[(i-lag):i])
+ stdFilter[i] <- sd(filteredY[(i-lag):i])
+
+ }
+ return(list("signals"=signals,"avgFilter"=avgFilter,"stdFilter"=stdFilter))
+ }))
+
+ factorCol <- "Groups"
+ Groups<-basename(raw_data@processingData@files)
+ metadata<-data.frame(Sample.Name=basename(fileNames(raw_data)),Groups=Groups)
+ sample_names <- paste(unlist(metadata[,factorCol]),
+ seq_len(nrow(metadata)))
+
+
+
+ # Running Algorithm to extract peaks from each sample ---------------------
+ peakList <- list()
+
+ for(index in seq_along(sample_names)) { #making peak table for each sample
+
+ ## identifying regions within TIC where peaks were identified
+
+ peaks <- rle(signals[[index]]$signals)
+ counter <- 1
+ peakGroups <- list()
+ for(rleIndex in seq_along(peaks$lengths)) {
+
+ curValue <- peaks$values[rleIndex]
+ if(curValue == 1) {
+
+ peakGroups[[counter]] <- data.frame(index = (startPoint + 1),
+ length =
+ peaks$lengths[rleIndex])
+ startPoint <- startPoint + peaks$lengths[rleIndex]
+ counter <- counter + 1
+
+ } else {
+
+ if(rleIndex == 1) {
+ startPoint <- peaks$lengths[rleIndex]
+ } else {
+ startPoint <- startPoint + peaks$lengths[rleIndex]
+ }
+
+
+ }
+
+ }
+ peakGroups <- Reduce(peakGroups, f = rbind)
+ signals[[index]]$signals[peakGroups$index[peakGroups$length
+ == 1] + 1] <- 1
+
+ #peaks <- Autotuner@time[[index]][signals[[index]]$signals == 1]
+
+ #peaks <- peaks[!is.na(peaks)]
+
+ ## getting and extracting peaks
+ #peaks
+ findPeaks <- rle(signals[[index]]$signals == 1)
+ counter <- 1
+ peakGroups <- list()
+ for(rleIndex in seq_along(findPeaks$lengths)) {
+
+ curValue <- findPeaks$values[rleIndex]
+ if(curValue) {
+
+ start <- (startPoint + 1)
+ startPoint <- startPoint + findPeaks$lengths[rleIndex]
+ end <- startPoint
+ peakGroups[[counter]] <- data.frame(start,
+ end,
+ length = end - start + 1)
+ counter <- counter + 1
+
+ } else {
+
+ if(rleIndex == 1) {
+ startPoint <- findPeaks$lengths[rleIndex]
+ } else {
+ startPoint <- startPoint + findPeaks$lengths[rleIndex]
+ }
+
+
+ }
+
+ }
+
+ peakGroups <- Reduce(rbind, peakGroups)
+
+
+ npeaks <-10
+ if(nrow(peakGroups) < 10) {
+ npeaks <- nrow(peakGroups);
+ warning("You are strongly advised to use wider rt.idx or more samples or other trimming strategy !")
+ }
+ peakGroups <- peakGroups[order(peakGroups$length, decreasing = TRUE),]
+
+ peak_times <- list()
+ for(j in seq_len(nrow(peakGroups))) {
+
+ peak_times[[j]] <- mSet$time[[index]][
+ peakGroups$start[j]:peakGroups$end[j]]
+
+ }
+
+
+ max_peak_length <- max(vapply(X = peak_times, FUN = length,
+ FUN.VALUE = numeric(1)))
+ peak_table <- data.frame(matrix(nrow = max_peak_length,
+ ncol = npeaks+1))
+ peak_table[,1] <- seq_len(max_peak_length)
+ colnames(peak_table) <- c("peakLenth",
+ paste("peak", seq_len(npeaks)))
+
+ for(column in seq(from = 2, to = ncol(peak_table))) {
+ peak <- peak_times[[column -1]]
+ peak_table[c(seq_along(peak)),column] <- peak
+ }
+
+ peak_table$peakLenth <- NULL
+ peakList[[index]] <- peak_table
+
+
+ }
+
+ names(peakList) <- sample_names
+
+
+ # initializing storage objects --------------------------------------------
+ peak_table <- data.frame()
+ counter <- 1
+ # Extracting peak width properties from all data TIC peaaks
+ for(sampleIndex in seq_along(peakList)) {
+
+ # extracting relevant info for each sample
+ time <- mSet$time[[sampleIndex]]
+ intensity <- mSet$intensity[[sampleIndex]]
+ peaks <- peakList[[sampleIndex]]
+
+ # generating peak widths for each returned peak ------------------------
+ # returns a data frame with estimated sample peakwidths
+ peakIndexTable <- data.frame()
+ for(peakColIndex in seq_len(ncol(peaks))) {
+
+ tempPeakWidthEst <- peakwidth_est(peak_vector =
+ peaks[,peakColIndex],
+ time,
+ intensity,
+ start = NULL,
+ end = NULL,
+ old_r2 = NULL)
+
+
+ #### ADD HARD CHECK HERE TO ENSURE PEAK DOESN'T GO ON FOREVER
+ if(length(time)/5 < diff(tempPeakWidthEst)) {
+ stop(paste("One peak was over 1/5 of all scans in length.",
+ "This is probably an error."))
+ }
+
+ ## 2019-06-20
+ ## Adding check to handle corner case when peak goes beyond
+ ## boundary of TIC
+ if(tempPeakWidthEst[2] > length(time)) {
+ tempPeakWidthEst[2] <- length(time)
+ }
+
+ peakIndexTable <- rbind(peakIndexTable, c(tempPeakWidthEst,
+ peakColIndex))
+
+ }
+ colnames(peakIndexTable) <- c("peakStart", "peakEnd", "peakID")
+
+
+ # Storing peakwidth info for each peak and each sample -----------------
+ # inner loop - itterating through columns of peak index table
+ for(curPeakIndexCol in seq_along(peakIndexTable$peakStart)) {
+
+ ## start and end indexes
+ start <- peakIndexTable$peakStart[curPeakIndexCol]
+ end <- peakIndexTable$peakEnd[curPeakIndexCol]
+
+
+ ## extracting peak width
+ storeRow <- data.frame(
+ peak_width = time[end] - time[start],
+ Start_time = time[start],
+ End_time = time[end],
+ Start_name = names(time)[start],
+ End_name = names(time)[end],
+ Sample = sampleIndex,
+ Mid_point_time = (time[start]+time[end])/2,
+ Max_intensity = max(intensity[start:end]),
+ ## consider changing with with which.is.max function
+ Maxima_time = time[start + which(intensity[start:end] %in%
+ max(intensity[start:end]))]
+ )
+
+ peak_table <- rbind(peak_table, storeRow)
+ counter <- counter + 1
+
+ }
+
+ }
+
+ # peak_table produced
+
+
+ # EIC param-----------------------------------------------------------------
+ pb <- progress_bar$new(format = "Evaluating [:bar] :percent Time left: :eta",
+ total = length(unique(peak_table$Sample)), clear = T, width= 75)
+
+ totalEstimates <- list()
+ for(j in unique(peak_table$Sample)) {
+
+ pb$tick();
+ #msnObj <- suppressMessages(MSnbase::readMSData(files = currentFile,
+ # mode = "onDisk",
+ # msLevel. = 1))
+ #header0 <- suppressWarnings( MSnbase::header(msnObj))
+
+
+ currentTable <- peak_table[peak_table$Sample == j,]
+
+ raw_data_current <- filterFile(raw_data,j)
+
+ header_rt <- unname(mSet[["time"]][[j]])
+ header <- MSnbase::header(raw_data_current)
+
+
+ allMzs <- MSnbase::mz(raw_data_current)
+ allInt <- MSnbase::intensity(raw_data_current)
+
+ mzDb <- list()
+ for(i in seq_along(allInt)) {
+ mzDb[[i]] <- cbind(mz = allMzs[[i]],
+ intensity = allInt[[i]])
+ }
+ rm(allMzs, allInt)
+
+ # going through each peak from a sample -----------------------------
+ pickedParams <- list()
+ for(curPeak in seq_len(nrow(currentTable))) {
+
+ #message("--- Currently on peak: ", curPeak)
+ start <- currentTable[curPeak,"Start_time"]
+ end <- currentTable[curPeak,"End_time"]
+ width <- currentTable$peak_width[curPeak]
+ observedPeak <- list(start = start, end = end)
+
+ ## currently here
+
+ rate <- mean(diff(header_rt[header$ms.level == 1L]))
+
+ scansOfPeak <- which(observedPeak$start < header_rt &
+ header_rt < observedPeak$end)
+ peakHead <- header[scansOfPeak,]
+ ms1 <- peakHead$ms.level == 1L
+
+ ## removing if statement here since everything is entered as MS1 spectra
+ ## from the get go 2019-06-19
+ #scanID <- as.numeric(sub("(.* )?scan=", "", peakHead$spectrumId[ms1]))
+
+ rm(peakHead,ms1)
+
+ peakMassSpectras <- mzDb[scansOfPeak]
+
+ for(i in seq_along(scansOfPeak)) {
+ peakMassSpectras[[i]] <- cbind(peakMassSpectras[[i]],
+ scansOfPeak[i]#,
+ #scanID[i]
+ )
+ }
+ peakMassSpectras <- Reduce(rbind, peakMassSpectras)
+ colnames(peakMassSpectras) <- c("mz", "intensity", "scan"#, "scanID"
+ )
+
+ peakMassSpectras <- data.frame(peakMassSpectras)
+
+ peakMassSpectras <- peakMassSpectras[order(peakMassSpectras$mz),]
+ peakMassSpectras <- peakMassSpectras[peakMassSpectras$intensity > 0,]
+
+ sortedAllEIC <- peakMassSpectras
+
+
+ matchedMasses <- rle(diff(sortedAllEIC$mz) < .005)
+
+ ### THIS COULD BE PLACE TO ADD NOISE FILTER TO MAKE SPEED FASTER
+ noiseAndPeaks <- filterPeaksfromNoise(matchedMasses)
+
+ no_match <- noiseAndPeaks[[1]]
+ truePeaks <- noiseAndPeaks[[2]]
+ rm(noiseAndPeaks)
+
+ approvedPeaks <- findTruePeaks(truePeaks, sortedAllEIC)
+
+ overlappingScans <- sum(approvedPeaks$multipleInScan)
+
+
+ # Filtering data by variability and ppm checks ----------------------------
+ ppmEst <- filterPpmError(approvedPeaks, useGap=T, varExpThresh,
+ returnPpmPlots=F, plotDir, observedPeak)
+
+
+ ppmObs <- approvedPeaks$meanPPM
+ ppmObs <- strsplit(split = ";", x = as.character(ppmObs))
+ ppmObs <- lapply(ppmObs, as.numeric)
+
+
+ noisyBin <- unlist(lapply(ppmObs, function(ppm) {
+ any(ppm > ppmEst)
+ }))
+
+ approvScorePeaks <- approvedPeaks[!noisyBin,]
+
+ # Estimating PeakPicking Parameters ---------------------------------------
+ SNest <- estimateSNThresh(no_match,
+ sortedAllEIC, approvScorePeaks)
+ SNest <- min(SNest)
+
+ if(is.infinite(SNest)) {
+ SNest <- 25
+ }
+
+ scanEst <- min(approvScorePeaks$scanCount)
+
+ ### Noise Intensity Estimate
+ noiseEst <- min(approvScorePeaks$minIntensity) - 1000
+ if(noiseEst < 0) {
+ noiseEst <- 0
+ }
+
+ ### Prefilter Intensity Estimate
+ intensityEst <- min(approvScorePeaks$Intensity)/sqrt(2)
+
+ estimatedPeakParams <- data.frame(ppm = ppmEst,
+ noiseThreshold = noiseEst,
+ peakCount = nrow(approvedPeaks),
+ prefilterI = intensityEst,
+ prefilterScan = scanEst,
+ TenPercentQuanSN = unname(SNest))
+
+
+ if(is.null(estimatedPeakParams)) {
+ next
+ }
+
+ pickedParams[[curPeak]] <- cbind(estimatedPeakParams,
+ startTime = start,
+ endTime = end,
+ sampleID = j)
+
+
+ }
+
+ sampleParams <- Reduce(rbind, pickedParams)
+
+ totalEstimates[[j]] <- sampleParams
+
+ }
+
+ eicParamEsts <- Reduce(rbind, totalEstimates)
+
+ param <-list()
+
+ param$ppm <- weighted.mean(eicParamEsts$ppm, eicParamEsts$peakCount)
+ param$noise <- min(eicParamEsts$noiseThreshold, na.rm = TRUE)
+ param$value_of_prefilter <- min(eicParamEsts$prefilterI, na.rm = TRUE)
+ param$prefilter <- min(eicParamEsts$prefilterScan, na.rm = TRUE)
+ #param$sn <- min(eicParamEsts$TenPercentQuanSN, na.rm = TRUE)
+
+ param
+
+
+}
+
+
+##### ------------------========= function kit from package IPO ======----------------######
+
+#' @references Gunnar Libiseller et al. 2015. IPO: a tool for automated optimization of XCMS parameters
+#' @references https://github.com/glibiseller/IPO
+
+getClusterType <- function() {
+ if( .Platform$OS.type=="unix" ) {
+ return("FORK")
+ }
+ return("PSOCK")
+}
+peaks_IPO <- function(xset) {
+
+ peaks_act <-xset@peaks
+ if (!("sample" %in% colnames(peaks_act))) {
+ colnames(peaks_act)[colnames(peaks_act) == ""] <- "sample"
+ }
+ peaks_act
+}
+calcMaximumCarbon <- function(masses) {
+
+ carbon = 12.0
+ hydrogen = 1.0078250170
+ CH3 = carbon + 3 * hydrogen
+ CH2 = carbon + 2 * hydrogen
+
+ maximum_carbon <- floor((masses-2*CH3)/CH2) + 2
+
+}
+getMaximumLevels <- function(model) {
+ # dimension of the modeled space
+ dimensions <- length(model$coding)
+
+ # define grid, to test for maximum
+ if(dimensions > 6) {
+ testSpace <- seq(-1,1,0.2) # 11 points
+ } else {
+ testSpace <- seq(-1,1,0.1) # 21 points
+ }
+
+ testSize <- 10^6 # maximum number of grid points for one test
+ # amount for testing each point in testSpace
+ testAmount <- length(testSpace)^dimensions
+ i <- 1
+ max <- rep(-1, dimensions+1) # start maximum response + setting
+ # if there are more test points (=testAmount), than testSize,
+ # then the tests are split and each subset is tested seperately
+ while(i < testAmount) {
+ testdata <- expand.grid.subset(i:(i+testSize), testSpace, dimensions)
+ if(dimensions==1)
+ names(testdata) <- names(model$coding)
+ max_tmp <- getMaxSettings(testdata, model)
+ if(max_tmp[1]>max[1]) # if better solution (i.e. test response)
+ max <- max_tmp
+ i <- i + testSize + 1
+ }
+
+ return(max)
+
+}
+getMaxSettings <- function(testdata, model) {
+
+ response <- predict(model, testdata)
+ max_response <- max(response)
+ # select row(s) corresponding to max
+ max_settings <- testdata[response==max_response,,drop=FALSE]
+ ret <- max_response
+
+ for(i in 1:ncol(testdata)) {
+ levels <- max_settings[,i] # all settings of variable i
+ if(all(c(-1,1) %in% levels)) # if both borders are in maximum settings
+ ret <- cbind(ret, NA)
+ else
+ ret <- cbind(ret,levels[1]) # take first setting
+ }
+
+ colnames(ret) <- c("response", paste("x", 1:ncol(testdata), sep=""))
+ return(ret)
+}
+expand.grid.subset <- function(subset, sequence, dimensions) {
+ # generate a list, with sequence for each dimension
+ vars <- list()
+ for(i in 1:dimensions) {
+ vars[[i]] <- sequence
+ }
+ names(vars) <- paste("x", 1:dimensions, sep="")
+
+ # number of points in sequence grid
+ maximumSubset <- length(sequence)^dimensions
+ # from min(subset)) to min(maximumSubset, max(subset)) OR
+ # from maximumSubset to maximumSubset
+ subset <- min(maximumSubset,min(subset)):min(maximumSubset, max(subset))
+
+ #nv <- #length(vars)
+ # number of values per variable = length(sequence)
+ lims <- sapply(vars,length)
+ stopifnot(length(lims) > 0, # i.e. dimensions > 0
+ subset <= prod(lims), # i.e. subset <= maximumSubset
+ length(names(vars)) == dimensions) # i.e. dimensions = dimensions
+ # empty list of length names(vars)
+ res <- structure(vector("list",dimensions), .Names = names(vars))
+
+ if (dimensions > 1) {
+ for(i in dimensions:2) { # count down to 2: set up grid top down
+ # %% = mod, %/% = integer division
+ f <- prod(lims[1:(i-1)]) # number of grid points up to variable nr. (i-1)
+ # repeat each element on grid 1:f
+ res[[i]] <- vars[[i]][(subset - 1)%/%f + 1]
+ subset <- (subset - 1)%%f + 1
+ }
+ }
+ res[[1]] <- vars[[1]][subset]
+ as.data.frame(res)
+}
+plotContours <- function(model, maximum_slice, plot_name = NULL) {
+ # generate for all variable combinations formulas
+ # (which will give the plots)
+ plots <- c()
+ for(i in 1:(length(maximum_slice)-1)) {
+ for(j in (i+1):length(maximum_slice)) {
+ plots <- c(plots, as.formula(paste("~ x", i, "* x", j, sep="")))
+ }
+ }
+
+ # determine number of plot rows and column on single device
+ plot_rows <- round(sqrt(length(plots)))
+ plot_cols <-
+ if(plot_rows==1){
+ length(plots)
+ } else {
+ ceiling(sqrt(length(plots)))
+ }
+
+ # save as jpeg, if plot_name is given
+ if(!is.null(plot_name)) {
+ plot_name = paste(plot_name, ".jpg", sep="")
+ jpeg(plot_name, width=4*plot_cols, height=2*plot_rows+2,
+ units="in", res=c(200,200))
+ } # otherwise plot on device
+
+ op <- par(mfrow = c(plot_rows, plot_cols), oma = c(0,0,0,0))
+ # contour.lm is called
+ ret_tr <- try({#may produce errors, if figure margins are too small
+ contour(model, plots, image = TRUE, at = maximum_slice)
+ })
+ if (class(ret_tr) == "try-error") {
+ message("Error in plotting (see above), but IPO continues to work normally!")
+ }
+
+ if (!is.null(plot_name)) {
+ dev.off()
+ }
+ par(op)
+}
+typeCastParams <- function(params) {
+ ret_1 <- list()
+ ret_2 <- list()
+ ret <- list()
+ for(i in 1:length(params)) {
+ factor <- params[[i]]
+ if(length(factor) == 2) {
+ ret_1[[(length(ret_1)+1)]] <- factor
+ names(ret_1)[length(ret_1)] <- names(params)[i]
+ } else {
+ ret_2[[(length(ret_2)+1)]] <- factor
+ names(ret_2)[length(ret_2)] <- names(params)[i]
+ }
+ }
+ ret$to_optimize <- ret_1
+ ret$no_optimization <- ret_2
+
+ return(ret)
+}
+getCcdParameter <- function(params) {
+
+ lower_bounds <- unlist(lapply(X=params, FUN=function(x) x[1]))
+ higher_bounds <- unlist(lapply(X=params, FUN=function(x) x[2]))
+
+ steps <- (higher_bounds - lower_bounds)/2
+
+ # formula for each parameter, that transformes values from the range
+ # to [0, 1]
+ x <- paste("x", 1:length(params), " ~ (", c(names(params)), " - ",
+ (lower_bounds + steps), ")/", steps, sep="")
+
+ # list with single formulas as entries
+ formulae <- list()
+ for(i in 1:length(x))
+ formulae[[i]] <- as.formula(x[i])
+
+ design <- rsm::ccd(length(params), # number of variables
+ n0 = 1, # number of center points
+ alpha = "face", # position of the ‘star’ points
+ randomize = FALSE,
+ inscribed = TRUE, # TRUE: axis points are at +/- 1 and the
+ # cube points are at interior positions
+ coding = formulae) # List of coding formulas for the design
+ # variables
+ return(design)
+
+}
+combineParams <- function(params_1, params_2) {
+ len <- max(unlist(sapply(params_1, length)))
+ #num_params <- length(params_1)
+
+ p_names <- c(names(params_1), names(params_2))
+ matchedFilter <- "fwhm" %in% p_names
+
+ for(i in 1:length(params_2)) {
+ new_index <- length(params_1) + 1
+ fact <- params_2[[i]]
+ params_1[[new_index]] <- fact
+ if(matchedFilter) {
+ if(p_names[new_index] == "sigma" && fact == 0) {
+ # update values for sigma if zero
+ if("fwhm" %in% names(params_1)) {
+ params_1[[new_index]][1:len] <- params_1$fwhm/2.3548
+ } else {
+ params_1[[new_index]][1:len] <- params_2$fwhm/2.3548
+ }
+ } else if(p_names[new_index] == "mzdiff" && fact == 0) {
+ # update values for mzdiff if zero
+ if("step" %in% names(params_1)) {
+ if("steps" %in% names(params_1)) {
+ params_1[[new_index]][1:len] <- 0.8-params_1$step*params_1$steps
+ } else {
+ params_1[[new_index]][1:len] <- 0.8-params_1$step*params_2$steps
+ }
+ } else {
+ if("steps" %in% names(params_1)) {
+ params_1[[new_index]][1:len] <- 0.8-params_2$step*params_1$steps
+ } else {
+ params_1[[new_index]][1:len] <- 0.8-params_2$step*params_2$steps
+ }
+ }
+ } else {
+ # standard: replicate value
+ params_1[[new_index]][1:len] <- fact
+ }
+ } else {
+ # standard: replicate value
+ params_1[[new_index]][1:len] <- fact
+ }
+ }
+ names(params_1) <- p_names
+ return(params_1)
+
+}
+getRGTVValues <- function(xset, exp_index=1, retcor_penalty=1) {
+
+ relative_rt_diff <- c()
+
+ if(nrow(xset@groups) > 0) {
+ for(i in 1:nrow(xset@groups)) {
+ feature_rtmed <- xset@groups[i, "rtmed"]
+ relative_rt_diff <-
+ c(relative_rt_diff,
+ mean(abs(feature_rtmed -
+ peaks_IPO(xset)[xset@groupidx[[i]], "rt"]) / feature_rtmed))
+ }
+ good_groups <-
+ sum(unlist(lapply(X=xset@groupidx, FUN = function(x, xset) {
+ ifelse(length(unique(peaks_IPO(xset)[x,"sample"])) ==
+ length(xset@filepaths) &
+ length(peaks_IPO(xset)[x,"sample"]) ==
+ length(xset@filepaths), 1, 0)
+ }, xset)))
+ bad_groups <- nrow(xset@groups) - good_groups
+ } else {
+ relative_rt_diff <- 1
+ good_groups <- 0
+ bad_groups <- 0
+ }
+
+ tmp_good_groups <- good_groups + ifelse(bad_groups==0, 1, 0)
+ tmp_bad_groups <- bad_groups + ifelse(bad_groups==0, 1, 0)
+
+ ARTS <- (mean(relative_rt_diff)) * retcor_penalty
+
+ ret <- list(exp_index = exp_index,
+ good_groups = good_groups,
+ bad_groups = bad_groups,
+ GS = tmp_good_groups^2/tmp_bad_groups,
+ RCS = 1/ARTS)
+
+ ret$retcor_done = retcor_penalty
+
+ return(ret)
+}
+findIsotopes.IPO <- function(xset, checkPeakShape=c("none", "borderIntensity", "sinusCurve", "normalDistr")) {
+
+ checkPeakShape <- match.arg(checkPeakShape)
+
+ iso_mat <- matrix(0, nrow=0, ncol=2)
+ if(is.null(xset)) {
+ return(iso_mat)
+ }
+
+ colnames(iso_mat) <- c("12C", "13C")
+ peak_source <- peaks_IPO(xset)[,c("mz", "rt", "sample", "into", "maxo", "mzmin",
+ "mzmax", "rtmin", "rtmax"), drop=FALSE]
+
+ for(i in 1:ncol(peak_source)) {
+ peak_source <- peak_source[!is.na(peak_source[,i]),,drop=FALSE]
+ }
+
+ peak_source <- cbind(1:nrow(peak_source), peak_source)
+ colnames(peak_source)[1] <- "id"
+
+ #carbon = 12.0
+ #hydrogen = 1.0078250170
+ #CH3 = carbon + 3 * hydrogen
+ #CH2 = carbon + 2 * hydrogen
+ isotope_mass = 1.0033548
+ isotope_abundance = 0.01108
+
+ samples <- max(peak_source[,"sample"])
+
+ #start_sample
+ for(sample in 1:samples) {
+ #only looking into peaks from current sample
+ speaks <- peak_source[peak_source[,"sample"]==sample,,drop=FALSE]
+ split <- 250
+ if(!(checkPeakShape=="none"))
+ # rawdata <- loadRaw(xcmsSource(xset@filepaths[sample]))
+ stop("Other PeakShapeChecking Method will be supported later !")
+
+ if(nrow(speaks)>1) {
+ #speaks <- speaks[,-c("sample")]
+ speaks <- speaks[order(speaks[,"mz"]),]
+
+ while(!is.null(nrow(speaks)) & length(speaks) > 3) {
+ part_peaks <- NULL
+ #splitting the data into smaller pieces to improve speed
+ if(nrow(speaks) < split) {
+ part_peaks <- speaks
+ } else {
+ upper_bound <- speaks[split,"mzmax"] + isotope_mass
+ end_point <- sum(speaks[,"mz"] < upper_bound)
+ part_peaks <- speaks[1:end_point,,drop=FALSE]
+ }
+
+ rt <- part_peaks[,"rt"]
+ rt_window <- rt * 0.005
+ rt_lower <- part_peaks[,"rt"] - rt_window
+ rt_upper <- part_peaks[,"rt"] + rt_window
+ rt_matrix <-
+ t(matrix(rep(rt, nrow(part_peaks)), ncol=nrow(part_peaks)))
+ rt_matrix_bool <- rt_matrix >= rt_lower & rt_matrix <= rt_upper
+
+ mz <- part_peaks[,"mz"]
+ #isotope_masses - mz_window
+ mz_lower <- part_peaks[,"mzmin"] + isotope_mass
+ #isotope_masses + mz_window
+ mz_upper <- part_peaks[,"mzmax"] + isotope_mass
+ mz_matrix <-
+ t(matrix(rep(mz, nrow(part_peaks)), ncol=nrow(part_peaks)))
+ mz_matrix_bool <- mz_matrix >= mz_lower & mz_matrix <= mz_upper
+
+ rt_mz_matrix_bool <- rt_matrix_bool & mz_matrix_bool
+
+ rt_mz_peak_ids <- which(rowSums(rt_mz_matrix_bool)>0)
+ calculations <- min(split, nrow(speaks))
+ rt_mz_peak_ids <- rt_mz_peak_ids[rt_mz_peak_ids < calculations]
+
+ for(i in rt_mz_peak_ids) {
+ current <- part_peaks[i, ,drop=FALSE]
+ rt_mz_peaks <- part_peaks[rt_mz_matrix_bool[i,],,drop=FALSE]
+ rt_difference <-
+ abs(current[,"rt"] - rt_mz_peaks[, "rt"]) / current[,"rt"]
+ rt_mz_peaks <- cbind(rt_mz_peaks, rt_difference)
+ #test intensity_window
+ #floor((current["mz"]-2*CH3)/CH2) + 2
+ maximum_carbon <- calcMaximumCarbon(current[,"mz"])
+ carbon_probabilty <- c(1,maximum_carbon)*isotope_abundance
+ iso_intensity <- current[,"into"] * carbon_probabilty
+
+ int_bools <-
+ rt_mz_peaks[,"into"] >= iso_intensity[1] &
+ rt_mz_peaks[,"into"] <= iso_intensity[2]
+
+ if(sum(int_bools) > 0) {
+ int_peaks <- rt_mz_peaks[int_bools,,drop=FALSE]
+ boundary_bool <- rep(TRUE, (nrow(int_peaks)+1))
+ if(!(checkPeakShape=="none")) {
+ if(checkPeakShape=="borderIntensity") {
+ boundary_bool <- checkIntensitiesAtRtBoundaries(
+ rawdata,
+ rbind(current,int_peaks[,-ncol(int_peaks), drop=FALSE]))
+ } else {
+ if(checkPeakShape=="sinusCurve") {
+ boundary_bool <- checkSinusDistribution(
+ rawdata,
+ rbind(current,int_peaks[,-ncol(int_peaks),drop=FALSE]))
+ } else {
+ boundary_bool <- checkNormalDistribution(
+ rawdata,
+ rbind(current,int_peaks[,-ncol(int_peaks),drop=FALSE]))
+ }
+ }
+ } #else {
+ #boundary_bool <- rep(TRUE, (nrow(int_peaks)+1))
+ #}
+ if(boundary_bool[1] & sum(boundary_bool[-1])>0) {
+ iso_peaks <- int_peaks[boundary_bool[-1],,drop=FALSE]
+ iso_id <-
+ iso_peaks[which.min(iso_peaks[,"rt_difference"]), "id"]
+ #iso_list[[length(iso_list)+1]] <- c(current[,"id"], iso_id)
+ iso_mat <- rbind(iso_mat, c(current[,"id"], iso_id))
+ }
+ }
+ }
+ speaks <- speaks[-(1:calculations),]
+
+ }#end_while_sample_peaks
+ }
+ }
+ return(iso_mat)
+ }
+checkIntensitiesAtRtBoundaries <- function(rawdata, peaks, minBoundaryToMaxo=1/3,ppmstep=15) {
+ ret <- rep(TRUE, nrow(peaks))
+ for(i in 1:nrow(peaks)) {
+ peak <- peaks[i,]
+ for(boundary in c("rtmin", "rtmax")) {
+ rtIndex <- which(rawdata$rt==peak[boundary])
+ if(length(rtIndex)>0) {
+ if(rtIndex==length(rawdata$scanindex)) {
+ rtIndices <- c(rawdata$scanindex[rtIndex], length(rawdata$mz))
+ } else {
+ rtIndices <- rawdata$scanindex[c(rtIndex, rtIndex+1)]
+ }
+
+ #only relevant mz and intensity values regarding retention time
+ mz <- rawdata$mz[(rtIndices[1]+1):rtIndices[2]]
+ intensities <- rawdata$intensity[(rtIndices[1]+1):rtIndices[2]]
+
+ ppm <- peak[c("mzmin", "mzmax")]*ppmstep/1000000
+ mzIntensities <-
+ c(0, intensities[mz>=peak["mzmin"]-ppm[1] & mz<=peak["mzmax"]+ppm[2]])
+ maxBoundaryIntensity <- max(mzIntensities)
+ ret[i] <- ret[i] & maxBoundaryIntensity<peak["maxo"]*minBoundaryToMaxo
+ }
+ }
+ }
+
+ return(ret)
+
+ }
+checkSinusDistribution <- function(rawdata, peaks) {
+ ret <- rep(TRUE, nrow(peaks))
+ for(i in 1:nrow(peaks)) {
+ ret[i] <- testSinusDistribution(rawdata, peaks[i,,drop=FALSE])
+ }
+
+ return(ret)
+}
+checkNormalDistribution <- function(rawdata, peaks) {
+ ret <- rep(TRUE, nrow(peaks))
+ for(i in 1:nrow(peaks)) {
+ ret[i] <- testNormalDistribution(rawdata, peaks[i,,drop=FALSE])
+ }
+
+ return(ret)
+}
+getIntensitiesFromRawdata <- function(rawdata, peak) {
+ rt <- rawdata$rt >= peak[,"rtmin"] & rawdata$rt <= peak[,"rtmax"]
+
+ rtRange <- c(min(which(rt)), max(which(rt))+1)
+ scanIndices <-
+ rawdata$scanindex[rtRange[1]:min(rtRange[2], length(rawdata$scanindex))]
+ # scanIndices <- scanIndices[!is.na(scanIndices)]
+ if(rtRange[2]>length(rawdata$scanindex)) {
+ scanIndices <- c(scanIndices, length(rawdata$intensity))
+ }
+
+ if(length(scanIndices) < 3)
+ return(FALSE)
+
+ y <- c()
+ for(i in 1:(length(scanIndices)-1)) {
+ scanRange <- c(scanIndices[i]+1, scanIndices[i+1])
+ mz <- rawdata$mz[scanRange[1]:scanRange[2]]
+ y <-
+ c(y,
+ max(0, (rawdata$intensity[scanRange[1]:scanRange[2]][
+ mz >= peak[,"mzmin"] & mz <= peak[,"mzmax"]])
+ )
+ )
+ }
+
+ y
+}
+testNormalDistribution <- function(rawdata, peak) {
+
+ y <- getIntensitiesFromRawdata(rawdata, peak)
+ if(length(y) < 3) {
+ return(FALSE)
+ }
+
+ if(max(y)==0) {
+ return(FALSE)
+ }
+
+ normY <- (y-min(y))/(max(y)-min(y))
+
+ mean=10;
+ sd=3;
+
+ seqModel <- seq(-4,4,length=length(normY))*sd + mean
+ yModel <- dnorm(seqModel,mean,sd)
+ yModel = yModel* (1/max(yModel))
+ correlation <- cor(yModel, normY)
+
+ correlation > 0.7
+
+
+}
+testSinusDistribution <- function(rawdata, peak) {
+
+ y <- getIntensitiesFromRawdata(rawdata, peak)
+ if(length(y) < 3) {
+ return(FALSE)
+ }
+ if(max(y)==0) {
+ return(FALSE)
+ }
+
+ normY <- (y-min(y))/(max(y)-min(y))
+ sinCurve <- (sin(seq(-pi/2,pi+1.5,length=length(normY))) + 1) / 2
+ correlation <- cor(sinCurve, normY)
+
+ correlation > 0.7
+
+}
+findIsotopes.CAMERA <- function(xset, ...) {
+
+ iso_mat <- matrix(0, nrow=0, ncol=2)
+ if(is.null(xset)) {
+ return(iso_mat)
+ }
+
+ ids <- peaks_IPO(xset)[,"sample", drop=FALSE]
+ ids <- cbind(1:length(ids), ids)
+
+ xsets <- split(xset, unique(peaks_IPO(xset)[,"sample"]))
+ samples <- unique(peaks_IPO(xset)[,"sample"])
+ for(sample in samples) {
+ an <- xsAnnotate(xset, sample=sample)
+ isos <- findIsotopes(an, ...)@isoID[,c("mpeak", "isopeak"), drop=FALSE]
+ #start_id <- ids[ids[,2]==sample,,drop=FALSE][1,1] - 1
+ iso_mat <- rbind(iso_mat, matrix(ids[ids[,2]==sample,1][isos], ncol=2))
+ }
+
+ iso_mat
+ }
+createModel <- function(design, params, resp) {
+ # add response to the design, which gives the data for the model
+ design$resp <- resp
+ if(length(params) > 1) {
+ # create full second order (SO) model
+ # use xi in model, instead of parameter names
+ formula <-
+ as.formula(paste("resp ~ SO(",
+ paste("x", 1:length(params),
+ sep="", collapse=","),
+ ")", sep=""))
+ model <- rsm:::rsm(formula, data=design)
+ } else {
+ # create full second order model with one parameter
+ # here: use parameter name in model
+ param_name <- names(params)[1]
+ formula <- as.formula(paste("resp ~ ", param_name, " + ",
+ param_name, " ^ 2", sep=""))
+ model <- lm(formula, data=design)
+ model$coding <- list(x1=as.formula(paste(param_name, "~ x1")))
+ names(model$coding) <- param_name
+ #attr(model, "class") <- c("rsm", "lm")
+ }
+ return(model)
+}
+decode <- function(value, bounds) {
+ if(is.na(value))
+ value <- 1
+ x <- (value+1)/2 # from [-1,1] to [0, 1]
+ x <- (x*(max(bounds)-min(bounds))) + min(bounds)
+
+ return(x)
+}
+decodeAll <- function(values, params) {
+
+ ret <- rep(0, length(params))
+ for(i in 1:length(params))
+ ret[i] <- decode(values[i], params[[i]])
+
+ names(ret) <- names(params)
+
+ return(ret)
+}
+encode <- function(value, bounds) {
+ x <- (value - min(bounds)) / (max(bounds) - min(bounds))
+
+ return(x*2-1)
+}
+attachList <- function(params_1, params_2) {
+ params <- params_1
+ for(factor in params_2)
+ params[[length(params)+1]] <- factor
+
+ names(params) <- c(names(params_1), names(params_2))
+ return(params)
+}
+checkParams <- function(params, quantitative_parameters,qualitative_parameters, unsupported_parameters) {
+ if(length(typeCastParams(params)$to_optimize)==0) {
+ stop("No parameters for optimization specified; stopping!")
+ }
+
+ for(i in 1:length(params)) {
+ param <- params[[i]]
+ name <- names(params)[i]
+ if(name %in% unsupported_parameters) {
+ stop(paste("The parameter", name, "is not supported! Please remove
+ from parameters; stopping!"))
+ }
+ if(name %in% qualitative_parameters) {
+ if(length(param) == 0) {
+ stop(paste("The parameter", name, "has no value set!
+ Please specify; stopping!"))
+ }
+ if(length(param) > 1) {
+ stop(paste("Optimization of parameter", name, "not supported!
+ Please specify only one value; stopping!"))
+ }
+ }
+ if(name %in% quantitative_parameters) {
+ if(length(param) == 0) {
+ stop(paste("The parameter", name, "has no value set!
+ Please specify between one and two; stopping!"))
+ }
+ if(length(param) > 2) {
+ stop(paste("Too many values for parameter", name, "!
+ Please specify only one or two; stopping!"))
+ }
+ if(!all(diff(param) > 0)) {
+ stop(paste("Parameter", name, "has wrong order!",
+ "Please specify in increasing order; stopping!"))
+ }
+ }
+ }
+ missing_params <-
+ which(!(c(quantitative_parameters, qualitative_parameters) %in%
+ names(params)))
+ if(length(missing_params > 0)) {
+ stop(paste("The parameter(s)",
+ paste(c(quantitative_parameters,
+ qualitative_parameters)[missing_params],
+ collapse=", "),
+ "is/are missing! Please specify; stopping!"))
+ }
+
+}
+
+
+#
+##### -----------------========== Bottom of this function kit ======----------------######
+
+
+###########--------------- ========= Function Kit from AutoTuner =========-----------------
+#' @references McLean C (2020). Autotuner: Automated parameter selection for untargeted metabolomics data processing
+#' @references https://github.com/crmclean/Autotuner/
+
+
+filterPeaksfromNoise <- function(matchedMasses) {
+
+ ## Initializing variables for subsetting
+ if(length(matchedMasses$values) %% 2 == 0) {
+ list_length <- length(matchedMasses$values)/2
+ } else {
+ list_length <- as.integer(length(matchedMasses$values)/2) + 1
+ }
+ truePeaks <- vector("list", list_length)
+ truePeakIndex <- 1
+ lengthCounter <- 1
+ lastTrue <- matchedMasses$values[1]
+
+ ## subsets things that have a second mass w/in user error
+ for(rleIndex in seq_along(matchedMasses$values)) {
+
+ start <- lengthCounter
+
+ if(lastTrue == TRUE) {
+ start <- start + 1
+ }
+
+ end <- lengthCounter + matchedMasses$lengths[rleIndex] - 1
+
+ if(isTRUE(matchedMasses$values[rleIndex])) {
+ end <- end + 1
+ lastTrue = TRUE
+ truePeaks[[truePeakIndex]] <- start:end
+ truePeakIndex <- truePeakIndex + 1
+ } else {
+ lastTrue = FALSE
+ if(!exists("no_match")) {
+ no_match <- start:end
+ } else {
+ no_match <- c(no_match, start:end)
+ }
+
+ }
+ lengthCounter <- lengthCounter + matchedMasses$lengths[rleIndex]
+ }
+
+ if(is.null(truePeaks[[list_length]])) {
+ truePeaks <- truePeaks[seq_len(list_length - 1)]
+ }
+
+ rm(list_length,truePeakIndex,lastTrue,lengthCounter,start,end,rleIndex)
+ return(list(no_match, truePeaks))
+}
+findTruePeaks <- function(truePeaks, sortedAllEIC) {
+ #
+
+ # initializing storage ----------------------------------------------------
+ ppmData <- list()
+ counter <- 1
+
+ # Checking if bin elements come from adj scans ----------------------------
+ for(i in seq_along(truePeaks)) {
+
+ pickedPeak <- truePeaks[[i]]
+
+ peakData <- sortedAllEIC[pickedPeak,]
+ peakData <- peakData[order(peakData$scan),]
+
+ # remove features that are duplicated. -------------------------------
+ if(nrow(peakData) == 1) {
+ next()
+ }
+
+ ## checking to make sure features comes from adjacent scans
+ scanDiff <- diff(sort(unique(peakData$scan)))
+
+ ## checking that binned peaks:
+ # are being picked up within consecutive scans
+ peakDists <- (length(unique(scanDiff)) == 1 && unique(scanDiff) == 1)
+ if(!peakDists) {
+ next()
+ }
+
+ ## checking to see if any binned masses come from the same scan
+ countsInScans <- table(peakData$scan)
+ moreInAScan <- any(as.vector(countsInScans) > 1)
+
+ if(moreInAScan) {
+
+ for(w in seq_len(length(unique(peakData$scan)) - 1)) {
+
+ curScan <- unique(peakData$scan)[w]
+ nextScan <- unique(peakData$scan)[w+1]
+
+ ### add condition here for whenever it is the end of the scan
+
+ scanStates <- peakData[peakData$scan == curScan,]
+ nextStates <- peakData[peakData$scan == nextScan,]
+ curObsRows <- peakData$scan == curScan | peakData$scan ==
+ nextScan
+
+ peakData <- peakData[!curObsRows,]
+
+ ## do this if there are two states in first scan
+
+ if(w == 1) {
+
+ errorNext <- lapply(scanStates$mz, function(x) {
+ obsError <- abs(x - nextStates$mz)/x * 10^6
+ })
+
+ checkMins <- vapply(X = errorNext, FUN = which.min,
+ FUN.VALUE = numeric(1))
+
+ initialState <- which.min(vapply(X = seq_along(errorNext),
+ FUN = function(x) {
+ errorNext[[x]][checkMins[x]]
+ }, FUN.VALUE = numeric(1)))
+
+ scanStates <- scanStates[initialState,]
+ }
+
+ nextStateIndex <- which.max(vapply(X = scanStates$mz, FUN = function(x) {
+
+ obsError <- abs(x - nextStates$mz)/x * 10^6
+
+
+ if(any(obsError == 0)) {
+
+ ## corner case - error is 0 and there are no other
+ ## options
+ if(length(x) == 1) {
+ obsError <- 0.001
+ } else {
+ obsError[obsError == 0] <-
+ min(obsError[obsError != 0])/10
+ }
+
+ }
+
+ intensityProb <- nextStates$intensity/
+ sum(nextStates$intensity)
+ errorInverse <- 1/obsError
+ nextStateProb <- errorInverse/sum(errorInverse) *
+ intensityProb
+ return(max(nextStateProb/sum(nextStateProb)))
+
+ }, FUN.VALUE = numeric(1)))
+
+ nextStates <- nextStates[nextStateIndex,]
+
+ ## store new states
+ bestStates <- rbind(scanStates,nextStates)
+ peakData <- rbind(bestStates, peakData)
+ peakData <- peakData[order(peakData$scan),]
+
+ }
+
+ multipleInScan <- TRUE
+
+ } else {
+
+ multipleInScan <- FALSE
+ }
+
+ obsPPM <- vapply(X = 2:length(peakData$mz), FUN = function(mz) {
+ estimatePPM(peakData$mz[(mz - 1)], peakData$mz[mz])
+ }, FUN.VALUE = numeric(1))
+
+ # storing output -------------------------------------------------------
+ ppmData[[counter]] <- data.frame(meanMZ = mean(peakData$mz),
+ startScan = min(peakData$scan),
+ endScan = max(peakData$scan),
+ scanCount = length(peakData$scan),
+ Intensity = sum(peakData$intensity),
+ meanIntensity = mean(
+ peakData$intensity),
+ intensityDispersion = sd(
+ peakData$intensity),
+ minIntensity = min(peakData$intensity),
+ meanPPM = paste(signif(obsPPM),
+ collapse = ";"),
+ multipleInScan,
+ stringsAsFactors = FALSE,
+ index = i)
+
+ counter <- 1 + counter
+
+ }
+ approvedPeaks <- Reduce(rbind, ppmData)
+ return(approvedPeaks)
+}
+estimatePPM <- function(first, second) {
+ abs(first-second)/first * 10 ^ 6
+}
+estimateSNThresh <- function(no_match, sortedAllEIC, approvedPeaks) {
+
+ noisePeakTable <- sortedAllEIC[no_match,]
+ noise_noise <- noisePeakTable$intensity
+ scanCount <- sortedAllEIC$scan
+ maxScan <- max(scanCount, na.rm = TRUE)
+ minScan <- min(scanCount, na.rm = TRUE)
+ scanCount <- scanCount[no_match]
+
+ ## generating index for subseting of fixed noise obj
+ scanIntervals <- list()
+ for(peakID in seq_len(nrow(approvedPeaks))) {
+
+ peakStart <- approvedPeaks[peakID,"startScan"]
+ peakEnd <- approvedPeaks[peakID,"endScan"]
+ peakDist <- peakEnd - peakStart
+ lowerBound <- peakStart - peakDist * 2
+
+ if(lowerBound < minScan) {
+ lowerBound <- minScan
+ }
+
+ upperBound <- peakEnd + peakDist * 2
+ if(upperBound > maxScan) {
+ upperBound <- maxScan
+ }
+
+ scanIntervals[[peakID]] <- which(minScan:maxScan %in% c(lowerBound,
+ upperBound))
+
+
+ }
+
+ ## calculating all fixed noise values
+ scanRange <- (minScan:maxScan)
+ fixedNoiseList <- list()
+ counter <- 1
+ for(scanID in seq_along(scanRange)) {
+
+ peakNoise <- noise_noise[scanCount == scanRange[scanID]]
+
+ if(length(peakNoise) == 0) {
+ next
+ }
+
+ fixedNoise <- peakNoise[!(peakNoise %in% boxplot.stats(peakNoise)$out)]
+
+ fixedNoiseMean <- mean(x = fixedNoise, na.rm = TRUE)
+ fixedNoiseVar <- stats::var(x = fixedNoise, na.rm = TRUE)
+
+ ## 2019-07-08: fixed corner case where only one noise element was
+ ## found within the bin
+ if(is.na(fixedNoiseVar)) {
+ fixedNoiseVar <- 0
+ }
+
+ N <- length(fixedNoise)
+
+ fixedNoiseList[[counter]] <- data.frame(fixedNoiseMean,fixedNoiseVar,N)
+ counter <- 1 + counter
+ }
+ fixedNoiseList <- Reduce(rbind, fixedNoiseList)
+
+ ## calculating the sd and mean for each group
+ noiseIntDb <- list()
+ counter <- 1
+ for(row in seq_along(scanIntervals)) {
+
+ if(row == 1) {
+
+ new <- TRUE
+
+ } else {
+
+ new <- vapply(X = noiseIntDb, FUN = function(noiseDb) {
+ if(!all(scanIntervals[[row]] == as.numeric(noiseDb[,c(1,2)]))) {
+ return(TRUE)
+ } else {
+ return(FALSE)
+ }
+ }, FUN.VALUE = logical(1))
+ new <- all(new)
+ }
+
+
+ if(new) {
+ ## add check to see if cur row has already been looked at
+ curRow <- scanIntervals[[row]]
+ curStatDb <- fixedNoiseList[curRow[1]:curRow[2],]
+
+ ## added this to check for case when row is missing
+ ## if a match to the noise peak was not identified
+ if(any(is.na(curStatDb$fixedNoiseMean))) {
+ curStatDb <- curStatDb[!is.na(curStatDb$fixedNoiseMean),]
+ }
+
+ eX2 <- sum((curStatDb$fixedNoiseMean^2 +
+ curStatDb$fixedNoiseVar)*curStatDb$N)
+ eX2 <- eX2/sum(curStatDb$N)
+ groupMean <- mean(curStatDb$fixedNoiseMean)
+ groupVar <- eX2 - groupMean^2
+
+ if(groupVar < 0) {
+ groupVar <- groupVar * -1
+ }
+
+ groupSd <- suppressWarnings(sqrt(groupVar))
+ noiseIntDb[[counter]] <- data.frame(start = curRow[1],
+ end = curRow[2], groupMean,
+ groupSd)
+ counter <- counter + 1
+ }
+
+ }
+
+ noiseIntDb <- Reduce(rbind, noiseIntDb)
+ noiseIntDb$key <- apply(noiseIntDb[,c(1,2)], 1, paste, collapse = " ")
+ rm(curStatDb, eX2, groupSd, groupVar, groupMean,
+ curRow, fixedNoiseList)
+
+
+ SN <- list()
+ counter <- 1
+ for(peakID in seq_along(scanIntervals)) {
+
+ scanInt <- paste(scanIntervals[[peakID]], collapse = " ")
+ scanStats <- noiseIntDb[noiseIntDb$key == scanInt,]
+
+ if(nrow(scanStats) == 0) {
+ next()
+ }
+
+ ## 2019-06-20 - added here to fix bug if noise calc is wrong
+ if(is.nan(scanStats$groupSd) | is.na(scanStats$groupSd)) {
+ next()
+ }
+
+ if(is.nan(scanStats$groupMean)) {
+ next()
+ }
+
+ Peak <- approvedPeaks$Intensity[peakID]
+
+ if((Peak - scanStats$groupMean) > 3*scanStats$groupSd) {
+
+ ## selects as true peak
+ SigNoiseThresh <- (Peak - scanStats$groupMean)/scanStats$groupSd
+ SN[[counter]] <- SigNoiseThresh
+ counter <- counter + 1
+
+ } else {
+
+ next()
+
+ }
+ }
+
+ if(!exists("SN")) {
+ return(NA)
+ }
+
+ return(unlist(SN))
+}
+filterPpmError <- function(approvedPeaks, useGap, varExpThresh,
+ returnPpmPlots, plotDir, observedPeak,
+ filename) {
+
+ ppmObs <- approvedPeaks$meanPPM
+ ppmObs <- unlist(lapply(strsplit(split = ";", x = as.character(ppmObs)),function(x) {as.numeric(x)}))
+
+ ## 2019-06-19
+ ## corner case when all error measurements are identical.
+ if(diff(range(ppmObs)) < .Machine$double.eps ^ 0.5) {
+ stop(paste("All calculated ppm values are identical.",
+ "Error of data may be higher than the mass threshold value."
+ ))
+ }
+
+ #message("-------- Number of ppm value across bins: ", length(ppmObs))
+ if(length(ppmObs) > 10000) {
+ ppmObs <- ppmObs[sample(x = seq_along(ppmObs), size = 5000)]
+ }
+
+ if(length(ppmObs) > 750) {
+
+ checkPpm <- length(ppmObs)/2
+ subsample <- TRUE
+ while(subsample) {
+
+ origDist <- stats::density(ppmObs, bw = 1)$y
+ newDist1 <- stats::density(sample(ppmObs, checkPpm), bw = 1)$y
+ newDist2 <- stats::density(sample(ppmObs, checkPpm), bw = 1)$y
+ newDist3 <- stats::density(sample(ppmObs, checkPpm), bw = 1)$y
+ newDist4 <- stats::density(sample(ppmObs, checkPpm), bw = 1)$y
+ newDist5 <- stats::density(sample(ppmObs, checkPpm), bw = 1)$y
+ newDist6 <- stats::density(sample(ppmObs, checkPpm), bw = 1)$y
+ newDist7 <- stats::density(sample(ppmObs, checkPpm), bw = 1)$y
+
+ klDistance <- list()
+ subSamples <- ls()[grep("newDist",ls())]
+ for(j in seq_along(subSamples)) {
+ klDistance[[j]] <- suppressWarnings(entropy::KL.empirical(
+ origDist,get(subSamples[j])))
+ }
+ klDistance <- unlist(klDistance)
+
+ if(any(klDistance >= 0.5)) {
+ subsample <- FALSE
+ } else {
+ checkPpm <- checkPpm/2
+ }
+
+ }
+
+ ppmObs <- sample(ppmObs, checkPpm)
+ #message("-------- Number of ppm value across bins after",
+ # " KL Distance Filtering: ",
+ # length(ppmObs))
+
+ }
+
+
+ ## 2019-04-09 added this here since it doesn't make sense to cluster too few
+ ## features
+ if(length(ppmObs) < 100) {
+
+ kmeansPPM <- kmeans(ppmObs, 1)
+
+ } else if(useGap) {
+
+ gapStat <- cluster::clusGap(x = as.matrix(ppmObs),
+ FUNcluster = kmeans,
+ K.max = 5,
+ B = 7,
+ verbose = FALSE)
+
+ gapStat <- gapStat$Tab
+ gap <- diff(-gapStat[,3]) > 0
+ if(any(gap)) {
+ clusters <- max(which(gap)) + 1
+ } else {
+ clusters <- 1
+ }
+
+ kmeansPPM <- kmeans(ppmObs, clusters)
+
+ } else {
+
+
+ ## estimating clustering based on hard coded 80% Vexp threshold
+ clustCount <- 1
+ varExp <- 0
+ while(varExp < varExpThresh && clustCount < length(ppmObs)/2) {
+ kmeansPPM <- kmeans(ppmObs, clustCount)
+ varExp <- kmeansPPM$betweenss/kmeansPPM$totss
+ clustCount <- clustCount + 1
+ }
+
+ }
+
+ ## cluster which contains smallest ppm values
+ clusterSize <-sort(table(kmeansPPM$cluster),decreasing = TRUE)
+ maxCluster <- names(clusterSize)[1]
+ minCluster <- which(kmeansPPM$cluster == maxCluster)
+ rm(clusterSize)
+
+ x <- ppmObs
+ n <- length(x)
+ h <- 1
+ ## delete this later
+ gauss <- function(x) 1/sqrt(2*pi) * exp(-(x^2)/2)
+ gaussDKE <- function(a, x) gauss((x - a)/h)/(n * h)
+
+ bumps <- vapply(X = ppmObs[minCluster], FUN = gaussDKE, x = x,
+ FUN.VALUE = numeric(length = length(x)))
+ wholeKDE <- vapply(X = ppmObs, FUN = gaussDKE,
+ x,
+ FUN.VALUE = numeric(length =
+ length(x)))
+
+ ## calculating this ahead of time to avoid unnecessary downstream
+ ## math
+ cKdeMean <- sum(rowSums(bumps))/length(minCluster)
+ OutlierScore <- rowSums(wholeKDE)/(cKdeMean)
+
+ scoreSub <- which(OutlierScore > 1)
+
+
+ ppmEst <- max(ppmObs[scoreSub])
+ maxX <- ppmEst
+ ppmEst <- ppmEst + sd(ppmObs[scoreSub])*3
+
+
+ if(returnPpmPlots) {
+
+
+ title <- paste(filename, 'ppm distribution:',
+ signif(observedPeak$start, digits = 4),
+ "-",
+ signif(observedPeak$end, digits = 4))
+
+ output <- file.path(plotDir,paste0(gsub(" ", "_", title), ".pdf"))
+ output <- sub(":", "", output)
+
+ ## error here...
+ par(mar=c(1,1,1,1))
+ grDevices::pdf(output, width = 8, height = 6)
+
+ ## adding heuristic here to make ploting easier to see
+ if(length(ppmObs) < 300) {
+ bw <- .1
+ } else {
+ bw <- .5
+ }
+
+ plot(stats::density(ppmObs,bw = bw),
+ main = title,
+ cex.main = 1.2, cex.lab = 1.3, cex.axis = 1.2) #+
+ abline(v = maxX, lty = 2, col = "red") +
+ abline(v = ppmEst, lty = 3, col = "blue")
+ legend("topright",
+ legend = c(paste("score > 1:", signif(maxX,digits = 3)),
+ paste("ppm estimate:", signif(ppmEst,digits = 3))),
+ col = c("red","blue"),
+ lty = c(2,3),cex = 1.1)
+ grDevices::dev.off()
+
+ }
+
+ return(ppmEst)
+}
+peakwidth_est <- function(peak_vector,
+ time,
+ intensity,
+ start = NULL,
+ end = NULL,
+ old_r2 = NULL) {
+
+
+ killSwitch <- FALSE
+
+ # check to make sure input values come from vector
+ if(!is.numeric(peak_vector)) {
+ warning(paste("A non numeric vector was given to peakwidth_est().",
+ "This is incorrect. Check the function input."))
+ }
+
+ # updating data values to put into regression
+
+ if(!is.null(start)) { # case where we are in second + iteration of algorithm
+
+ end <- end + 1
+
+ } else { # case where the algorithm is run for the first time
+
+ peak_index <- which(time %in% peak_vector)
+ if(length(peak_index) == 0) {
+ stop(paste("The peak entered here could not be matched to the",
+ "chromatography data."))
+ }
+
+ start <- peak_index[1] - 1
+ end <- peak_index[length(peak_index)]
+
+ }
+
+ # terms for lm
+ points <- c(start,start-1,start-2,start-3,end,end+1,end+2,end+3)
+ intensityObs <- intensity[points]
+ modelIndex <- seq_along(intensityObs)
+
+ # correcting na formation within intensity observation vector
+ if(any(is.na(intensityObs))) {
+
+ naObsIndex <- which(is.na(intensityObs))
+ modelIndex <- modelIndex[-naObsIndex]
+ intensityObs <- intensityObs[-naObsIndex]
+ killSwitch <- TRUE
+
+ }
+
+ # running smoothing spline on the data
+ if(sum(!is.na(peak_vector)) > 1) {
+ splineOut <- smooth.spline(modelIndex, intensityObs)
+ splineObs <- splineOut$fit$coef
+ splineIndex <- seq_along(splineObs)
+ } else {
+ splineObs <- intensityObs
+ }
+ splineIndex <- seq_along(splineObs)
+
+ # running a linear model on the outcome of the spline
+ chrom_table <- data.frame(splineIndex, splineObs)
+ model <- lm(formula = splineObs ~ splineIndex, data = chrom_table)
+ new_r2 <- summary(model)$r.squared
+
+ # used for comparison with previous itterations
+ if(is.null(old_r2)) {
+ old_r2 <- 0
+ }
+
+ # recursive case - returns previously calculated model fit if improvement
+ if((old_r2 > new_r2 | old_r2 > .9) | killSwitch == TRUE) {
+
+ # make sure to return numerical index of fit - not the values being compared
+ peak_width <- c(peakStart = start-3, peakEnd = end+3)
+ return(peak_width)
+
+ } else {
+ peakwidth_est(peak_vector, time, intensity, start,
+ end, old_r2 = new_r2)
+ }
+}
+
+
+##### -----------------========== Bottom of this function kit ======----------------######
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/peak_utils.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/peak_utils.R
new file mode 100755
index 0000000000000000000000000000000000000000..4a07c41d1937380c626b64f701075811e52f417f
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/peak_utils.R
@@ -0,0 +1,174 @@
+#' Create Mummichog Libraries from KEGG
+#' @description Function to create mummichog libraries from
+#' MetaboAnalyst pathway libraries (metpa).
+#' Outputs the RDS files in the current working directory. RDS files
+#' are saved using the KEGG organism code.
+#' @param folder Input the path of the folder containing the metpa rda files.
+#' @param kegg_compounds Input the name of the KEGG dictionary containing the
+#' KEGG compound IDs, KEGG compopund names, and molecular weight.
+#' @usage CreateMummichogLibs("~/Desktop/MetaboAnalyst/mummichog/2020_mummichog_libs/test", kegg_compounds_2020)
+#' @export
+CreateMummichogLibs <- function(folder, kegg_compounds){
+
+ # Step 1: Get list of pathways to make mummichog libraries from
+ folder <- folder
+ files <- list.files(folder, pattern = ".rda$")
+
+ if(length(files) == 0){
+ AddErrMsg("No .rda files found in folder!")
+ return(0)
+ }
+
+ # Step2: Create the models list
+ models <- Map(rda2list, file.path(folder, files))
+ names(models) <- tools::file_path_sans_ext(files)
+ org <- names(models)
+
+ kegg_compounds <<- kegg_compounds
+
+ # Step 3: Create the pathways
+ pathway <- lapply(models, function(f) {fillpathways(f)} )
+
+ # Step 4: Create cpd.lib
+ cpd.lib <- lapply(pathway, function(l) {make_cpdlib(l)})
+
+ # Step 5: Create mummichog libraries
+ # Will output the .RDS files in the current working directory
+ output <- mapply(CreateLibFromKEGG, cpd.lib, pathway, org)
+
+}
+
+#' Utility function
+#' Make list of KEGG rda files
+rda2list <- function(file) {
+ e <- new.env()
+ load(file, envir = e)
+ as.list(e)
+}
+
+#' Fill in the pathways
+fillpathways <- function(f){
+
+ pathways <- list()
+ p <- list()
+
+ cpds <- unname(f$current.kegglib$mset.list)
+
+ for(i in 1:length(cpds)){
+ all_cpds <- as.vector(unlist(cpds[[i]]))
+ matched_cpds <- all_cpds[which(all_cpds %in% kegg_compounds)]
+ p[[i]] <- matched_cpds
+ }
+
+ pathways$cpds <- p
+ pathways$name <- names(f$current.kegglib$path.ids)
+
+ return(pathways)
+}
+
+#' Gets names and exact mass of all cpds (cpd.lib)
+make_cpdlib <- function(org){
+
+ all_cpds <- unique(unlist(org$cpds))
+
+ index <- match(all_cpds, kegg_compounds[,1])
+
+ ids <- list()
+ names <- list()
+ mass <- list()
+
+ for(i in 1:length(index)){
+ inx <- index[i]
+ ids[i] <- kegg_compounds[inx,1]
+ names[i] <- kegg_compounds[inx,2]
+ mass[i] <- kegg_compounds[inx,3]
+ }
+
+ ids <- unlist(ids)
+ names <- unlist(names)
+ mass <- as.numeric(unlist(mass))
+
+ cpd.lib <- list(
+ id = ids,
+ name = names,
+ mw = mass
+ )
+ return(cpd.lib)
+}
+
+#' Creates cpd.tree
+CreateLibFromKEGG <- function(cpd.lib, pathways, org){
+
+ cpd.lib <- cpd.lib;
+ ms_modes <- c('dpj_positive', 'positive', 'negative');
+ adducts <- list();
+ for (ms_mode in ms_modes){
+ adducts[[ms_mode]] <- Compound_function_mzlist(ms_mode, cpd.lib$mw);
+ }
+ cpd.lib$adducts <- adducts;
+
+ # create a dictionary for look up in the range of 50-2000
+ # now need to create ladder (tree) for each new mz
+ # key is the mass 50 to 2000, values are the compounds (if any of their modified mw gives the value)
+ # now create cpd tree for each mass pos
+ # note, this can be slow, but this can be created before hand
+ # for each species and for each mode
+ # note l2 only stores the index of the cpd.lib
+
+ cpd.tree <- list();
+ for (ms_mode in ms_modes){
+ l2 <- list();
+ l2[[49]] <- "";
+ l2[[2001]] <- "";
+ mz.mat <- cpd.lib$adducts[[ms_mode]];
+ floor.mzs <- floor(mz.mat);
+ for(i in 1:nrow(floor.mzs)){
+ neighbourhood <- floor.mzs[i,];
+ for(n in neighbourhood){
+ if((n>50) & (n<2000)){
+ l2[[n]] <- append(l2[[n]], i);
+ }
+ }
+ }
+ cpd.tree[[ms_mode]] <- lapply(l2, unique);
+ }
+
+ # set up the variables
+ mummichog.lib <- list(
+ pathways = pathways,
+ cpd.tree = cpd.tree,
+ cpd.lib = cpd.lib
+ )
+
+ print(paste0(org, " mummichog library created!"))
+ file_name <- paste0(org, "_kegg.qs")
+
+ qs::qsave(mummichog.lib, file=file_name);
+}
+
+#' Makes adducts
+Compound_function_mzlist <- function(ms_mode, mw){
+
+ load_stringr()
+
+ PROTON <- 1.00727646677;
+ mw_modified <- NULL;
+
+ if (ms_mode == "dpj_positive"){
+ mw_modified <- cbind(mw, mw + PROTON, mw/2 + PROTON, mw +1.0034 + PROTON, mw/2 + 0.5017 + PROTON, mw +1.9958 + PROTON, mw +1.9972 + PROTON, mw + 21.9820 + PROTON, mw/2 + 10.991 + PROTON, mw + 37.9555 + PROTON, mw + 67.9874 + PROTON, mw + 83.9613 + PROTON);
+ colnames(mw_modified) <- c('M[1+]', 'M+H[1+]', 'M(C13)+H[1+]', 'M(C13)+H[1+]', 'M(C13)+2H[2+]', 'M(S34)+H[1+]', 'M(Cl37)+H[1+]', 'M+Na[1+]', 'M+H+Na[2+]', 'M+K[1+]', 'M+HCOONa[1+]', 'M+HCOOK[1+]');
+
+ }else if (ms_mode == "positive" | ms_mode == 'generic'){
+ mw_modified <- cbind(mw, mw + PROTON, mw/2 + PROTON, mw/3 + PROTON, mw +1.0034 + PROTON, mw/2 + 0.5017 + PROTON, mw/3 + 0.3344 + PROTON, mw +1.9958 + PROTON, mw +1.9972 + PROTON, mw + 21.9820 + PROTON, mw/2 + 10.991 + PROTON, mw + 37.9555 + PROTON, mw + 18.0106 + PROTON, mw - 18.0106 + PROTON, mw - 36.0212 + PROTON, mw - 17.0265 + PROTON, mw - 27.9950 + PROTON, mw - 43.9898 + PROTON, mw - 46.0054 + PROTON, mw + 67.9874 + PROTON, mw - 67.9874 + PROTON, mw + 57.9586 + PROTON, mw - 72.0211 + PROTON, mw + 83.9613 + PROTON, mw - 83.9613 + PROTON);
+ colnames(mw_modified) <- c('M[1+]', 'M+H[1+]', 'M+2H[2+]', 'M+3H[3+]', 'M(C13)+H[1+]', 'M(C13)+2H[2+]', 'M(C13)+3H[3+]', 'M(S34)+H[1+]', 'M(Cl37)+H[1+]', 'M+Na[1+]', 'M+H+Na[2+]', 'M+K[1+]', 'M+H2O+H[1+]', 'M-H2O+H[1+]', 'M-H4O2+H[1+]', 'M-NH3+H[1+]', 'M-CO+H[1+]', 'M-CO2+H[1+]', 'M-HCOOH+H[1+]', 'M+HCOONa[1+]', 'M-HCOONa+H[1+]', 'M+NaCl[1+]', 'M-C3H4O2+H[1+]', 'M+HCOOK[1+]', 'M-HCOOK+H[1+]');
+
+ }else if (ms_mode == "negative"){
+ mw_modified <- cbind(mw - PROTON, mw/2 - PROTON, mw + 1.0034 - PROTON, mw + 1.9958 - PROTON, mw + 1.9972 - PROTON, mw + 21.9820 - 2*PROTON, mw + 37.9555 - 2*PROTON, mw - 18.0106 - PROTON, mw + 34.9689, mw + 36.9659, mw + 78.9183, mw + 80.9163, mw + 2*12 + 3*1.007825 + 14.00307 - PROTON, mw + 1.007825 + 12 + 2*15.99491, mw + 3*1.007825 + 2*12 + 2*15.99491, mw - PROTON + 15.99491);
+ colnames(mw_modified) <- c('M-H[-]', 'M-2H[2-]', 'M(C13)-H[-]', 'M(S34)-H[-]', 'M(Cl37)-H[-]', 'M+Na-2H[-]', 'M+K-2H[-]', 'M-H2O-H[-]', 'M+Cl[-]', 'M+Cl37[-]', 'M+Br[-]', 'M+Br81[-]', 'M+ACN-H[-]', 'M+HCOO[-]', 'M+CH3COO[-]', 'M-H+O[-]');
+
+ }else{
+ print("Unrecognized mode of instrumentation.")
+ }
+
+ return(mw_modified);
+}
\ No newline at end of file
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/peaks_to_function.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/peaks_to_function.R
new file mode 100755
index 0000000000000000000000000000000000000000..163c33e14c86c9dfbb159bb888500b625a74e0de
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/peaks_to_function.R
@@ -0,0 +1,4648 @@
+### An R package for pathway enrichment analysis for untargeted metabolomics
+### based on high-resolution LC-MS platform
+### This is based on the mummichog algorithm implemented in python (http://mummichog.org/)
+### The goals of developing MummichogR are
+### 1) to make this available to the R user community
+### 2) high-performance (similar or faster compared to python)
+### 3) broader pathways support - by adding support for 21 common organisms based on KEGG pathways
+### 4) companion web interface on MetaboAnalyst - the "MS Peaks to Pathways" module
+### @authors J. Chong \email{jasmine.chong@mail.mcgill.ca}, J. Xia \email{jeff.xia@mcgill.ca}
+### McGill University, Canada
+### License: GNU GPL (>= 2)
+
+#'Save adduct names for mapping
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param qvec Input the vector to query
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+Setup.AdductData <- function(mSetObj=NA, qvec){
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$dataSet$adduct.list <- qvec;
+ mSetObj$adduct.custom <- TRUE
+ return(.set.mSet(mSetObj));
+}
+
+#'Set the peak enrichment method for the MS Peaks to Paths module
+#'@description This function sets the peak enrichment method.
+#'@param mSetObj Input the name of the created mSetObj.
+#'@author Jasmine Chong, Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+SetPeakEnrichMethod <- function(mSetObj=NA, algOpt, version="v2"){
+
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$peaks.alg <- algOpt
+
+ mum.version <<- version
+
+ if(algOpt == "gsea"){
+ anal.type <<- "gsea_peaks"
+ }else if(algOpt == "mum"){
+ anal.type <<- "mummichog"
+ }else{
+ anal.type <<- "integ_peaks"
+ }
+ return(.set.mSet(mSetObj));
+}
+
+#'Constructor to read uploaded user files into the mummichog object
+#'@description This function handles reading in CSV or TXT files and filling in the mSet object
+#' for mummichog analysis. It makes sure that all necessary columns are present.
+#'@usage Read.PeakListData(mSetObj=NA, filename = NA)
+#'@param mSetObj Input the name of the created mSetObj.
+#'@param filename Input the path name for the CSV/TXT files to read.
+#'@param meta.anal Logical, TRUE if data will be used for meta-analysis.
+#'@param method Input the type of statistical scores included in the
+#'mummichog input. "pvalue" for p-values, "es" for effect-sizes, and
+#'"both" for both p-values and effect-sizes.
+#'@author Jasmine Chong, Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@import qs
+#'@export
+Read.PeakListData <- function(mSetObj=NA, filename = NA, meta.anal = FALSE,
+ method = "pvalue") {
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ file_name <- tools::file_path_sans_ext(basename(filename))
+ mumDataContainsPval = 1; #whether initial data contains pval or not
+ input <- as.data.frame(.readDataTable(filename));
+ user_cols <- gsub("[^[:alnum:]]", "", colnames(input));
+ mummi.cols <- c("m.z", "p.value", "t.score", "r.t")
+
+ if(meta.anal & method %in% c("es", "both")){
+ mummi.cols <- c(mummi.cols, "effect.size", "lower.ci", "upper.ci")
+ }
+
+ # first check if mode included
+ mumDataContainsMode <- "mode" %in% user_cols;
+
+ if(mumDataContainsMode){
+ mode.info <- input$mode
+ input <- subset(input, select=-mode)
+ user_cols <- gsub("[^[:alnum:]]", "", colnames(input))
+ }
+
+ # next check what column names are there
+ hit <- "mz" %in% user_cols;
+
+ if(sum(hit) < 1){
+ AddErrMsg("Missing information, data must contain a 'm.z' column!");
+ return(0);
+ }
+
+ if(length(colnames(input) %in% mummi.cols) == 1){
+ peakFormat <- peakFormat
+ }else{
+ # subset to what's needed for ms peaks
+ # then rename columns
+ hits2 <- match(gsub("[^[:alnum:]]", "", mummi.cols), user_cols)
+ input <- input[, na.omit(hits2)]
+ user_cols <- user_cols[na.omit(hits2)]
+ hits.colnames <- match(user_cols, gsub("[^[:alnum:]]", "", mummi.cols))
+ user.cols <- mummi.cols[na.omit(hits.colnames)]
+ peakFormat <- paste0(substr(sort(user.cols), 1, 1), collapse = "")
+ colnames(input) <- user.cols
+ }
+
+ rt.hit <- "r.t" %in% colnames(input)
+
+ if(rt.hit > 0){
+ rt = TRUE
+ }else{
+ rt = FALSE
+ }
+
+ qs::qsave(input, "mum_raw.qs");
+
+ if(!"p.value" %in% colnames(input)){
+ mumDataContainsPval <- 0;
+ input[,'p.value'] <- rep(0, length=nrow(input))
+ }
+
+ if(!"t.score" %in% colnames(input)){
+ input[,'t.score'] <- rep(0, length=nrow(input))
+ }
+
+ if(rt){
+ mSetObj$dataSet$mummi.orig <- cbind(input$p.value, input$m.z, input$t.score, input$r.t);
+ colnames(mSetObj$dataSet$mummi.orig) = c("p.value", "m.z", "t.score", "r.t")
+ }else{
+ mSetObj$dataSet$mummi.orig <- cbind(input$p.value, input$m.z, input$t.score);
+ colnames(mSetObj$dataSet$mummi.orig) = c("p.value", "m.z", "t.score")
+ }
+
+ if(meta.anal & method %in% c("es", "both")){
+ mSetObj$dataSet$mummi.orig <- cbind(mSetObj$dataSet$mummi.orig, effect.size=input$effect.size,
+ lower.ci=input$lower.ci, upper.ci=input$upper.ci);
+ }
+
+ if(mSetObj$dataSet$mode == "positive"){
+ mSetObj$dataSet$pos_inx <- rep(TRUE, nrow(mSetObj$dataSet$mummi.orig))
+ }else if(mSetObj$dataSet$mode == "negative"){
+ mSetObj$dataSet$pos_inx <- rep(FALSE, nrow(mSetObj$dataSet$mummi.orig) )
+ }else{ # mixed
+ mSetObj$dataSet$pos_inx <- mode.info == "positive"
+ }
+
+ mSetObj$dataSet$mumRT = rt
+ mSetObj$dataSet$mumType = "list";
+ mSetObj$msgSet$read.msg <- paste("A total of", length(input$p.value), "m/z features were found in your uploaded data.");
+ mSetObj$dataSet$fileName <- file_name
+ mumDataContainsPval <<- mumDataContainsPval;
+ peakFormat <<- peakFormat
+ print(peakFormat)
+ return(.set.mSet(mSetObj));
+}
+
+# function to format peak table from mzmine to right format for metaboanalyst
+# @format "row" for features in rows, "col" for features in columns.
+.format_mzmine_pktable <- function(mSetObj=NA, fileName, format="rowu", group1=NA, group2=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ mzmine_table <- .readDataTable(fileName)
+
+ if(class(mzmine_table) == "try-error" || ncol(mzmine_table) == 1){
+ AddErrMsg("Data format error. Failed to read in the data!");
+ AddErrMsg("Make sure the data table is saved as comma separated values (.csv) format!");
+ AddErrMsg("Please also check the followings: ");
+ AddErrMsg("Either sample or feature names must in UTF-8 encoding; Latin, Greek letters are not allowed.");
+ AddErrMsg("We recommend to use a combination of English letters, underscore, and numbers for naming purpose.");
+ AddErrMsg("Make sure sample names and feature (peak, compound) names are unique.");
+ AddErrMsg("Missing values should be blank or NA without quote.");
+ AddErrMsg("Make sure the file delimeters are commas.");
+ return(0);
+ }
+
+ rownames(mzmine_table) <- mzmine_table[,1]
+ mzmine_table <- mzmine_table[,-1]
+
+ if(!is.na(group1) & !is.na(group2)){
+ if(format == "row"){
+ keep.inx <- mzmine_table[1, ] %in% c(group1, group2)
+ mzmine_table <- mzmine_table[, keep.inx]
+ }else{
+ keep.inx <- mzmine_table[, 1] %in% c(group1, group2)
+ mzmine_table <- mzmine_table[keep.inx, ]
+ }
+ newnames <- paste0(tools::file_path_sans_ext(basename(fileName)), "_", group1, "_", group2, ".csv")
+ }else{
+
+ mzmine_table[1, ] <- tolower(mzmine_table[1, ])
+ groups <- unique(unlist(mzmine_table[1, ]))
+
+ if(length(groups) > 2){
+ AddErrMsg("Only two groups permitted!");
+ if("qc" %in% groups){
+ AddErrMsg("Remove QCs prior to uploading the mzmine table!");
+ }
+ return(0);
+ }
+
+ if(.on.public.web){
+ newnames <- "mzmine_peaktable_metaboanalyst.csv"
+ }else{
+ newnames <- paste0(tools::file_path_sans_ext(basename(fileName)), "_formatted.csv")
+ }
+ }
+
+ if(format == "colu"){ # samples in columns so features are in row
+ feats <- gsub("/", "__", rownames(mzmine_table) )
+ feats <- sub(".*?__", "", feats )
+ feats <- sub("min", "", feats )
+ feats <- sub("mz", "", feats )
+ feats <- make.unique(feats, sep="")
+ rownames(mzmine_table) <- feats
+ }else{ # features in columns
+ feats <- gsub("/", "__", colnames(mzmine_table) )
+ feats <- sub(".*?__", "", feats )
+ feats <- sub("min", "", feats )
+ feats <- sub("mz", "", feats )
+ feats <- make.unique(feats, sep="")
+ colnames(mzmine_table) <- feats
+ }
+ write.csv(mzmine_table, newnames, row.names = TRUE)
+ return(.set.mSet(mSetObj))
+}
+
+#'Set the peak format for the mummichog analysis
+#'@description Set the peak format for mummichog analysis.
+#'@param mSetObj Input the name of the created mSetObj.
+#'@author Jasmine Chong, Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+SetPeakFormat <-function(type){
+ peakFormat <<- type;
+}
+
+GetPeakFormat <- function(mSetObj=NA){
+ return(peakFormat)
+}
+
+#'Convert mSetObj to proper format for MS Peaks to Pathways module
+#'@description Following t-test analysis or effect size calculation,
+#'this functions converts the results from the mSetObj
+#'to the proper format for mummichog analysis.
+#'@param mSetObj Input the name of the created mSetObj.
+#'@param rt Logical, whether or not to include retention time information.
+#'@param rds.file Logical, if true, the "annotated_peaklist.rds"
+#'must be in the current working directory to get corresponding retention time
+#'information for the features. If not, the retention time information
+#'will be taken from the feature names. Feature names must be formatted
+#'so that the mz and retention time for a single peak is separated by two
+#'underscores. For instance, m/z of 410.2148 and retention time of 42.46914 seconds
+#'must be formatted as 410.2148__42.46914.
+#'@param rt.type Character, input whether retention time is in seconds (default as RT using
+#'MetaboAnalystR is seconds) or minutes (as from MZmine).
+#'@param test Character, input what statistical values to include in the mummichog input.
+#'For p-values and t-scores only from t-test, use "tt".
+#'For log2FC from the fold-change analsis, use "fc".
+#'For effect-sizes, use "es".
+#'For, p-values, fold-changes and effect sizes, use "all".
+#'@author Jasmine Chong, Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+Convert2Mummichog <- function(mSetObj=NA, rt=FALSE, rds.file=FALSE, rt.type="seconds",
+ test="tt", mode=NA){
+
+ if(test=="tt"|test=="all"){
+ if(is.null(mSetObj$analSet$tt)){
+ AddErrMsg("T-test was not performed!")
+ return(0)
+ }
+
+ tt.pval <- sort(mSetObj$analSet$tt$p.value);
+ fdr <- p.adjust(tt.pval, "fdr")
+ mz.pval <- names(tt.pval)
+ pvals <- cbind(mz.pval, as.numeric(fdr))
+ colnames(pvals) <- c("m.z", "p.value")
+
+ tt.tsc <- sort(mSetObj$analSet$tt$t.score);
+ mz.tsc <- names(tt.tsc)
+ tscores <- cbind(mz.tsc, as.numeric(tt.tsc))
+ colnames(tscores) <- c("m.z", "t.score")
+ }
+
+ if(test=="es"|test=="all"){
+
+ effect.size <- mSetObj$analSet$effect.size
+
+ if(is.null(effect.size)){
+ AddErrMsg("Effect size was not calculated!")
+ return(0)
+ }
+
+ mz <- rownames(effect.size)
+ esize <- cbind(mz, effect.size)
+ colnames(esize) <- c("m.z", "effect.size", "st.dev", "lower.ci", "upper.ci")
+ }
+
+ if(test=="fc"|test=="all"){
+
+ log2fc <- mSetObj$analSet$fc$fc.log
+
+ if(is.null(log2fc)){
+ AddErrMsg("Fold-change was not calculated!")
+ return(0)
+ }
+
+ mz.fc <- names(log2fc)
+ fcs <- cbind(mz.fc, as.numeric(log2fc))
+ colnames(fcs) <- c("m.z", "log2.fc")
+ }
+
+ if(rt & rds.file){
+
+ if(!file.exists("annotated_peaklist.rds")){
+ AddErrMsg("annotated_peaklist.rds not found in current working directory!")
+ return(0)
+ }
+
+ camera_output <- readRDS("annotated_peaklist.rds")
+ mz.cam <- round(camera_output$mz, 5)
+ rt.cam <- round(camera_output$rt, 5)
+ camera <- cbind(mz.cam, rt.cam)
+ colnames(camera) <- c("m.z", "r.t")
+
+ if(test == "tt"){
+ mummi_new <- Reduce(function(x,y) merge(x,y,by="m.z", all = TRUE), list(pvals, tscores, camera))
+ complete.inx <- complete.cases(mummi_new[,c("p.value", "t.score", "r.t")]) # filter out m/zs without pval and tscore
+ }else if(test == "es"){
+ mummi_new <- Reduce(function(x,y) merge(x,y,by="m.z", all = TRUE), list(esize, camera))
+ complete.inx <- complete.cases(mummi_new[,c("effect.size", "r.t")])
+ }else if(test == "all"){
+ mummi_new <- Reduce(function(x,y) merge(x,y,by="m.z", all = TRUE), list(pvals, tscores, fcs, esize, camera))
+ complete.inx <- complete.cases(mummi_new[,c("p.value", "t.score", "log2.fc", "effect.size", "r.t")]) # filter out m/zs without pval and tscore
+ }else if(test=="fc"){
+ mummi_new <- Reduce(function(x,y) merge(x,y,by="m.z", all = TRUE), list(fcs, camera))
+ complete.inx <- complete.cases(mummi_new[,c("log2.fc", "r.t")])
+ }
+
+ mummi_new <- mummi_new[complete.inx,]
+
+ }else{
+
+ if(test=="tt"){
+ mummi_new <- merge(pvals, tscores)
+ }else if(test=="es"){
+ mummi_new <- esize
+ }else if(test=="all"){
+ mummi_new <- Reduce(merge, list(pvals, tscores, fcs, esize))
+ mummi_new[] <- lapply(mummi_new, as.character)
+ }else if(test=="fc"){
+ mummi_new <- fcs
+ }
+
+ if(rt){ # taking retention time information from feature name itself
+ feat_info <- mummi_new[,1]
+ feat_info_split <- matrix(unlist(strsplit(feat_info, "__", fixed=TRUE)), ncol=2, byrow=T)
+ colnames(feat_info_split) <- c("m.z", "r.t")
+
+ if(rt.type == "minutes"){
+ rtime <- as.numeric(feat_info_split[,2])
+ rtime <- rtime * 60
+ feat_info_split[,2] <- rtime
+ }
+
+ mummi_new <- cbind(feat_info_split, mummi_new[,-1])
+ }
+ }
+
+ if(!is.na(mode)){
+ if(mode=="positive"){
+ mode <- rep("positive", nrow(mummi_new))
+ }else{
+ mode <- rep("negative", nrow(mummi_new))
+ }
+ mummi_new <- cbind(mummi_new, mode)
+ }
+
+ mummi_new[,1] <- as.numeric(make.unique(as.character(mummi_new[,1]), sep=""))
+
+ filename <- paste0("mummichog_input_", Sys.Date(), ".txt")
+ input_filename <<- filename;
+ write.table(mummi_new, filename, row.names = FALSE)
+
+ return(.set.mSet(mSetObj))
+}
+
+#'Update the mSetObj with user-selected parameters for MS Peaks to Pathways.
+#'@description This functions handles updating the mSet object for mummichog analysis. It is necessary to utilize this function
+#'to specify to the organism's pathways to use (libOpt), the mass-spec mode (msModeOpt) and mass-spec instrument (instrumentOpt).
+#'@usage UpdateInstrumentParameters(mSetObj=NA, instrumentOpt, msModeOpt, custom=FALSE)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects).
+#'@param instrumentOpt Numeric. Define the mass-spec instrument used to perform untargeted metabolomics.
+#'@param msModeOpt Character. Define the mass-spec mode of the instrument used to perform untargeted metabolomics.
+#'@param custom Logical, select adducts for mummichog to consider.
+#'@param force_primary_ion Character, if "yes", only mz features that match compounds with a primary ion are kept.
+#'@author Jasmine Chong, Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+UpdateInstrumentParameters <- function(mSetObj=NA, instrumentOpt, msModeOpt,
+ force_primary_ion = "yes", rt_frac = 0.02,
+ rt_tol = NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(!is.numeric(instrumentOpt)){
+ AddErrMsg("Mass accuracy must be numeric!")
+ }else{
+ mSetObj$dataSet$instrument <- instrumentOpt;
+ }
+
+ mSetObj$dataSet$mode <- msModeOpt;
+ mSetObj$dataSet$primary_ion <- force_primary_ion;
+ mSetObj$dataSet$rt_tol <- rt_tol;
+ mSetObj$dataSet$rt_frac <- rt_frac;
+
+ return(.set.mSet(mSetObj));
+}
+
+#'Sanity Check Data
+#'@description SanityCheckData is used for data processing, and performs a basic sanity
+#'check of the uploaded data, ensuring that the data is suitable for further analysis.
+#'The function ensure that all parameters are properly set based on updated parameters.
+#'@usage SanityCheckMummichogData(mSetObj=NA)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects).
+#'@author Jasmine Chong, Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@import qs
+#'@export
+
+SanityCheckMummichogData <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+ if(mSetObj$dataSet$mumType == "table"){
+ mumDataContainsPval <<- 1;
+ orig.data<- qs::qread("data_orig.qs");
+ l = sapply(colnames(orig.data),function(x) return(unname(strsplit(x,"/", fixed=TRUE)[[1]][1])))
+ colnames(orig.data) <- l;
+ qs::qsave(orig.data, file="data_orig.qs");
+
+ if(.on.public.web){
+ return(SanityCheckData(NA));
+ }else{
+ mSetObj <- SanityCheckData(mSetObj)
+ return(.set.mSet(mSetObj));
+ }
+ }
+
+ msg.vec <- NULL;
+ mSetObj$mum_nm <- "mummichog_query.json"
+ mSetObj$mum_nm_csv <- "mummichog_pathway_enrichment.csv"
+ ndat <- mSetObj$dataSet$mummi.orig;
+ pos_inx = mSetObj$dataSet$pos_inx
+ ndat <- data.frame(cbind(ndat, pos_inx), stringsAsFactors = FALSE)
+
+ rawdat <- qs::qread("mum_raw.qs");
+
+ if(mSetObj$dataSet$mumRT){
+ na.num <- sum(is.na(ndat$r.t))
+ # filter out any reads w. NA RT
+ if(na.num>0){
+ na.inx <- which(is.na(ndat$r.t))
+ ndat <- ndat[-na.inx,]
+ msg.vec <- c(msg.vec, paste("A total of <b>", na.num, "</b> mz features with missing retention times were removed."));
+ }
+ }
+
+ # another check to ensure no missing or NA values
+ missing.inx <- apply(ndat, 2, function(x) any(is.na(x)))
+
+ if(any(missing.inx)){
+ AddErrMsg("NA values found in the uploaded data!")
+ return(0)
+ }
+
+ read.msg <- mSetObj$msgSet$read.msg
+
+ # sort mzs by p-value
+ ord.inx <- order(ndat[,1]);
+ ndat <- ndat[ord.inx,]; # order by p-vals
+
+ # filter based on mz
+ mznew <- ndat[,2];
+
+ # trim to fit within 50 - 2000
+ my.inx <- mznew > 50 & mznew < 2001;
+ trim.num <- sum(!my.inx);
+ range = paste0(min(ndat[,1], "-", max(ndat[,1])))
+ if(length(unique(mSetObj[["dataSet"]][["pos_inx"]])) > 1){
+ colNMadd <- "and mode";
+ colnumadd <- 1;
+ } else {
+ colnumadd <- 0;
+ colNMadd <- NULL;
+ }
+
+ msg.vec <- c(msg.vec, paste("The instrument's mass accuracy is <b>", mSetObj$dataSet$instrument , "</b> ppm."));
+ msg.vec <- c(msg.vec, paste("The instrument's analytical mode is <b>", mSetObj$dataSet$mode , "</b>."));
+ msg.vec <- c(msg.vec, paste("The uploaded data contains <b>", length(colnames(rawdat)) + colnumadd, "</b> columns."));
+
+ if(peakFormat == "rmp"){
+ msg.vec <- c(msg.vec, paste("The peaks are ranked by <b>p-values</b>."));
+ }else if(peakFormat == "rmt"){
+ msg.vec <- c(msg.vec, paste("The peaks are ranked by <b>t-scores</b>."));
+ }
+
+ msg.vec <- c(msg.vec, paste("The column headers of uploaded data are <b>", paste(colnames(rawdat),collapse=", "), colNMadd ,"</b>."));
+ msg.vec <- c(msg.vec, paste("The range of m/z peaks is trimmed to 50-2000. <b>", trim.num, "</b> features have been trimmed."));
+
+ if(trim.num > 0){
+ ndat <- ndat[my.inx,]
+ #msg.vec <- c(msg.vec, paste("A total of", trim.num, "were excluded to fit within mz range of 50-2000"));
+ }
+
+ # remove duplicated mzs (make unique)
+ dup.inx <- duplicated(ndat);
+ dup.num <- sum(dup.inx);
+
+ if(dup.num > 0){
+ ndat <- ndat[!dup.inx,];
+ msg.vec <- c(msg.vec, paste("A total of <b>", dup.num, "</b> duplicated mz features were removed."));
+ }
+
+ # make mzs unique
+ mzs <- ndat[,2]
+ # ensure features are unique
+ mzs_unq <- mzs[duplicated(mzs)]
+ set.seed(123);
+ while(length(mzs_unq)>0){
+ mzs[duplicated(mzs)] <- sapply(mzs_unq, function(x) paste0(x, sample(1:9, 1, replace = TRUE)));
+ mzs_unq <- mzs[duplicated(mzs)]
+ }
+
+ ndat[,2] <- mzs
+ ref_mzlist <- ndat[,2];
+
+ # set up expression (up/dn)
+ tscores <- as.numeric(ndat[,3]);
+ names(tscores) <- ref_mzlist;
+
+ # set up rt
+ if(mSetObj$dataSet$mumRT){
+
+ retention_time <- as.numeric(ndat[,4]);
+ names(retention_time) <- ref_mzlist;
+ mSetObj$dataSet$pos_inx <- as.numeric(ndat$pos_inx) == 1;
+ mSetObj$dataSet$ret_time <- retention_time;
+
+ if(is.na(mSetObj$dataSet$rt_tol)){
+ rt_tol <- max(mSetObj$dataSet$ret_time) * mSetObj$dataSet$rt_frac
+ print(paste0("Retention time tolerance is ", rt_tol))
+ mSetObj$dataSet$rt_tol <- rt_tol
+ }
+
+ }else{
+ mSetObj$dataSet$pos_inx <- as.numeric(ndat$pos_inx) == 1;
+ }
+
+ ref.size <- length(ref_mzlist);
+
+ msg.vec <- c(msg.vec, paste("A total of ", ref.size, "input mz features were retained for further analysis."));
+
+ if(ref.size > 20000){
+ msg.vec <- c(msg.vec, "There are too many input features, the performance may be too slow.");
+ }
+
+ if(ref.size < 100){
+ AddErrMsg("There are too few m/z features. Ensure that all of your m/z features have been uploaded!");
+ return(0)
+ }
+
+ if(min(ndat[,"p.value"])<0 || max(ndat[,"p.value"])>1){
+ msg.vec <- c(msg.vec, "Please make sure the p-values are between 0 and 1.");
+ }
+
+ mSetObj$msgSet$check.msg <- c(mSetObj$msgSet$check.msg, read.msg, msg.vec);
+ mSetObj$dataSet$mummi.proc <- ndat;
+ mSetObj$dataSet$expr_dic <- tscores;
+ mSetObj$dataSet$ref_mzlist <- ref_mzlist;
+
+ return(.set.mSet(mSetObj));
+}
+
+#'Set the cutoff for mummichog analysis
+#'@description Set the p-value cutoff for mummichog analysis.
+#'@param mSetObj Input the name of the created mSetObj.
+#'@author Jasmine Chong, Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+SetMummichogPvalFromPercent <- function(mSetObj=NA, fraction){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(peakFormat %in% c("rmp", "rmt")){
+ maxp <- 0;
+ }else{
+ pvals <- c(0.25, 0.2, 0.15, 0.1, 0.05, 0.01, 0.005, 0.001, 0.0005, 0.0001, 0.00005, 0.00001)
+ ndat <- mSetObj$dataSet$mummi.proc;
+ n <- floor(fraction*length(ndat[,"p.value"]))
+ cutoff <- ndat[n+1,1]
+ if(!any(pvals <= cutoff)){
+ maxp <- 0.00001
+ }else{
+ maxp <- max(pvals[pvals <= cutoff])
+ }
+ }
+ mSetObj$dataSet$cutoff <- maxp
+ .set.mSet(mSetObj);
+ return(SetMummichogPval("NA", maxp));
+}
+
+#'Set the cutoff for mummichog analysis
+#'@description Set the p-value cutoff for mummichog analysis.
+#'@param mSetObj Input the name of the created mSetObj.
+#'@author Jasmine Chong, Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+SetMummichogPval <- function(mSetObj=NA, cutoff){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ msg.vec <- NULL;
+ mSetObj$dataSet$cutoff <- cutoff;
+ ndat <- mSetObj$dataSet$mummi.proc;
+ msg.vec <- c(msg.vec, "Only a small percentage (below 10%) peaks in your input peaks should be significant.");
+ msg.vec <- c(msg.vec, "The algorithm works best for <u>200~500 significant peaks in 3000~7000 total peaks</u>.");
+
+ ref_mzlist <- ndat[,2];
+ if(mumDataContainsPval == 1){
+ my.inx <- ndat[,1] < cutoff;
+ input_mzlist <- ref_mzlist[my.inx];
+ # note, most of peaks are assumed to be not changed significantly, more than 25% should be warned
+
+ }else{
+ inxToKeep = length(ref_mzlist)/10
+ if(inxToKeep > 500){
+ inxToKeep = 500;
+ }
+ input_mzlist <- ref_mzlist[1:inxToKeep];
+ }
+
+ sig.size <- length(input_mzlist);
+ sig.part <- round(100*sig.size/length(ref_mzlist),2);
+
+ if(sig.part > 25){
+ msg.vec <- c(msg.vec, paste("<font color=\"orange\">Warning: over", sig.part, "percent were significant based on your cutoff</font>."));
+ msg.vec <- c(msg.vec, "You should adjust p-value cutoff to control the percentage");
+ }else{
+ msg.vec <- c(msg.vec, paste("A total of", sig.size, "or", sig.part, "percent signficant mz features were found based on the selected p-value cutoff:", cutoff));
+ }
+
+ if(sig.size > 2000){
+ msg.vec <- c(msg.vec, "There are too many significant features based on the current cutoff, possibly too slow.");
+ }else if(sig.size == 0){
+ AddErrMsg("No significant features were found based on the current cutoff! Failed to perform analysis.");
+ return(0);
+ }else if(sig.size < 30){
+ msg.vec <- c(msg.vec, "The number of significant features is small based on the current cutoff, possibly not accurate.");
+ }
+
+ print(msg.vec)
+ mSetObj$dataSet$input_mzlist <- input_mzlist;
+ mSetObj$dataSet$N <- sig.size;
+
+ if(.on.public.web){
+ mSet <<- mSetObj;
+ return(round(sig.part, 0))
+ } else {
+ return(.set.mSet(mSetObj));
+ }
+}
+
+#' For meta-analysis, set the p-value
+#' cutoff used to define the new
+#' input_mzlist
+SetMetaPeaksPvals <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$dataSet$cutoff <- cutoff;
+ return(.set.mSet(mSetObj));
+}
+
+#'Function to perform peak set enrichment analysis
+#'@description This is the main function that performs either the mummichog
+#'algorithm, GSEA, or both for peak set enrichment analysis.
+#'@usage PerformPSEA(mSetObj=NA, lib, libVersion, minLib, permNum = 100)
+#'@param mSetObj Input the name of the created mSetObj object.
+#'@param lib Input the name of the organism library, default is hsa_mfn.
+#'@param libVersion Input the version of the KEGG pathway libraries ("current" or "old").
+#'@param minLib Numeric, input the minimum number of metabolites needed to consider the pathway
+#'or metabolite set.
+#'@param permNum Numeric, input the number of permutations to perform. Default is 100.
+#'@author Jasmine Chong, Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'@import qs
+
+PerformPSEA <- function(mSetObj=NA, lib, libVersion, minLib = 3, permNum = 100){
+
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj <- .setup.psea.library(mSetObj, lib, libVersion, minLib)
+ version <- mum.version
+
+ if(mSetObj$dataSet$mumRT & version=="v2"){
+ mSetObj <- .init.RT.Permutations(mSetObj, permNum)
+ }else{
+ mSetObj <- .init.Permutations(mSetObj, permNum)
+ }
+
+ if(class(mSetObj) != "list"){
+ if(mSetObj == 0){
+ AddErrMsg("MS Peaks to Paths analysis failed! Likely not enough m/z to compound hits for pathway analysis!")
+ return(0)
+ }
+ }
+ return(.set.mSet(mSetObj));
+}
+
+#' Internal function to perform PSEA, no retention time
+.init.Permutations <- function(mSetObj, permNum){
+
+ if(anal.type == "mummichog"){
+ mSetObj <- .perform.mummichogPermutations(mSetObj, permNum);
+ mSetObj <- .compute.mummichogSigPvals(mSetObj);
+ }else if(anal.type == "gsea_peaks"){
+ mSetObj <- .compute.mummichog.fgsea(mSetObj, permNum);
+ }else{
+ # need to perform mummichog + gsea then combine p-values
+ mSetObj <- .compute.mummichog.fgsea(mSetObj, permNum);
+ mSetObj <- .perform.mummichogPermutations(mSetObj, permNum);
+ mSetObj <- .compute.mummichogSigPvals(mSetObj);
+
+ pathResults <- vector("list")
+
+ pathResults$ora.all <- mSetObj$mummi.resmat
+ pathResults$gsea.all <- mSetObj$mummi.gsea.resmat
+
+ path.names.all <- lapply(pathResults, rownames)
+ path.intersect <- Reduce(intersect, path.names.all)
+
+ # remove paths not found by all three - complete.cases
+ path.intersected <- lapply(pathResults, function(x) x[row.names(x) %in% path.intersect,])
+ #li_2 <- lapply(seq_along(path.intersected), function(i) {colnames(path.intersected[[i]]) <- paste0(colnames(path.intersected[[i]]), names(path.intersected)[[i]]) ; path.intersected[[i]] } )
+ path2 <- data.table::setDF(Reduce(merge, lapply(path.intersected, data.table::data.table, keep.rownames = TRUE)))
+
+ mum.df <- path2[, c("rn", "Pathway total", "Hits.total", "Hits.sig", "FET", "P_val")]
+ rownames(mum.df) <- mum.df$rn
+
+ # combine p-values
+ # replace 1 with 0.999 and 0 with low number
+ mum.df[,5:6][mum.df[,5:6]==1] <- 0.999
+ mum.df[,5:6][mum.df[,5:6]==0] <- .Machine$double.xmin
+
+ combo.all <- apply(mum.df[,5:6], 1, function(x) sumlog(x))
+
+ #extract p-values
+ all.ps <- unlist(lapply(combo.all, function(z) z["p"]))
+ df.combo <- as.matrix(mum.df[,2:6])
+ dfcombo <- round(cbind(df.combo, all.ps), 5)
+ colnames(dfcombo) <- c("Total_Size", "Hits", "Sig_Hits", "Mummichog_Pvals", "GSEA_Pvals", "Combined_Pvals")
+ ord.inx <- order(dfcombo[,6]);
+ dfcombo <- signif(as.matrix(dfcombo[ord.inx, ]), 4);
+
+ write.csv(dfcombo, "mummichog_integ_pathway_enrichment.csv", row.names = TRUE)
+ mSetObj$integ.resmat <- dfcombo
+
+ matched_cpds <- names(mSetObj$cpd_exp)
+ colnames(mum.df)[1] = "pathways";
+ inx2<-na.omit(match(mum.df$pathways[ord.inx], mSetObj$pathways$name))
+ filt_cpds <- lapply(inx2, function(f) { mSetObj$pathways$cpds[f] })
+
+ cpds <- lapply(filt_cpds, function(x) intersect(unlist(x), matched_cpds))
+ cpds_sig <- lapply(filt_cpds, function(x) intersect(unlist(x), mSetObj$input_cpdlist))
+
+ mSetObj$path.nms <- rownames(dfcombo)
+ mSetObj$path.hits <- convert2JsonList(cpds)
+ mSetObj$path.pval <- as.numeric(dfcombo[,6])
+ mSetObj <<- mSetObj;
+ matched_res <- qs::qread("mum_res.qs");
+ json.res <- list(
+ cmpd.exp = mSetObj$cpd_exp,
+ path.nms = rownames(dfcombo),
+ hits.all = convert2JsonList(cpds),
+ hits.all.size = as.numeric(dfcombo[,2]),
+ hits.sig = convert2JsonList(cpds_sig),
+ hits.sig.size = as.numeric(dfcombo[,3]),
+ mum.p = as.numeric(dfcombo[,4]),
+ gsea.p = as.numeric(dfcombo[,5]),
+ comb.p = as.numeric(dfcombo[,6]),
+ peakToMet = mSetObj$cpd_form_dict,
+ peakTable = matched_res
+ );
+
+ json.mat <- RJSONIO::toJSON(json.res, .na='null');
+ sink(mSetObj$mum_nm);
+ cat(json.mat);
+ sink();
+ }
+ return(mSetObj);
+}
+
+#' Internal function to perform PSEA, with RT
+.init.RT.Permutations <- function(mSetObj, permNum){
+
+ if(anal.type == "mummichog"){
+ mSetObj <- .perform.mummichogRTPermutations(mSetObj, permNum);
+ mSetObj <- .compute.mummichogRTSigPvals(mSetObj);
+ }else if(anal.type == "gsea_peaks"){
+ mSetObj <- .compute.mummichog.RT.fgsea(mSetObj, permNum);
+ }else{
+ # need to perform mummichog + gsea then combine p-values
+ mSetObj <- .compute.mummichog.RT.fgsea(mSetObj, permNum);
+ mSetObj <- .perform.mummichogRTPermutations(mSetObj, permNum);
+ mSetObj <- .compute.mummichogRTSigPvals(mSetObj);
+
+ pathResults <- vector("list")
+
+ pathResults$ora.all <- mSetObj$mummi.resmat
+ pathResults$gsea.all <- mSetObj$mummi.gsea.resmat
+
+ path.names.all <- lapply(pathResults, rownames)
+ path.intersect <- Reduce(intersect, path.names.all)
+
+ # remove paths not found by all three - complete.cases
+ path.intersected <- lapply(pathResults, function(x) x[row.names(x) %in% path.intersect,])
+ #li_2 <- lapply(seq_along(path.intersected), function(i) {colnames(path.intersected[[i]]) <- paste0(colnames(path.intersected[[i]]), names(path.intersected)[[i]]) ; path.intersected[[i]] } )
+ path2 <- data.table::setDF(Reduce(merge, lapply(path.intersected, data.table::data.table, keep.rownames = TRUE)))
+
+ mum.df <- path2[, c(1:4, 6, 12)]
+ rownames(mum.df) <- mum.df$rn
+ mum.df <- mum.df[,-1]
+ colnames(mum.df) <- c("Total_Size", "Hits", "Sig_Hits", "Mummichog_Pvals", "GSEA_Pvals")
+
+ # combine p-values
+ combo.all <- apply(mum.df[,c("Mummichog_Pvals", "GSEA_Pvals")], 1, function(x) sumlog(x))
+
+ #extract p-values
+ all.ps <- unlist(lapply(combo.all, function(z) z["p"]))
+ df.combo <- as.matrix(mum.df)
+ df.combo <- round(cbind(df.combo, all.ps), 5)
+ colnames(df.combo) <- c("Total_Size", "Hits", "Sig_Hits", "Mummichog_Pvals", "GSEA_Pvals", "Combined_Pvals")
+ ord.inx <- order(df.combo[,6]);
+ df.combo <- signif(as.matrix(df.combo[ord.inx, ]), 4);
+ write.csv(df.combo, "mummichog_integ_pathway_enrichment.csv", row.names = TRUE)
+ mSetObj$integ.resmat <- df.combo
+
+ ## transform ecpd to cpd for json files
+ # for all cpds
+ total_ecpds <- unique(mSetObj$total_matched_ecpds) #all matched compounds
+ current.mset <- mSetObj$pathways$emp_cpds[match(rownames(df.combo), mSetObj$pathways$name)]
+ ecpds <- lapply(current.mset, function(x) intersect(x, total_ecpds)); #pathways & all ref ecpds
+ cpds <- lapply(ecpds, function(x) unique(unlist(mSetObj$ecpd_cpd_dict[match(x, names(mSetObj$ecpd_cpd_dict))])) )
+
+ # for sig ecpds
+ qset <- unique(unlist(mSetObj$input_ecpdlist));
+ current.mset <- mSetObj$pathways$emp_cpds[match(rownames(df.combo), mSetObj$pathways$name)]
+ feats <- lapply(current.mset, function(x) intersect(x, qset));
+ cpds_feats <- lapply(feats, function(x) unique(unlist(mSetObj$ecpd_cpd_dict[match(x, names(mSetObj$ecpd_cpd_dict))])) )
+
+ # now make exp vec for all compounds
+ cpds2ec <- mSetObj$cpd_ecpd_dict
+ cpds.all <- unique(unlist(mSetObj$ecpd_cpd_dict[match(total_ecpds, names(mSetObj$ecpd_cpd_dict))]))
+ cpds.exp <- sapply(cpds.all, function(x) sapply(seq_along(x), function(i) mean(mSetObj$ec_exp[match(unique(unlist(cpds2ec[match(x[[i]], names(cpds2ec))])), names(mSetObj$ec_exp))]) ) )
+
+ mSetObj$path.nms <- rownames(df.combo)
+ mSetObj$path.hits <- convert2JsonList(cpds)
+ mSetObj$path.pval <- as.numeric(df.combo[,6])
+
+ mSetObj <<- mSetObj;
+ matched_res <- qs::qread("mum_res.qs");
+
+ json.res <- list(
+ cmpd.exp = cpds.exp,
+ path.nms = rownames(df.combo),
+ hits.all = convert2JsonList(cpds),
+ hits.all.size = as.numeric(df.combo[,2]),
+ hits.sig = convert2JsonList(cpds_feats),
+ hits.sig.size = as.numeric(df.combo[,3]),
+ mum.p = as.numeric(df.combo[,4]),
+ gsea.p = as.numeric(df.combo[,5]),
+ comb.p = as.numeric(df.combo[,6]),
+ peakToMet = mSetObj$cpd_form_dict,
+ peakTable = matched_res
+ );
+
+ json.mat <- RJSONIO::toJSON(json.res, .na='null');
+ sink(mSetObj$mum_nm);
+ cat(json.mat);
+ sink();
+ }
+ return(mSetObj);
+}
+
+# Internal function to set up library for PSEA
+.setup.psea.library <- function(mSetObj = NA, lib, libVersion, minLib=3, metaAnalysis = FALSE,
+ metaLevel = "pathway", combine.level,
+ pval.method, es.method, rank.metric, mutual.feats = TRUE){
+
+ version <- mum.version
+ filenm <- paste(lib, ".qs", sep="")
+ biocyc <- grepl("biocyc", lib)
+
+ if(!is.null(mSetObj$curr.cust)){
+
+ if(biocyc){
+ user.curr <- mSetObj$curr.map$BioCyc
+ }else{
+ user.curr <- mSetObj$curr.map$KEGG
+ }
+
+ currency <<- user.curr
+
+ if(length(currency)>0){
+ mSetObj$mummi$anal.msg <- c("Currency metabolites were successfully uploaded!")
+ }else{
+ mSetObj$mummi$anal.msg <- c("Errors in currency metabolites uploading!")
+ }
+ }
+
+ if(.on.public.web){
+ mum.url <- paste("../../libs/mummichog/", filenm, sep="");
+ print(paste("Adding mummichog library:", mum.url));
+ mummichog.lib <- qs::qread(mum.url);
+ }else{
+ if(!file.exists(filenm)){
+ mum.url <- paste("https://www.metaboanalyst.ca/resources/libs/mummichog/", filenm, sep="");
+ download.file(mum.url, destfile = filenm, method="libcurl", mode = "wb")
+ mummichog.lib <- qs::qread(filenm);
+ }else{
+ mummichog.lib <- qs::qread(filenm);
+ }
+ }
+
+ if(!is.null(mSetObj$adduct.custom)){
+ mw <- mummichog.lib$cpd.lib$mw
+ new_adducts <- new_adduct_mzlist(mSetObj, mw)
+
+ cpd.lib <- list(
+ mz.matp = new_adducts$pos,
+ mz.matn = new_adducts$neg,
+ mw = mummichog.lib$cpd.lib$mw,
+ id = mummichog.lib$cpd.lib$id,
+ name = mummichog.lib$cpd.lib$name
+ );
+
+ }else{
+ cpd.lib <- list(
+ mz.matp = mummichog.lib$cpd.lib$adducts[["positive"]],
+ mz.matn = mummichog.lib$cpd.lib$adducts[["negative"]],
+ mw = mummichog.lib$cpd.lib$mw,
+ id = mummichog.lib$cpd.lib$id,
+ name = mummichog.lib$cpd.lib$name
+ );
+ }
+
+ cpd.treep <- mummichog.lib$cpd.tree[["positive"]];
+ cpd.treen <- mummichog.lib$cpd.tree[["negative"]];
+
+ # build empirical compound library after
+ path.length <- sapply(mummichog.lib$pathways$cpds, length)
+
+ min.inx <- which(path.length >= minLib)
+
+ cleaned.pathways <- vector("list")
+ cleaned.pathways$cpds <- mummichog.lib$pathways$cpds[min.inx]
+ cleaned.pathways$id <- mummichog.lib$pathways$id[min.inx]
+ cleaned.pathways$name <- mummichog.lib$pathways$name[min.inx]
+
+ mSetObj$pathways <- cleaned.pathways;
+
+ if(metaAnalysis & metaLevel %in% c("cpd", "ec")){
+ mSetObj <- .search.compoundLibMeta(mSetObj, cpd.lib, cpd.treep, cpd.treen, metaLevel, combine.level,
+ pval.method, es.method, rank.metric, mutual.feats);
+ }else{
+ mSetObj <- .search.compoundLib(mSetObj, cpd.lib, cpd.treep, cpd.treen);
+ }
+
+ if(mSetObj$dataSet$mumRT & version=="v2"){
+ # only for empirical compounds
+ if(metaLevel %in% c("ec", "pathway", "pooled")){
+ # map cpds to empirical cpds
+ cleaned.pathways$emp_cpds <- lapply(cleaned.pathways$cpds, function(x) unique(unlist(mSetObj$cpd_ecpd_dict[na.omit(match(x, names(mSetObj$cpd_ecpd_dict)))])))
+
+ # delete emp_cpds, cpds and names with no emp_cpds
+ null.inx <- sapply(cleaned.pathways$emp_cpds, is.null)
+
+ new_pathways <- vector("list")
+ new_pathways$cpds <- cleaned.pathways$cpds[!null.inx]
+ new_pathways$name <- cleaned.pathways$name[!null.inx]
+ new_pathways$emp_cpds <- cleaned.pathways$emp_cpds[!null.inx]
+
+ mSetObj$pathways <- new_pathways;
+ }
+ }
+
+ mSetObj$lib.organism <- lib; #keep track of lib organism for sweave report
+ return(mSetObj);
+}
+
+# version 2
+# internal function for searching compound library
+.search.compoundLib <- function(mSetObj, cpd.lib, cpd.treep, cpd.treen){
+
+ ref_mzlist <- as.numeric(mSetObj$dataSet$ref_mzlist);
+ print(paste0("Got ", length(ref_mzlist), " mass features."))
+ pos_inx <- mSetObj$dataSet$pos_inx;
+ ref_mzlistp <- ref_mzlist[pos_inx];
+ ref_mzlistn <- ref_mzlist[!pos_inx];
+ version <- mum.version
+
+ # for empirical compounds
+ if(mSetObj$dataSet$mumRT & version=="v2"){
+ ord_rt <- rank(mSetObj$dataSet$ret_time, ties.method = "random")
+ ret_time_pos <- mSetObj$dataSet$ret_time[pos_inx];
+ ret_time_rank_pos <- ord_rt[pos_inx]
+ ret_time_neg <- mSetObj$dataSet$ret_time[!pos_inx]
+ ret_time_rank_neg <- ord_rt[!pos_inx]
+ rt_tol <- mSetObj$dataSet$rt_tol
+ rt_tol_rank <- length(ref_mzlist) * mSetObj$dataSet$rt_frac
+ }else{
+ # add fake RT
+ ret_time_pos <- rep(1, length(ref_mzlistp))
+ ret_time_rank_pos <- rep(1, length(ref_mzlistp))
+ ret_time_neg <- rep(1, length(ref_mzlistn))
+ ret_time_rank_neg <- rep(1, length(ref_mzlistn))
+ }
+
+ modified.statesp <- colnames(cpd.lib$mz.matp);
+ modified.statesn <- colnames(cpd.lib$mz.matn);
+ my.tolsp <- mz_tolerance(ref_mzlistp, mSetObj$dataSet$instrument);
+ my.tolsn <- mz_tolerance(ref_mzlistn, mSetObj$dataSet$instrument);
+
+ # get mz ladder (pos index)
+ self.mzsp <- floor(ref_mzlistp);
+ all.mzsp <- cbind(self.mzsp-1, self.mzsp, self.mzsp+1);
+
+ self.mzsn <- floor(ref_mzlistn);
+ all.mzsn <- cbind(self.mzsn-1, self.mzsn, self.mzsn+1);
+
+ # matched_res will contain detailed result (cmpd.id. query.mass, mass.diff) for all mz;
+ # use a high-performance variant of list
+ matched_resp <- myFastList();
+ matched_resn <- myFastList();
+
+ if(mSetObj$dataSet$mode != "negative"){
+ for(i in 1:length(ref_mzlistp)){
+ mz <- ref_mzlistp[i];
+ rt <- ret_time_pos[i];
+ rt_rank <- ret_time_rank_pos[i];
+ my.tol <- my.tolsp[i];
+ all.mz <- all.mzsp[i,];
+ pos.all <- as.numeric(unique(unlist(cpd.treep[all.mz])));
+
+ for(pos in pos.all){
+ id <- cpd.lib$id[pos];
+ mw.all <- cpd.lib$mz.matp[pos,]; #get modified mzs
+ diffs <- abs(mw.all - mz); #modified mzs - mz original
+ hit.inx <- which(diffs < my.tol);
+ if(length(hit.inx)>0){
+ for(spot in 1:length(hit.inx)){
+ hit.pos <- hit.inx[spot];# need to match all
+ index <- paste(mz, id, rt, hit.pos, sep = "___");
+ matched_resp$add(index, c(i, id, mz, rt, rt_rank, mw.all[hit.pos], modified.statesp[hit.pos], diffs[hit.pos])); #replaces previous when hit.inx>1
+ }
+ }
+ }
+ }
+ }
+
+ all.mzsn <<- all.mzsn
+
+ if(mSetObj$dataSet$mode != "positive"){
+ for(i in 1:length(ref_mzlistn)){
+ mz <- ref_mzlistn[i];
+ rt <- ret_time_neg[i];
+ rt_rank <- ret_time_rank_neg[i];
+ my.tol <- my.tolsn[i];
+ all.mz <- all.mzsn[i,];
+ pos.all <- as.numeric(unique(unlist(cpd.treen[all.mz])));
+
+ for(pos in pos.all){
+ id <- cpd.lib$id[pos]; # position of compound in cpd.tree
+ mw.all <- cpd.lib$mz.matn[pos,]; #get modified mzs
+ diffs <- abs(mw.all - mz); #modified mzs - mz original
+ hit.inx <- which(diffs < my.tol);
+ if(length(hit.inx)>0){
+ for(spot in 1:length(hit.inx)){
+ hit.pos <- hit.inx[spot];# need to match all
+ index <- paste(mz, id, rt, hit.pos, sep = "___"); #name in fast_list
+ matched_resn$add(index, c(i, id, mz, rt, rt_rank, mw.all[hit.pos], modified.statesn[hit.pos], diffs[hit.pos])); #replaces previous when hit.inx>1
+ }
+ }
+ }
+ }
+ }
+
+ # convert to regular list
+ if(mSetObj$dataSet$mode == "mixed"){
+
+ matched_resn <- matched_resn$as.list();
+ matched_resp <- matched_resp$as.list();
+
+ neg_matches <- length(matched_resn) > 0
+ pos_matches <- length(matched_resp) > 0
+
+ if(!neg_matches & !pos_matches){
+ msg.vec <<- "No compound matches from upload peak list!"
+ return(0)
+ }
+
+ if(neg_matches){
+ matched_resn <- data.frame(matrix(unlist(matched_resn), nrow=length(matched_resn), byrow=T), stringsAsFactors = FALSE);
+ }
+
+ if(pos_matches){
+ matched_resp <- data.frame(matrix(unlist(matched_resp), nrow=length(matched_resp), byrow=T), stringsAsFactors = FALSE);
+ }
+
+ if(neg_matches & pos_matches){ # both w. matches
+ matched_res <- rbind(matched_resp, matched_resn)
+ }else if(neg_matches & !pos_matches){ # only neg w. matches
+ matched_res <- matched_resn
+ }else{ # only pos w. matches
+ matched_res <- matched_resp
+ }
+
+ }else if(mSetObj$dataSet$mode == "positive"){
+ matched_resp <- matched_resp$as.list();
+
+ if(is.null(unlist(matched_resp))){
+ msg.vec <<- "No compound matches from upload peak list!"
+ return(0)
+ }
+
+ matched_resp <- data.frame(matrix(unlist(matched_resp), nrow=length(matched_resp), byrow=T), stringsAsFactors = FALSE);
+ matched_res <- matched_resp
+ }else{
+ matched_resn <- matched_resn$as.list();
+
+ if(is.null(unlist(matched_resn))){
+ msg.vec <<- "No compound matches from upload peak list!"
+ return(0)
+ }
+
+ matched_resn <- data.frame(matrix(unlist(matched_resn), nrow=length(matched_resn), byrow=T), stringsAsFactors = FALSE);
+ matched_res <- matched_resn
+ }
+
+ # re-order columns for output
+ matched_res <- matched_res[, c(3,2,7,8,4,5)];
+ colnames(matched_res) <- c("Query.Mass", "Matched.Compound", "Matched.Form", "Mass.Diff", "Retention.Time", "RT.Rank");
+
+ if(!mSetObj$dataSet$mumRT & version=="v2"){
+ matched_res <- matched_res[,-(5:6)]
+ }
+
+ #print(paste0(length(unique(matched_res[,2])), " matched compounds! cpd2mz"))
+
+ # now create empirical compounds if necessary!
+ # 1 compound matches to multiple m/z, filter by RT
+ if(mSetObj$dataSet$mumRT & version=="v2"){
+ start <- Sys.time()
+ # mz, ion
+ empirical.cpd.list <- split(matched_res[,c(1,3,5,6)], matched_res[,2]); # split mz, ion and rt by compound
+ empirical.cpds2cpds <- vector(length=(length(empirical.cpd.list)), "list")
+ names(empirical.cpds2cpds) <- names(empirical.cpd.list)
+
+ # for each compound, if multiple matches, split into ECpds if > RT tolerance - rt_tol
+ for(i in 1:length(empirical.cpd.list)){
+
+ mzs <- empirical.cpd.list[[i]]$Query.Mass
+ ions <- empirical.cpd.list[[i]]$Matched.Form
+ rts <- empirical.cpd.list[[i]]$Retention.Time
+ rt.rank <- empirical.cpd.list[[i]]$RT.Rank
+ cpds <- names(empirical.cpd.list)[i]
+
+ # first, for each compound, determine ECs among matched ions
+ if(length(mzs)>1){ # if multiple ECs per compound
+
+ # first group together to create empirical cpds by rt
+ rts <- as.numeric(rts)
+ names(rts) <- paste0(mzs, ";", ions, ";", rts, ";", cpds)
+ rts <- sort(rts)
+
+ # second, group together to create empirical cpds by rt rank
+ rt.ranks <- as.numeric(rt.rank)
+ names(rt.ranks) <- paste0(mzs, ";", ions, ";", rts, ";", cpds)
+ rt.ranks <- sort(rt.ranks)
+
+ split.inx <- c(0, cumsum(Reduce("&", list(abs(diff(rts)) > rt_tol, abs(diff(rt.ranks)) > rt_tol_rank) )))
+
+ # need to deal w. multiple rts but only 1 EC
+ if(length(unique(split.inx)) > 1){
+ e.cpds <- split(rts, split.inx)
+ empirical.cpds2cpds[[i]] <- lapply(e.cpds, names)
+ }else{
+ empirical.cpds2cpds[[i]] <- paste0(names(rts), collapse="__")
+ }
+
+ }else{ # if only 1 EC per compound
+ empirical.cpds2cpds[[i]] <- paste0(mzs, ";", ions, ";", rts, ";", cpds)
+ }
+ }
+
+ initial_ecs <- unlist(empirical.cpds2cpds, recursive=FALSE)
+ names(initial_ecs) <- paste0("EC", 1:length(initial_ecs))
+ print(paste0(length(initial_ecs), " inital ECs created!"))
+
+ # second, merge ECs if same m/z and form - append compounds
+ try <- reshape2::melt(initial_ecs)
+ try2 <- strsplit(as.character(try[,1]), split="__", fixed=TRUE) # deals with multiple rts belonging to 1 EC
+ try2.df <- data.frame(value=unlist(try2), L1 = rep(try$L1, sapply(try2, length)))
+
+ info <- strsplit(as.character(try2.df[,1]), split=";")
+ df_ecs <- data.frame(ec=as.character(try2.df[,2]), mz=sapply(info, `[[`, 1), form=sapply(info, `[[`, 2), rt = sapply(info, `[[`, 3), cpd = sapply(info, `[[`, 4), stringsAsFactors = F)
+ df_ecs$str_row_inx <- paste(df_ecs$mz, df_ecs$form, df_ecs$rt, sep = "___")
+ qs::qsave(df_ecs, "initial_ecs.qs")
+ merged_ecs <- aggregate(. ~ str_row_inx, df_ecs, paste, collapse=";")
+
+ # cleaning the df
+ # merged_ecs$ec <- sapply(strsplit(merged_ecs$ec, ";", fixed=TRUE), function(x) unlist(x)[1]) - keep as long name
+ merged_ecs$mz <- sapply(strsplit(merged_ecs$mz, ";", fixed=TRUE), function(x) unique(unlist(x)))
+ merged_ecs$form <- sapply(strsplit(merged_ecs$form, ";", fixed=TRUE), function(x) unique(unlist(x)))
+ merged_ecs$rt <- sapply(strsplit(merged_ecs$rt, ";", fixed=TRUE), function(x) unique(unlist(x)))
+ print(paste0(length(unique(merged_ecs$ec)), " merged ECs identified!"))
+
+ # third, check if primary ion is present
+ # needs to be per EC!
+ if(mSetObj$dataSet$primary_ion=="yes"){
+
+ ecs <- unique(merged_ecs$ec)
+
+ # function to group ECs and verify if contains primary ion
+ new_info <- lapply(ecs, function(x) {
+ new_info <- merged_ecs[which(merged_ecs$ec == x),] # subset merged_ecs to rows containing ECx
+ primary.inx <- length(intersect(new_info$form, primary_ions))
+
+ if(primary.inx>0){
+ new_info <- new_info
+ }else{
+ new_info <- NULL
+ }
+ new_info
+ })
+
+ final_ecs <- do.call(args=new_info, what=rbind)[,-1]
+
+ }else{
+ final_ecs <- merged_ecs[,-1]
+ }
+
+ colnames(final_ecs) <- c("Empirical.Compound", "Query.Mass", "Matched.Form", "Retention.Time", "Matched.Compound")
+
+ # transform to long format
+ cpd_split <- strsplit(as.character(final_ecs$Matched.Compound), ";", fixed=TRUE)
+ reps <- pmax(lengths(cpd_split))
+ df2 <- final_ecs[rep(1:nrow(final_ecs), reps), 1:4]
+ df2$Matched.Compound <- unlist(mapply(function(x,y) c(x, rep(NA, y)), cpd_split, reps-lengths(cpd_split)))
+
+ matched_res <- merge(matched_res, df2)
+ matched_res <- matched_res[,-6] #rm rt rank
+ matched_res[,6] <- as.character(matched_res[,6])
+
+ # now deal with the fact that if at least one EC overlap, need to count as same EC per compound...
+ my_final_cpds <- aggregate(. ~ Matched.Compound, matched_res, paste, collapse="___")
+ my_final_cpds_list <- lapply(split(my_final_cpds$Empirical.Compound, my_final_cpds$Matched.Compound), unlist)
+
+ cpd2ec1 <- lapply(seq_along(my_final_cpds_list), function(x) { # function used to make grouping of ecs per cpd
+
+ ecs <- unlist(strsplit(my_final_cpds_list[[x]], "___", fixed=TRUE))
+
+ if(length(ecs) > 1){
+ ecs.list <- as.list(strsplit(ecs, ";", fixed=TRUE))
+ library(igraph)
+ m = sapply(ecs.list, function(x) sapply(ecs.list, function(y) length(intersect(x,y))>0))
+ g = igraph::groups(components(graph_from_adjacency_matrix(m)))
+ ecs <- paste0(sapply(g, function(z) paste0(ecs[z], collapse = "|") ), collapse = "___")
+ }
+ ecs
+ })
+
+ names(cpd2ec1) <- names(my_final_cpds_list)
+
+ update_ecs <- lapply(seq_along(cpd2ec1), function(z) {
+
+ ecs.old <- unlist(strsplit(my_final_cpds_list[[z]], "___", fixed=TRUE))
+ ecs.new <- unlist(strsplit(cpd2ec1[[z]], "___", fixed=TRUE))
+
+ for(i in seq_along(ecs.new)){
+ pattern <- ecs.new[i]
+ pattern_vec <- unlist(strsplit(pattern, "\\|"))
+ up.pattern <- paste0(unique(pattern_vec), collapse = "|")
+ ecs.old[ ecs.old %in% pattern_vec ] <- up.pattern
+ }
+
+ ecs.old <- paste0(ecs.old, collapse = "___")
+ ecs.old
+ })
+
+ updated_ecs <- do.call(rbind, update_ecs)
+ my_final_cpds$Empirical.Compound <- updated_ecs
+
+ new_dt <- data.table::data.table(my_final_cpds)
+ new_dt <- new_dt[, list(Query.Mass = unlist(strsplit(as.character(Query.Mass), "___", fixed=TRUE)),
+ Matched.Form = unlist(strsplit(as.character(Matched.Form), "___", fixed=TRUE)),
+ Retention.Time = unlist(strsplit(as.character(Retention.Time), "___", fixed=TRUE)),
+ Mass.Diff = unlist(strsplit(as.character(Mass.Diff), "___", fixed=TRUE)),
+ Empirical.Compound = unlist(strsplit(as.character(Empirical.Compound), "___", fixed=TRUE))),
+ by = Matched.Compound]
+
+ matched_res <- data.frame(Query.Mass = new_dt$Query.Mass, Matched.Compound = new_dt$Matched.Compound, Matched.Form = new_dt$Matched.Form,
+ Retention.Time = new_dt$Retention.Time, Mass.Diff = new_dt$Mass.Diff, Empirical.Compound = new_dt$Empirical.Compound, stringsAsFactors = FALSE)
+
+ # make EC names
+ ec <- matched_res$Empirical.Compound
+ ec.unique <- unique(matched_res$Empirical.Compound)
+
+ for(i in seq_along(ec.unique)){
+ ec <- replace(ec, grep(paste0("\\b", ec.unique[i], "\\b"), ec, perl=TRUE), paste0("EC000", i))
+ }
+
+ #for(i in seq_along(ec.unique)){
+ # ec <- gsub(paste0("\\b", ec.unique[i], "\\b"), paste0("EC000", i), ec)
+ #}
+
+ matched_res$Empirical.Compound <- gsub("\\|.*", "", ec)
+ end <- Sys.time()
+ totaltime <- end-start
+ print(paste0(length(unique(matched_res$Empirical.Compound)), " empirical compounds identified in ", totaltime, " seconds."))
+ }
+
+ fast.write.csv(matched_res, file="mummichog_matched_compound_all.csv", row.names=FALSE);
+ qs::qsave(matched_res, "mum_res.qs");
+
+ # now update expr. profile
+ matched_mz <- matched_res[,1];
+ matched_ts <- mSetObj$dataSet$expr_dic[matched_mz];
+
+ if(mSetObj$dataSet$mumRT & version=="v2"){ # RT need to be in EC space
+ # first create ecpd to expression dict
+ ec.exp.mat <- data.frame(key=matched_res[,6], value=as.numeric(matched_ts), stringsAsFactors = F)
+ ec_exp_dict <- Convert2Dictionary(ec.exp.mat);
+ ec.exp.vec <- unlist(lapply(ec_exp_dict, max));
+
+ # also need to make cpd_exp_dict for KEGG network view
+ exp.mat <- data.frame(key=matched_res[,2], value=as.numeric(matched_ts));
+ cpd_exp_dict <- Convert2Dictionary(exp.mat);
+
+ # ecpd to cpd dict
+ cpd_ecpd_dict <- Convert2Dictionary(matched_res[,c(2,6)])
+ ecpd_cpd_dict <- Convert2Dictionary(matched_res[,c(6,2)])
+
+ # now mz 2 ecpd dict
+ mz2cpd_dict <- Convert2Dictionary(matched_res[,c(1,2)]); #indexed/named by mz
+ mz2ec_dict <- Convert2Dictionary(matched_res[,c(1,6)])
+ ec2mz_dict <- Convert2Dictionary(matched_res[,c(6,1)])
+
+ # save to mSetObj
+ mSetObj$ec_exp_dict <- ec_exp_dict
+ mSetObj$cpd_exp_dict <- cpd_exp_dict;
+ mSetObj$ec_exp <- ec.exp.vec
+ mSetObj$mz2cpd_dict <- mz2cpd_dict;
+ mSetObj$mz2ec_dict <- mz2ec_dict
+ mSetObj$ec2mz_dict <- ec2mz_dict
+ mSetObj$ecpd_cpd_dict <- ecpd_cpd_dict
+ mSetObj$cpd_ecpd_dict <- cpd_ecpd_dict
+ mSetObj$cpd_ecpd_counts <- cpd2ec1
+
+ # now do matching to identify significant input_ecpdlist
+ refmz <- names(mz2ec_dict)
+ hits.index <- which(refmz %in% as.character(mSetObj$dataSet$input_mzlist));
+ ec1 <- unique(unlist(mz2ec_dict[hits.index]));
+ mSetObj$input_ecpdlist <- ec1;
+ mSetObj$total_matched_ecpds <- unique(as.vector(matched_res$Empirical.Compound));
+ }else{
+ # get the expression profile for each
+ exp.mat <- data.frame(key=matched_res[,2], value=as.numeric(matched_ts));
+ cpd_exp_dict <- Convert2Dictionary(exp.mat);
+ # create average exp
+ exp.vec <- unlist(lapply(cpd_exp_dict, mean));
+
+ # now need to get the mapping from mz to compound id (one mz can have 0, 1, or more id hits)
+ mz2cpd_dict <- Convert2Dictionary(matched_res[,c(1,2)]); #indexed/named by mz
+ cpd2mz_dict <- Convert2Dictionary(matched_res[,c(2,1)]); # indexed/named by id
+
+ # now do matching to identify significant input_cpdlist
+ refmz <- names(mz2cpd_dict)
+ hits.index <- which(refmz %in% as.character(mSetObj$dataSet$input_mzlist));
+ cpd1 <- unique(unlist(mz2cpd_dict[hits.index]));
+ cpd1 <- cpd1[!(cpd1 %in% currency)];
+
+ mSetObj$mz2cpd_dict <- mz2cpd_dict;
+ mSetObj$cpd_exp_dict <- cpd_exp_dict;
+ mSetObj$cpd_exp <- exp.vec;
+ mSetObj$cpd2mz_dict <- cpd2mz_dict;
+ mSetObj$input_cpdlist <- cpd1;
+ mSetObj$total_matched_cpds <- unique(as.vector(matched_res$Matched.Compound));
+ }
+
+ form.mat <- cbind(matched_res[,2], matched_res[,3]);
+ cpd_form_dict <- Convert2Dictionary(form.mat);
+ mSetObj$cpd_form_dict <- cpd_form_dict;
+
+ return(mSetObj);
+}
+
+# version 2
+# internal function for searching compound library
+.search.compoundLibMeta <- function(mSetObjMeta, cpd.lib, cpd.treep, cpd.treen, metaLevel = "cpd",
+ combine.level = "pvalue", pval.method = "fisher", es.method = "fixed",
+ rank.metric = "mean", mutual.feats = TRUE){
+
+ metaFiles <- unique(metaFiles)
+
+ metaMsetObj <- vector("list")
+ version <- mum.version
+
+ # first do compound mapping
+ for(meta_file in seq_along(metaFiles)){
+
+ mSetObj <- qs::qread(metaFiles[meta_file])
+ ref_mzlist <- as.numeric(mSetObj$dataSet$ref_mzlist);
+ print(paste0("Got ", length(ref_mzlist), " mass features."))
+ pos_inx <- mSetObj$dataSet$pos_inx;
+ ref_mzlistp <- ref_mzlist[pos_inx];
+ ref_mzlistn <- ref_mzlist[!pos_inx];
+
+ # for empirical compounds
+ if(mSetObj$dataSet$mumRT){
+ ret_time_pos <- mSetObj$dataSet$ret_time[pos_inx];
+ ret_time_neg <- mSetObj$dataSet$ret_time[!pos_inx]
+ rt_tol <- mSetObj$dataSet$rt_tol
+ }else{
+ # add fake RT
+ ret_time_pos <- rep(1, length(ref_mzlistp))
+ ret_time_neg <- rep(1, length(ref_mzlistn))
+ }
+
+ modified.statesp <- colnames(cpd.lib$mz.matp);
+ modified.statesn <- colnames(cpd.lib$mz.matn);
+ my.tolsp <- mz_tolerance(ref_mzlistp, mSetObj$dataSet$instrument);
+ my.tolsn <- mz_tolerance(ref_mzlistn, mSetObj$dataSet$instrument);
+
+ # get mz ladder (pos index)
+ self.mzsp <- floor(ref_mzlistp);
+ all.mzsp <- cbind(self.mzsp-1, self.mzsp, self.mzsp+1);
+
+ self.mzsn <- floor(ref_mzlistn);
+ all.mzsn <- cbind(self.mzsn-1, self.mzsn, self.mzsn+1);
+
+ # matched_res will contain detailed result (cmpd.id. query.mass, mass.diff) for all mz;
+ # use a high-performance variant of list
+ matched_resp <- myFastList();
+ matched_resn <- myFastList();
+
+ if(mSetObj$dataSet$mode != "negative"){
+ for(i in seq_along(ref_mzlistp)){
+ mz <- ref_mzlistp[i];
+ rt <- ret_time_pos[i];
+ my.tol <- my.tolsp[i];
+ all.mz <- all.mzsp[i,];
+ pos.all <- as.numeric(unique(unlist(cpd.treep[all.mz])));
+
+ for(pos in pos.all){
+ id <- cpd.lib$id[pos];
+ mw.all <- cpd.lib$mz.matp[pos,]; #get modified mzs
+ diffs <- abs(mw.all - mz); #modified mzs - mz original
+ hit.inx <- which(diffs < my.tol);
+ if(length(hit.inx)>0){
+ for(spot in seq_along(hit.inx)){
+ hit.pos <- hit.inx[spot];# need to match all
+ index <- paste(mz, id, rt, hit.pos, sep = "_");
+ matched_resp$add(index, c(i, id, mz, rt, mw.all[hit.pos], modified.statesp[hit.pos], diffs[hit.pos])); #replaces previous when hit.inx>1
+ }
+ }
+ }
+ }
+ }
+
+ all.mzsn <<- all.mzsn
+
+ if(mSetObj$dataSet$mode != "positive"){
+ for(i in seq_along(ref_mzlistn)){
+ mz <- ref_mzlistn[i];
+ rt <- ret_time_neg[i];
+ my.tol <- my.tolsn[i];
+ all.mz <- all.mzsn[i,];
+ pos.all <- as.numeric(unique(unlist(cpd.treen[all.mz])));
+
+ for(pos in pos.all){
+ id <- cpd.lib$id[pos]; # position of compound in cpd.tree
+ mw.all <- cpd.lib$mz.matn[pos,]; #get modified mzs
+ diffs <- abs(mw.all - mz); #modified mzs - mz original
+ hit.inx <- which(diffs < my.tol);
+ if(length(hit.inx)>0){
+ for(spot in seq_along(hit.inx)){
+ hit.pos <- hit.inx[spot];# need to match all
+ index <- paste(mz, id, rt, hit.pos, sep = "_"); #name in fast_list
+ matched_resn$add(index, c(i, id, mz, rt, mw.all[hit.pos], modified.statesn[hit.pos], diffs[hit.pos])); #replaces previous when hit.inx>1
+ }
+ }
+ }
+ }
+ }
+
+ # convert to regular list
+ if(mSetObj$dataSet$mode == "mixed"){
+
+ matched_resn <- matched_resn$as.list();
+ matched_resp <- matched_resp$as.list();
+
+ neg_matches <- length(matched_resn) > 0
+ pos_matches <- length(matched_resp) > 0
+
+ if(!neg_matches & !pos_matches){
+ msg.vec <<- "No compound matches from upload peak list!"
+ return(0)
+ }
+
+ if(neg_matches){
+ matched_resn <- data.frame(matrix(unlist(matched_resn), nrow=length(matched_resn), byrow=T), stringsAsFactors = FALSE);
+ }
+
+ if(pos_matches){
+ matched_resp <- data.frame(matrix(unlist(matched_resp), nrow=length(matched_resp), byrow=T), stringsAsFactors = FALSE);
+ }
+
+ if(neg_matches & pos_matches){ # both w. matches
+ matched_res <- rbind(matched_resp, matched_resn)
+ }else if(neg_matches & !pos_matches){ # only neg w. matches
+ matched_res <- matched_resn
+ }else{ # only pos w. matches
+ matched_res <- matched_resp
+ }
+
+ }else if(mSetObj$dataSet$mode == "positive"){
+ matched_resp <- matched_resp$as.list();
+
+ if(is.null(unlist(matched_resp))){
+ msg.vec <<- "No compound matches from upload peak list!"
+ return(0)
+ }
+
+ matched_resp <- data.frame(matrix(unlist(matched_resp), nrow=length(matched_resp), byrow=T), stringsAsFactors = FALSE);
+ matched_res <- matched_resp
+ }else{
+ matched_resn <- matched_resn$as.list();
+
+ if(is.null(unlist(matched_resn))){
+ msg.vec <<- "No compound matches from upload peak list!"
+ return(0)
+ }
+
+ matched_resn <- data.frame(matrix(unlist(matched_resn), nrow=length(matched_resn), byrow=T), stringsAsFactors = FALSE);
+ matched_res <- matched_resn
+ }
+
+ # re-order columns for output
+ matched_res <- matched_res[, c(3,2,6,7,4)];
+ colnames(matched_res) <- c("Query.Mass", "Matched.Compound", "Matched.Form", "Mass.Diff", "Retention.Time");
+
+ if(metaLevel == "cpd"){
+ fileName = paste0("mummichog_matched_compound_", mSetObj$dataSet$fileName, "_all.csv")
+ fast.write.csv(matched_res, file=fileName, row.names=FALSE);
+ }
+
+ # objects save to meta msetObj
+ metafile <- tools::file_path_sans_ext(metaFiles[meta_file])
+ metaMsetObj[[metafile]] <- vector("list", 5)
+
+ # now update expr. profile
+ matched_mz <- matched_res[,1];
+ matched_ts <- mSetObj$dataSet$expr_dic[matched_mz];
+
+ if(combine.level %in% c("pvalue", "both", "pool")){
+ pvals <- mSetObj$dataSet$mummi.proc$p.value
+ names(pvals) <- mSetObj$dataSet$mummi.proc$m.z
+ matched_pvals <- pvals[matched_mz]
+ metaMsetObj[[metafile]]$matched_pvals <- matched_pvals;
+ }
+
+ if(combine.level %in% c("es", "both")){
+ es <- mSetObj$dataSet$mummi.proc[,c("effect.size", "lower.ci", "upper.ci")]
+ rownames(es) <- mSetObj$dataSet$mummi.proc$m.z
+ match.inx <- match(matched_mz, rownames(es))
+ matched_es <- es[match.inx,]
+ metaMsetObj[[metafile]]$matched_es <- matched_es;
+ }
+
+ metaMsetObj[[metafile]]$mumResTable <- matched_res;
+ metaMsetObj[[metafile]]$ref_mzlist <- mSetObj$dataSet$ref_mzlist
+ metaMsetObj[[metafile]]$input_mzlist <- mSetObj$dataSet$input_mzlist
+ metaMsetObj[[metafile]]$matched_ts <- matched_ts;
+ metaMsetObj[[metafile]]$mumRT <-mSetObj$dataSet$mumRT
+ }
+
+ # second fill in p-value and effect size information
+ mSetObj <- mSetObjMeta;
+
+ matched_res <- lapply(metaMsetObj, "[[", "mumResTable")
+ matched_res <- data.table::rbindlist(matched_res, idcol = TRUE)
+ matched_ts <- unlist(lapply(metaMsetObj, "[[", "matched_ts"))
+ matched_res <- cbind(matched_res, matched_ts)
+
+ if(combine.level %in% c("pvalue", "both", "pool")){
+ matched_pval <- unlist(lapply(metaMsetObj, "[[", "matched_pvals"))
+ }else{ # initialize empty
+ matched_pval <- rep(NA, length(matched_ts))
+ }
+
+ if(combine.level %in% c("es", "both")){
+ matched_es <- lapply(metaMsetObj, "[[", "matched_es")
+ matched_es <- Reduce(rbind, matched_es)
+ }else{ # initialize empty
+ matched_es <- matrix("1", nrow = length(matched_ts), ncol=3)
+ colnames(matched_es) <- c("effect.size", "lower.ci", "upper.ci")
+ }
+
+ matched_res <- cbind(matched_res, Matched.Pval = matched_pval, matched_es)
+
+ # combine at compound level
+ if(metaLevel == "cpd"){
+
+ if(mutual.feats){
+ matched_res_ag <- aggregate(. ~ Matched.Compound, matched_res, paste, collapse=";")
+
+ # keep compounds that only match across all files
+ matched <- strsplit(matched_res_ag$.id, ";", fixed=TRUE)
+ matched.inx <- vapply(matched, function(x) length(unique(x))==length(metaFiles), logical(1))
+
+ if(sum(matched.inx) == 0){
+ AddErrMsg("No compounds found across all files!")
+ return(0)
+ }
+
+ matched_res_ag <- matched_res_ag[matched.inx,]
+ # undo aggregate
+
+ matched_res <- splitstackshape::cSplit(matched_res_ag, c(".id", "Query.Mass", "Matched.Form", "Mass.Diff", "Retention.Time", "matched_ts",
+ "Matched.Pval", "effect.size", "lower.ci", "upper.ci"),
+ ";", "long", makeEqual = FALSE, type.convert = "as.character")
+ matched_res <- data.table::setDF(matched_res)
+ colnames(matched_res)[2] <- "File.Name"
+ colnames(matched_res)[7:11] <- c("Matched.Scores", "Matched.Pvalue", "Matched.ES", "Matched.L.CI", "Matched.U.CI")
+
+ }else{
+ matched_res <- matched_res[, c(3,1,2,4:11)]
+ matched_res <- data.table::setDF(matched_res)
+ colnames(matched_res)[2] <- "File.Name"
+ colnames(matched_res)[7:11] <- c("Matched.Scores", "Matched.Pvalue", "Matched.ES", "Matched.L.CI", "Matched.U.CI")
+ }
+
+ fast.write.csv(matched_res, file="mummichog_matched_compound_all.csv", row.names=FALSE);
+ # or empirical compound combining here!
+ }else{
+
+ all_ref_mz <- unlist(lapply(metaMsetObj, "[[", "ref_mzlist"))
+
+ matched_res$RT.Rank <- rank(as.numeric(matched_res$Retention.Time), ties.method = "random")
+ rt_tol_rank <- length(all_ref_mz) * mSetObj$dataSet$rt_frac
+
+ # now create empirical compounds if necessary!
+ # 1 compound matches to multiple m/z, filter by RT
+ if(mSetObj$dataSet$mumRT & version=="v2"){
+
+ start <- Sys.time()
+ empirical.cpd.list <- data.table:::split.data.table(matched_res, by="Matched.Compound", sorted = TRUE); # split all info by compound
+ empirical.cpds2cpds <- vector(length=(length(empirical.cpd.list)), "list")
+ names(empirical.cpds2cpds) <- names(empirical.cpd.list)
+
+ # for each compound, if multiple matches, split into ECpds if > RT tolerance - rt_tol
+ for(i in seq_along(empirical.cpd.list)){
+
+ id <- empirical.cpd.list[[i]]$.id
+ mzs <- empirical.cpd.list[[i]]$Query.Mass
+ ions <- empirical.cpd.list[[i]]$Matched.Form
+ rts <- as.numeric(empirical.cpd.list[[i]]$Retention.Time)
+ rt.rank <- as.numeric(empirical.cpd.list[[i]]$RT.Rank)
+ score <- empirical.cpd.list[[i]]$matched_ts
+ mass.diff <- empirical.cpd.list[[i]]$Mass.Diff
+ p.val <- empirical.cpd.list[[i]]$Matched.Pval
+ es <- empirical.cpd.list[[i]]$effect.size
+ l.ci <- empirical.cpd.list[[i]]$lower.ci
+ u.ci <- empirical.cpd.list[[i]]$upper.ci
+ cpds <- names(empirical.cpd.list)[i]
+
+ # first, for each compound, determine ECs among matched ions
+ if(length(mzs)>1){ # if multiple ECs per compound
+
+ # first group together to create empirical cpds by rt
+ names(rts) <- paste0(mzs, ";", ions, ";", rts, ";", cpds, ";", id, ";", score,
+ ";", mass.diff, ";", p.val,";", es, ";", l.ci, ";", u.ci)
+ rts <- sort(rts)
+
+ # second, group together to create empirical cpds by rt rank
+ names(rt.rank) <- paste0(mzs, ";", ions, ";", rts, ";", cpds, ";", id, ";", score,
+ ";", mass.diff, ";", p.val,";", es, ";", l.ci, ";", u.ci)
+ rt.rank <- sort(rt.rank)
+
+ split.inx <- c(0, cumsum(Reduce("&", list(abs(diff(rts)) > rt_tol, abs(diff(rt.rank)) > rt_tol_rank) )))
+
+ # need to deal w. multiple rts but only 1 EC
+ if(length(unique(split.inx)) > 1){
+ e.cpds <- split(rts, split.inx)
+ empirical.cpds2cpds[[i]] <- lapply(e.cpds, names)
+ }else{
+ empirical.cpds2cpds[[i]] <- paste0(names(rts), collapse="__")
+ }
+
+ }else{ # if only 1 EC per compound
+ empirical.cpds2cpds[[i]] <- paste0(mzs, ";", ions, ";", rts, ";", cpds, ";", id, ";", score,
+ ";", mass.diff, ";", p.val,";", es, ";", l.ci, ";", u.ci)
+ }
+ }
+
+ initial_ecs <- unlist(empirical.cpds2cpds, recursive=FALSE)
+ names(initial_ecs) <- paste0("EC", seq_along(initial_ecs))
+ print(paste0(length(initial_ecs), " inital ECs created!"))
+
+ # second, merge ECs if same m/z and form - append compounds
+ try <- reshape2::melt(initial_ecs)
+ try2 <- strsplit(as.character(try[,1]), split="__", fixed=TRUE) # deals with multiple rts belonging to 1 EC
+ try2 <- data.frame(value=unlist(try2), L1 = rep(try$L1, sapply(try2, length)))
+
+ info <- strsplit(as.character(try2[,1]), split=";", fixed=TRUE)
+
+ df_ecs <- data.frame(ec = as.character(try2[,2]), mz = sapply(info, `[[`, 1), form = sapply(info, `[[`, 2), rt = sapply(info, `[[`, 3),
+ cpd = sapply(info, `[[`, 4), id = sapply(info, `[[`, 5), score = sapply(info, `[[`, 6),
+ mass_diff = sapply(info, `[[`, 7), pval = sapply(info, `[[`, 8), es = sapply(info, `[[`, 9),
+ lci = sapply(info, `[[`, 10), uci = sapply(info, `[[`, 11), stringsAsFactors = F)
+
+ df_ecs$str_row_inx <- paste(df_ecs$mz, df_ecs$form, df_ecs$rt, sep = "___")
+ merged_ecs <- aggregate(. ~ str_row_inx, df_ecs, paste, collapse=";")
+
+ # cleaning the df
+ # merged_ecs$ec <- sapply(strsplit(merged_ecs$ec, ";"), function(x) unlist(x)[1]) - keep as long name
+ merged_ecs$mz <- sapply(strsplit(merged_ecs$mz, ";", fixed=TRUE), function(x) unique(unlist(x)))
+ merged_ecs$form <- sapply(strsplit(merged_ecs$form, ";", fixed=TRUE), function(x) unique(unlist(x)))
+ merged_ecs$rt <- sapply(strsplit(merged_ecs$rt, ";", fixed=TRUE), function(x) unique(unlist(x)))
+ merged_ecs$id <- sapply(strsplit(merged_ecs$id, ";", fixed=TRUE), function(x) paste0(unique(unlist(x)), collapse=";"))
+ merged_ecs$score <- sapply(strsplit(merged_ecs$score, ";", fixed=TRUE), function(x) paste0(unique(unlist(x)), collapse=";") )
+ merged_ecs$mass_diff <- sapply(strsplit(merged_ecs$mass_diff, ";", fixed=TRUE), function(x) paste0(unique(unlist(x)), collapse=";") )
+ merged_ecs$pval <- sapply(strsplit(merged_ecs$pval, ";", fixed=TRUE), function(x) paste0(unique(unlist(x)), collapse=";") )
+ merged_ecs$es <- sapply(strsplit(merged_ecs$es, ";", fixed=TRUE), function(x) paste0(unique(unlist(x)), collapse=";") )
+ merged_ecs$lci <- sapply(strsplit(merged_ecs$lci, ";", fixed=TRUE), function(x) paste0(unique(unlist(x)), collapse=";") )
+ merged_ecs$uci <- sapply(strsplit(merged_ecs$uci, ";", fixed=TRUE), function(x) paste0(unique(unlist(x)), collapse=";") )
+ print(paste0(length(unique(merged_ecs$ec)), " merged ECs identified!"))
+
+ # third, check if primary ion is present
+ # needs to be per EC!
+ if(mSetObj$dataSet$primary_ion=="yes"){
+
+ ecs <- unique(merged_ecs$ec)
+
+ # function to group ECs and verify if contains primary ion
+ new_info <- lapply(ecs, function(x) {
+ new_ec_info <- merged_ecs[which(merged_ecs$ec == x),] # subset merged_ecs to rows containing ECx
+ primary.inx <- length(intersect(new_ec_info$form, primary_ions))
+
+ if(primary.inx>0){
+ new_ec_info <- new_ec_info
+ }else{
+ new_ec_info <- NULL
+ }
+ new_ec_info
+ })
+
+ final_ecs <- do.call(args=new_info, what=rbind)[,-1]
+
+ }else{
+ final_ecs <- merged_ecs[,-1]
+ }
+
+ colnames(final_ecs) <- c("Empirical.Compound", "Query.Mass", "Matched.Form", "Retention.Time", "Matched.Compound", "FileName", "Matched.Scores",
+ "Mass.Diff", "Matched.Pvalue", "Matched.ES", "Matched.L.CI", "Matched.U.CI")
+
+ # transform to long format
+ cpd_split <- strsplit(as.character(final_ecs$Matched.Compound), ";", fixed=TRUE)
+ reps <- pmax(lengths(cpd_split))
+ df2 <- final_ecs[rep(1:nrow(final_ecs), reps), c(1:4, 6:12)]
+ df2$Matched.Compound <- unlist(mapply(function(x,y) c(x, rep(NA, y)), cpd_split, reps-lengths(cpd_split)))
+ df2 <- unique(df2)
+
+ # now deal with the fact that if at least one EC overlap, need to count as same EC per compound...
+ my_final_cpds <- aggregate(. ~ Matched.Compound, df2, paste, collapse="___")
+ my_final_cpds_list <- lapply(split(my_final_cpds$Empirical.Compound, my_final_cpds$Matched.Compound), unlist)
+
+ cpd2ec1 <- lapply(seq_along(my_final_cpds_list), function(x) { # function used to make grouping of ecs per cpd
+
+ ecs <- unlist(strsplit(my_final_cpds_list[[x]], "___", fixed=TRUE))
+
+ if(length(ecs) > 1){
+ ecs.list <- as.list(strsplit(ecs, ";", fixed=TRUE))
+ library(igraph)
+ m = sapply(ecs.list, function(x) sapply(ecs.list, function(y) length(intersect(x,y))>0))
+ g = igraph::groups(components(graph_from_adjacency_matrix(m)))
+ ecs <- paste0(sapply(g, function(z) paste0(ecs[z], collapse = "|") ), collapse = "___")
+ }
+ ecs
+ })
+
+ names(cpd2ec1) <- names(my_final_cpds_list)
+
+ update_ecs <- lapply(seq_along(cpd2ec1), function(z) {
+
+ ecs.old <- unlist(strsplit(my_final_cpds_list[[z]], "___", fixed=TRUE))
+ ecs.new <- unlist(strsplit(cpd2ec1[[z]], "___", fixed=TRUE))
+
+ for(i in seq_along(ecs.new)){
+ pattern <- ecs.new[i]
+ pattern_vec <- unlist(strsplit(pattern, "\\|", fixed=TRUE))
+ up.pattern <- paste0(unique(pattern_vec), collapse = "|")
+ ecs.old[ ecs.old %in% pattern_vec ] <- up.pattern
+ }
+
+ ecs.old <- paste0(ecs.old, collapse = "___")
+ ecs.old
+ })
+
+ updated_ecs <- do.call(rbind, update_ecs)
+ my_final_cpds$Empirical.Compound <- updated_ecs
+
+ new_dt <- data.table::data.table(my_final_cpds)
+ new_dt <- new_dt[, list(Query.Mass = unlist(strsplit(as.character(Query.Mass), "___", fixed=TRUE)),
+ Matched.Form = unlist(strsplit(as.character(Matched.Form), "___", fixed=TRUE)),
+ Retention.Time = unlist(strsplit(as.character(Retention.Time), "___", fixed=TRUE)),
+ Empirical.Compound = unlist(strsplit(as.character(Empirical.Compound), "___", fixed=TRUE)),
+ File.Name = unlist(strsplit(as.character(FileName), "___", fixed=TRUE)),
+ Matched.Scores = unlist(strsplit(as.character(Matched.Scores), "___", fixed=TRUE)),
+ Mass.Diff = unlist(strsplit(as.character(Mass.Diff), "___", fixed=TRUE)),
+ Matched.Pvalue = unlist(strsplit(as.character(Matched.Pvalue), "___", fixed=TRUE)),
+ Matched.ES = unlist(strsplit(as.character(Matched.ES), "___", fixed=TRUE)),
+ Matched.L.CI = unlist(strsplit(as.character(Matched.L.CI), "___", fixed=TRUE)),
+ Matched.U.CI = unlist(strsplit(as.character(Matched.U.CI), "___", fixed=TRUE))
+ ),
+ by = Matched.Compound]
+
+ matched_res <- data.frame(Query.Mass = new_dt$Query.Mass, Matched.Compound = new_dt$Matched.Compound, Matched.Form = new_dt$Matched.Form, Mass.Diff = new_dt$Mass.Diff,
+ Retention.Time = new_dt$Retention.Time, Matched.Scores = new_dt$Matched.Scores, Matched.Pvalue = new_dt$Matched.Pvalue,
+ Matched.ES = new_dt$Matched.ES, Matched.L.CI = new_dt$Matched.L.CI, Matched.U.CI = new_dt$Matched.U.CI,
+ Empirical.Compound = new_dt$Empirical.Compound, File.Name = new_dt$File.Name, stringsAsFactors = FALSE)
+
+ # make new EC names
+ ec <- as.list(matched_res$Empirical.Compound)
+ ec.unique <- unique(matched_res$Empirical.Compound)
+ ec.new <- paste0("EC000", seq_along(ec.unique))
+
+ ec.new <- vapply(seq_along(ec), function(i) {
+
+ inx <- match(ec[[i]], ec.unique)
+ ec <- ec.new[inx]
+ ec
+
+ }, character(1))
+
+ matched_res$Empirical.Compound <- gsub("\\|.*", "", ec.new)
+ end <- Sys.time()
+ totaltime <- end-start
+ print(paste0(length(unique(matched_res$Empirical.Compound)), " empirical compounds identified in ", totaltime, " seconds."))
+
+ if(mutual.feats){
+ # keep empirical compounds that only match across all files
+ matched_res <- aggregate(. ~ Empirical.Compound, matched_res, paste, collapse="___")
+ matched <- strsplit(matched_res$File.Name, ";|___")
+ matched.inx <- vapply(matched, function(x) length(unique(x))==length(metaFiles), logical(1))
+
+ if(sum(matched.inx)==0){
+ AddErrMsg("No empirical compounds found across all studies!")
+ return(0)
+ }else if(sum(matched.inx) < 50){
+ AddErrMsg("Not enough empirical compounds matched across all studies! Try meta-analysis at a higher level (compound or pathway).")
+ return(0)
+ }
+
+ print(paste0(sum(matched.inx), "matched empirical compounds identified across all studies!"))
+
+ matched_res <- matched_res[matched.inx,]
+ matched_res <- splitstackshape::cSplit(matched_res, c("Query.Mass", "Matched.Compound", "Matched.Form", "Mass.Diff", "Retention.Time", "Matched.Scores",
+ "Matched.Pvalue", "Matched.ES", "Matched.L.CI", "Matched.U.CI", "File.Name"),
+ "___", "long", makeEqual = FALSE, type.convert = "as.character")
+ matched_res <- data.table::setDF(matched_res)
+ }else{
+ matched_res <- matched_res[,c(11,1:10,12)]
+ matched_res <- data.table::setDF(matched_res)
+ }
+ fast.write.csv(matched_res, file="mummichog_matched_compound_postmerge.csv", row.names=FALSE);
+ }else{
+ AddErrMsg("Meta-analysis at empirical compound level is invalid!")
+ return(0)
+ }
+ }
+
+ ref_mzlist <- lapply(metaMsetObj, "[[", "ref_mzlist")
+ ref_mzlist <- unlist(unique(ref_mzlist))
+ mSetObj$dataSet$ref_mzlist <- ref_mzlist
+
+ mumRT <- unlist(lapply(metaMsetObj, "[[", "mumRT"))
+ qs::qsave(matched_res, "mum_res.qs");
+
+ ##############################################
+ # COMBINE EITHER P-VALUES
+ # EFFECT-SIZES
+ # OR BOTH (only for mummichog or integ_peaks)
+ # then re-make input_cpdlist and input_ecpdlist
+ # gsea uses rank metric only
+
+ # if(anal.type %in% c("mummichog", "integ_peaks")){
+
+ if(combine.level %in% c("pvalue", "both")){
+
+ if(metaLevel %in% "ec"){
+ # merge to empirical compounds
+ all_p <- aggregate(. ~ Empirical.Compound, matched_res, paste, collapse="___")
+ old_p <- strsplit(all_p$Matched.Pvalue, "___", fixed=TRUE)
+ scores <- strsplit(all_p$Matched.Pvalue, ";|___")
+ scores <- lapply(scores, function(x) {
+ if(length(x) == 1){
+ x <- rep(x, 2)
+ }
+ x;})
+
+ }else{
+ # merge to compounds
+ all_p <- aggregate(. ~ Matched.Compound, matched_res, paste, collapse="___")
+ old_p <- strsplit(all_p$Matched.Pvalue, "___", fixed=TRUE)
+ scores <- strsplit(all_p$Matched.Pvalue, ";|___")
+ scores <- lapply(scores, function(x) {
+ if(length(x) == 1){
+ x <- rep(x, 2)
+ }
+ x;})
+ }
+
+ # combine p-values
+ if(pval.method=="fisher"){
+ meta.pvals <- lapply(scores, function(x) metap::sumlog(as.numeric(x)))
+ }else if(pval.method=="edgington"){
+ meta.pvals <- lapply(scores, function(x) metap::sump(as.numeric(x)))
+ }else if(pval.method=="stouffer"){
+ meta.pvals <- lapply(scores, function(x) metap::sumz(x))
+ }else if(pval.method=="vote"){
+ meta.pvals <- lapply(scores, function(x) metap::votep(x))
+ }else if(pval.method=="min"){
+ Meta.P <- lapply(scores, function(x) min(x) )
+ }else if(pval.method=="max") {
+ Meta.P <- lapply(scores, function(x) max(x) )
+ }else{
+ AddErrMsg("Invalid meta-analysis method!")
+ return(0)
+ }
+
+ #extract p-values
+ if(exists("meta.pvals")){
+ Meta.P <- unlist(lapply(meta.pvals, function(z) z["p"]))
+ }
+
+ Meta.P2 <- rep(Meta.P, vapply(old_p, length, numeric(1)))
+ matched_res$Meta.P <- Meta.P2
+ # }
+
+ # now create input mzlist - used to create
+ # input cpd/ec list
+ cutoff <- mSetObj$dataSet$cutoff
+
+ if(combine.level == "both"){
+ my.inx <- matched_res[,"Meta.P.Both"] < cutoff
+ }else if(combine.level == "pvalue"){
+ my.inx <- matched_res[,"Meta.P"] < cutoff
+ }else{
+ my.inx <- matched_res[,"Meta.ES.Pval"] < cutoff
+ }
+
+ input_mzlist <- unlist(unique(matched_res[as.vector(my.inx), "Query.Mass"]))
+
+ }else{ # gsea
+ input_mzlist <- lapply(metaMsetObj, "[[", "input_mzlist")
+ input_mzlist <- unlist(unique(input_mzlist)) # will be updated later
+ }
+
+ sig.size <- length(input_mzlist);
+ mSetObj$dataSet$N <- sig.size;
+ mSetObj$dataSet$input_mzlist <- input_mzlist
+
+ if(all(mumRT) & version=="v2"){ # RT need to be in EC space
+
+ # for GSEA
+ # need to merge t-scores if same m/z in the data
+ if(rank.metric == "mean"){ # default using the mean
+ matched_res$Matched.Scores <- vapply(matched_res$Matched.Scores, function(x) mean(as.numeric(unlist(strsplit(as.character(x), ";", fixed=TRUE)))), numeric(1))
+ }else if(rank.metric == "min"){
+ matched_res$Matched.Scores <- vapply(matched_res$Matched.Scores, function(x) min(as.numeric(unlist(strsplit(as.character(x), ";", fixed=TRUE)))), numeric(1))
+ }else if(rank.metric == "max"){
+ matched_res$Matched.Scores <- vapply(matched_res$Matched.Scores, function(x) max(as.numeric(unlist(strsplit(as.character(x), ";", fixed=TRUE)))), numeric(1))
+ }else if(rank.metric == "median"){
+ matched_res$Matched.Scores <- vapply(matched_res$Matched.Scores, function(x) median(as.numeric(unlist(strsplit(as.character(x), ";", fixed=TRUE)))), numeric(1))
+ }else{
+ AddErrMsg("Invalid method selected for merging scores!")
+ return(0)
+ }
+
+ ec.exp.mat <- data.frame(key=matched_res$Empirical.Compound, value=as.numeric(matched_res$Matched.Scores), stringsAsFactors = F)
+ ec_exp_dict <- Convert2Dictionary(ec.exp.mat);
+ ec.exp.vec <- unlist(lapply(ec_exp_dict, max));
+
+ # also need to make cpd_exp_dict for KEGG network view
+ exp.mat <- data.frame(key=matched_res$Matched.Compound, value=as.numeric(matched_res$Matched.Scores), stringsAsFactors = F);
+ cpd_exp_dict <- Convert2Dictionary(exp.mat);
+
+ # ecpd to cpd dict
+ cpd_ecpd_dict <- Convert2Dictionary(matched_res[,c(3,1)])
+ ecpd_cpd_dict <- Convert2Dictionary(matched_res[,c(1,3)])
+
+ # now mz 2 ecpd dict
+ mz2cpd_dict <- Convert2Dictionary(matched_res[,c(2,3)]); #indexed/named by mz
+ mz2ec_dict <- Convert2Dictionary(matched_res[,c(2,1)])
+ ec2mz_dict <- Convert2Dictionary(matched_res[,c(1,2)])
+
+ # save to mSetObj
+ mSetObj$ec_exp_dict <- ec_exp_dict
+ mSetObj$cpd_exp_dict <- cpd_exp_dict;
+ mSetObj$ec_exp <- ec.exp.vec
+ mSetObj$mz2cpd_dict <- mz2cpd_dict;
+ mSetObj$mz2ec_dict <- mz2ec_dict
+ mSetObj$ec2mz_dict <- ec2mz_dict
+ mSetObj$ecpd_cpd_dict <- ecpd_cpd_dict
+ mSetObj$cpd_ecpd_dict <- cpd_ecpd_dict
+ mSetObj$cpd_ecpd_counts <- cpd2ec1
+
+ # now do matching to identify significant input_ecpdlist
+ # trio.list <- data.frame(mz = names(mz2ec_dict), ec = sapply(mz2ec_dict, paste, collapse="; "), cpd = sapply(mz2cpd_dict, paste, collapse="; "))
+ refmz <- names(mz2ec_dict)
+ hits.index <- which(refmz %in% as.character(input_mzlist));
+ ec1 <- unique(unlist(mz2ec_dict[hits.index]));
+ mSetObj$input_ecpdlist <- ec1;
+ mSetObj$total_matched_ecpds <- unique(as.vector(matched_res$Empirical.Compound));
+ form.mat <- cbind(matched_res[,2], matched_res[,4]);
+
+ }else{ # compound level
+
+ # get the expression profile for each
+ exp.mat <- data.frame(key=matched_res$Matched.Compound, value=as.numeric(matched_res$Matched.Scores), stringsAsFactors = F);
+ cpd_exp_dict <- Convert2Dictionary(exp.mat);
+ # create average exp
+ exp.vec <- unlist(lapply(cpd_exp_dict, function(x) mean(unlist(x))));
+
+ # now need to get the mapping from mz to compound id (one mz can have 0, 1, or more id hits)
+ mz2cpd_dict <- Convert2Dictionary(matched_res[ , c("Query.Mass", "Matched.Compound")]) #indexed/named by mz
+ cpd2mz_dict <- Convert2Dictionary(matched_res[ , c("Matched.Compound", "Query.Mass")]) # indexed/named by id
+
+ # now do matching to identify significant input_cpdlist
+ refmz <- names(mz2cpd_dict)
+ hits.index <- which(refmz %in% as.character(input_mzlist));
+ cpd1 <- unique(unlist(mz2cpd_dict[hits.index]));
+ cpd1 <- cpd1[!(cpd1 %in% currency)];
+ form.mat <- cbind(matched_res$Query.Mass, matched_res$Matched.Form);
+
+ mSetObj$mz2cpd_dict <- mz2cpd_dict;
+ mSetObj$cpd_exp_dict <- cpd_exp_dict;
+ mSetObj$cpd_exp <- exp.vec;
+ mSetObj$cpd2mz_dict <- cpd2mz_dict;
+ mSetObj$input_cpdlist <- cpd1;
+ mSetObj$dataSet$N <- length(input_mzlist);
+ mSetObj$total_matched_cpds <- unique(as.vector(matched_res$Matched.Compound));
+ }
+
+ cpd_form_dict <- Convert2Dictionary(form.mat);
+ mSetObj$cpd_form_dict <- cpd_form_dict;
+ return(mSetObj);
+}
+
+#'@param method If "cohen", computes Cohen's d, if "hedges",
+#'computes Hegdes' g effect size statistics.
+CalculateEffectSize <- function(mSetObj=NA, paired=FALSE, method="cohen"){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ inx1 <- which(mSetObj$dataSet$cls==levels(mSetObj$dataSet$cls)[1])
+ inx2 <- which(mSetObj$dataSet$cls==levels(mSetObj$dataSet$cls)[2])
+
+ # samples in row, features in columns
+ x <- mSetObj$dataSet$norm[inx1,]
+ y <- mSetObj$dataSet$norm[inx2,]
+
+ library(effsize)
+
+ my.fun <- function(x) {
+
+ if(method == "cohen"){
+ tmp <- try(cohen.d(x[inx1], x[inx2], paired=paired, hedges.correction=FALSE));
+ }else{
+ tmp <- try(cohen.d(x[inx1], x[inx2], paired=paired, hedges.correction=TRUE));
+ }
+
+ if(class(tmp) == "try-error") {
+ return(c(NA, NA, NA, NA));
+ }else{
+ return(c(tmp$estimate, tmp$sd, tmp$conf.int));
+ }
+ }
+
+ results <- apply(as.matrix(mSetObj$dataSet$norm), 2, my.fun)
+ rownames(results) <- c("effect_size", "win_group_stdev", "lower_ci", "upper_ci")
+
+ mSetObj$analSet$effect.size <- t(results);
+ return(.set.mSet(mSetObj));
+}
+
+# Internal function for permutation, no RT
+.perform.mummichogPermutations <- function(mSetObj, permNum){
+
+ num_perm <- permNum;
+ print(paste('Resampling, ', num_perm, 'permutations to estimate background ...'));
+ permutation_hits <- permutation_record <- vector("list", num_perm);
+ matched_res <- qs::qread("mum_res.qs");
+ set.seed(123)
+ for(i in 1:num_perm){ # for each permutation, create list of input compounds and calculate pvalues for each pathway
+ input_mzlist <- sample(mSetObj$dataSet$ref_mzlist, mSetObj$dataSet$N)
+ t <- make_cpdlist(mSetObj, input_mzlist);
+ perm <- ComputeMummichogPermPvals(t, mSetObj$total_matched_cpds, mSetObj$pathways, matched_res, input_mzlist, mSetObj$cpd2mz_dict);
+ permutation_record[[i]] <- perm[1]
+ permutation_hits[[i]] <- perm[2]
+ }
+
+ mSetObj$perm_record <- permutation_record;
+ mSetObj$perm_hits <- permutation_hits
+
+ return(mSetObj);
+}
+
+# Calculate p-values for each Lperm
+# Used in higher mummichogR functions w.out RT
+ComputeMummichogPermPvals <- function(input_cpdlist, total_matched_cpds, pathways, matches.res, input_mzlist, cpd2mz_dict){
+
+ ora.vec <- input_cpdlist; #Lperm
+ query_set_size <- length(ora.vec)
+ current.mset <- pathways$cpds; #all
+ total_cpds <- unique(total_matched_cpds) #matched compounds
+ total_feature_num <- length(total_cpds)
+
+ size <- negneg <- vector(mode="list", length=length(current.mset));
+
+ cpds <- lapply(current.mset, function(x) intersect(x, total_cpds)); # pathways & all ref cpds
+ feats <- lapply(current.mset, function(x) intersect(x, ora.vec)); #pathways & lsig
+ feat_len <- unlist(lapply(feats, length)); # length of overlap features
+ set.num <- unlist(lapply(cpds, length)); #cpdnum
+
+ negneg <- sizes <- vector(mode="list", length=length(current.mset));
+
+ for(i in seq_along(current.mset)){ # for each pathway
+ sizes[[i]] <- min(feat_len[i], count_cpd2mz(cpd2mz_dict, unlist(feats[i]), input_mzlist))
+ negneg[[i]] <- total_feature_num + sizes[[i]] - set.num[i] - query_set_size;
+ }
+
+ unsize <- as.integer(unlist(sizes))
+ res.mat <- matrix(0, nrow=length(current.mset), ncol=1)
+ fishermatrix <- cbind(unsize-1, set.num, (query_set_size + unlist(negneg)), query_set_size)
+ res.mat[,1] <- apply(fishermatrix, 1, function(x) phyper(x[1], x[2], x[3], x[4], lower.tail=FALSE));
+ perm_records <- list(res.mat, as.matrix(unsize));
+ return(perm_records);
+}
+
+# Internal function for permutation
+.perform.mummichogRTPermutations <- function(mSetObj, permNum){
+ num_perm <- permNum;
+ print(paste('Resampling, ', num_perm, 'permutations to estimate background ...'));
+ permutation_hits <- permutation_record <- vector("list", num_perm);
+ matched_res <- qs::qread("mum_res.qs");
+ set.seed(123)
+ for(i in 1:num_perm){ # for each permutation, create list of input emp compounds and calculate pvalues for each pathway
+ input_mzlist <- sample(mSetObj$dataSet$ref_mzlist, mSetObj$dataSet$N)
+ t <- make_ecpdlist(mSetObj, input_mzlist);
+ perm <- ComputeMummichogRTPermPvals(t, mSetObj$total_matched_ecpds, mSetObj$pathways, matched_res, input_mzlist);
+ permutation_record[[i]] <- perm[1]
+ permutation_hits[[i]] <- perm[2]
+ }
+
+ mSetObj$perm_record <- permutation_record;
+ mSetObj$perm_hits <- permutation_hits
+
+ return(mSetObj);
+}
+
+# Calculate p-values for each Lperm
+# Used in higher mummichogR functions w. RT
+ComputeMummichogRTPermPvals <- function(input_ecpdlist, total_matched_ecpds, pathways, matches.res, input_mzlist){
+
+ ora.vec <- input_ecpdlist; #Lperm
+ query_set_size <- length(ora.vec) # query set size
+ current.mset <- pathways$emp_cpds; #all
+ total_ecpds <- unique(total_matched_ecpds) # matched number of empirical compounds
+ total_feature_num <- length(total_ecpds)
+
+ size <- negneg <- vector(mode="list", length=length(current.mset));
+
+ ecpds <- lapply(current.mset, function(x) intersect(x, total_ecpds)); # pathways & all ref ecpds
+ feats <- lapply(current.mset, function(x) intersect(x, ora.vec)); #pathways & query ecpds (perm lsig)
+ feat_len <- unlist(lapply(feats, length)); # length of overlap features
+ set.num <- unlist(lapply(ecpds, length)); #cpdnum
+
+ negneg <- sizes <- vector(mode="list", length=length(current.mset));
+
+ for(i in seq_along(current.mset)){ # for each pathway
+ sizes[[i]] <- feat_len[i] # for ecs, just use length of overlap feats - overlap_size
+ negneg[[i]] <- total_feature_num + sizes[[i]] - set.num[i] - query_set_size;
+ }
+
+ unsize <- as.integer(unlist(sizes))
+ res.mat <- matrix(0, nrow=length(current.mset), ncol=1)
+ fishermatrix <- cbind(unsize-1, set.num, (query_set_size + unlist(negneg)), query_set_size)
+ res.mat[,1] <- apply(fishermatrix, 1, function(x) phyper(x[1], x[2], x[3], x[4], lower.tail=FALSE));
+ perm_records <- list(res.mat, as.matrix(unsize));
+ return(perm_records);
+}
+
+# Internal function for significant p value
+.compute.mummichogSigPvals <- function(mSetObj){
+
+ qset <- unique(unlist(mSetObj$input_cpdlist)); #Lsig ora.vec
+ query_set_size <- length(qset); #q.size
+
+ total_cpds <- unique(mSetObj$total_matched_cpds) #all matched compounds
+ total_feature_num <- length(total_cpds)
+
+ current.mset <- mSetObj$pathways$cpds; #all compounds per pathway
+ path.num <- unlist(lapply(current.mset, length));
+
+ cpds <- lapply(current.mset, function(x) intersect(x, total_cpds)); #pathways & all ref cpds
+ set.num <- unlist(lapply(cpds, length)); #cpdnum
+
+ feats <- lapply(current.mset, function(x) intersect(x, qset)); #pathways & lsig
+ feat_len <- unlist(lapply(feats, length)); # length of overlap features
+ feat_vec <- sapply(feats, function(x) paste(x, collapse=";"))
+
+ negneg <- sizes <- vector(mode="list", length=length(current.mset)); #empty lists
+
+ for(i in seq_along(current.mset)){ # for each pathway
+ sizes[[i]] <- min(feat_len[i], count_cpd2mz(mSetObj$cpd2mz_dict, unlist(feats[i]), mSetObj$dataSet$input_mzlist)) #min overlap or mz hits
+ negneg[[i]] <- total_feature_num + sizes[[i]] - set.num[i] - query_set_size; # failure in left part
+ }
+
+ #error fixing for negatives, problem occurs when total_feat_num and query_set_size too close (lsig too close to lall)
+ negneg <- rapply(negneg, function(x) ifelse(x<0,0,x), how = "replace")
+
+ unsize <- as.integer(unlist(sizes));
+
+ uniq.count <- length(unique(unlist(current.mset, use.names = FALSE)));
+
+ # prepare for the result table
+ res.mat <- matrix(0, nrow=length(current.mset), ncol=6);
+
+ #fishermatrix for phyper
+ fishermatrix <- cbind(unsize-1, set.num, (query_set_size + unlist(negneg) - unsize), query_set_size);
+ first <- unlist(lapply(sizes, function(x) max(0, x-1)));
+ easematrix <- cbind(first, (set.num - unsize + 1), (query_set_size - unsize), unlist(negneg));
+
+ res.mat[,1] <- path.num;
+ res.mat[,2] <- set.num;
+ res.mat[,3] <- unsize;
+ res.mat[,4] <- query_set_size*(path.num/uniq.count); #expected
+ res.mat[,6] <- apply(easematrix, 1, function(x) fisher.test(matrix(x, nrow=2), alternative = "greater")$p.value);
+ res.mat[,5] <- apply(fishermatrix, 1, function(x) phyper(x[1], x[2], x[3], x[4], lower.tail=FALSE));
+ colnames(res.mat) <- c("Pathway total", "Hits.total", "Hits.sig", "Expected", "FET", "EASE");
+ rownames(res.mat) <- mSetObj$pathways$name
+
+ mSetObj$pvals <- res.mat;
+ permutations_hits <- matrix(unlist(mSetObj$perm_hits), nrow=length(mSetObj$perm_hits), byrow=TRUE);
+ sig_hits <- res.mat[,3]; # sighits
+ sigpvalue <- res.mat[,6]; # EASE scores
+
+ perm_record <- unlist(mSetObj$perm_record);
+ perm_minus <- abs(0.9999999999 - perm_record);
+
+ if(length(sig_hits[sig_hits!=0]) < round(length(sig_hits)*0.05)){ # too few hits that can't calculate gamma dist!
+ if(!exists("adjustedp")){
+ adjustedp <- rep(NA, length = length(res.mat[,1]))
+ }
+ res.mat <- cbind(res.mat, Gamma=adjustedp);
+ }else{
+ tryCatch({
+ fit.gamma <- fitdistrplus::fitdist(perm_minus, distr = "gamma", method = "mle", lower = c(0, 0), start = list(scale = 1, shape = 1));
+ rawpval <- as.numeric(sigpvalue);
+ adjustedp <- 1 - (pgamma(1-rawpval, shape = fit.gamma$estimate["shape"], rate = fit.gamma$estimate["scale"]));
+ }, error = function(e){
+ if(mSetObj$dataSet$mumType == "table"){
+ if(!exists("adjustedp")){
+ adjustedp <- rep(NA, length = length(res.mat[,1]))
+ }
+ res.mat <- cbind(res.mat, Gamma=adjustedp);
+ }
+ print(e)
+ }, finally = {
+ if(!exists("adjustedp")){
+ adjustedp <- rep(NA, length = length(res.mat[,1]))
+ }
+ res.mat <- cbind(res.mat, Gamma=adjustedp);
+ })
+ }
+
+ #calculate empirical p-values
+ record <- mSetObj$perm_record
+ fisher.p <- as.numeric(res.mat[,5])
+
+ #pathway in rows, perms in columns
+ record_matrix <- do.call(cbind, do.call(cbind, record))
+ num_perm <- ncol(record_matrix)
+
+ #number of better hits for web
+ better.hits <- sapply(seq_along(record_matrix[,1]), function(i) sum(record_matrix[i,] <= fisher.p[i]) )
+
+ #account for a bias due to finite sampling - Davison and Hinkley (1997)
+ emp.p <- sapply(seq_along(record_matrix[,1]), function(i) (sum(record_matrix[i,] <= fisher.p[i])/num_perm) )
+
+ res.mat <- cbind(res.mat, Emp.Hits=better.hits, Empirical=emp.p, Cpd.Hits = feat_vec)
+
+ # remove those no hits
+ hit.inx <- as.numeric(as.character(res.mat[,3])) > 0;
+ res.mat <- res.mat[hit.inx, , drop=FALSE];
+
+ if(nrow(res.mat) <= 1){
+ AddErrMsg("Not enough m/z to compound hits for pathway analysis!")
+ return(0)
+ }
+
+ # prepare json element for network
+ hits.all <- cpds[hit.inx];
+ hits.sig <- feats[hit.inx];
+ path.nms <- mSetObj$pathways$name[hit.inx];
+
+ # order by p-values
+ ord.inx <- order(res.mat[,7]);
+
+ Cpd.Hits <- res.mat[ord.inx, 10]
+ res.mat <- signif(apply(as.matrix(res.mat[ord.inx, 1:9, drop=FALSE]), 2, as.numeric), 5);
+ rownames(res.mat) <- path.nms[ord.inx]
+ mSetObj$mummi.resmat <- res.mat[,-9];
+
+ mSetObj$path.nms <- path.nms[ord.inx]
+ mSetObj$path.hits <- convert2JsonList(hits.all[ord.inx])
+ mSetObj$path.pval <- as.numeric(res.mat[,5])
+ matched_res <- qs::qread("mum_res.qs");
+
+ json.res <- list(
+ cmpd.exp = mSetObj$cpd_exp,
+ path.nms = path.nms[ord.inx],
+ hits.all = convert2JsonList(hits.all[ord.inx]),
+ hits.all.size = as.numeric(res.mat[,2]),
+ hits.sig = convert2JsonList(hits.sig[ord.inx]),
+ hits.sig.size = as.numeric(res.mat[,3]),
+ fisher.p = as.numeric(res.mat[,7]),
+ peakToMet = mSetObj$cpd_form_dict,
+ peakTable = matched_res
+ );
+
+ matri = res.mat[,-8]
+ matri = cbind(res.mat, paste0("P", seq.int(1, nrow(res.mat))))
+ colnames(matri)[ncol(matri)] = "Pathway Number"
+ matri <- cbind(matri, Cpd.Hits)
+ fast.write.csv(matri, file=mSetObj$mum_nm_csv, row.names=TRUE);
+ json.mat <- RJSONIO::toJSON(json.res, .na='null');
+ sink(mSetObj$mum_nm);
+ cat(json.mat);
+ sink();
+ return(mSetObj);
+}
+
+# Internal function for significant p value with RT
+.compute.mummichogRTSigPvals <- function(mSetObj){
+
+ qset <- unique(unlist(mSetObj$input_ecpdlist)); #Lsig ora.vec
+ query_set_size <- length(qset); #q.size
+
+ total_ecpds <- unique(mSetObj$total_matched_ecpds) #all matched compounds
+ total_feature_num <- length(total_ecpds)
+
+ current.mset <- mSetObj$pathways$emp_cpds; #all compounds per pathway
+ path.num <- unlist(lapply(current.mset, length));
+
+ ecpds <- lapply(current.mset, function(x) intersect(x, total_ecpds)); #pathways & all ref ecpds
+ set.num <- unlist(lapply(ecpds, length)); # total ecpd num in pathway
+
+ feats <- lapply(current.mset, function(x) intersect(x, qset)); #pathways & lsig
+ feat_len <- unlist(lapply(feats, length)); # length of overlap features
+ feat_vec <- sapply(feats, function(x) paste(x, collapse=";"))
+
+ negneg <- sizes <- vector(mode="list", length=length(current.mset)); #empty lists
+
+ for(i in seq_along(current.mset)){ # for each pathway
+ sizes[[i]] <- feat_len[i] # overlap size
+ negneg[[i]] <- total_feature_num + sizes[[i]] - set.num[i] - query_set_size; # failure in left part
+ }
+
+ #error fixing for negatives, problem occurs when total_feat_num and query_set_size too close (lsig too close to lall)
+ negneg <- rapply(negneg, function(x) ifelse(x<0,0,x), how = "replace")
+
+ unsize <- as.integer(unlist(sizes));
+
+ uniq.count <- length(unique(unlist(current.mset, use.names = FALSE)));
+
+ # prepare for the result table
+ res.mat <- matrix(0, nrow=length(current.mset), ncol=6);
+
+ #fishermatrix for phyper
+ fishermatrix <- cbind(unsize-1, set.num, (query_set_size + unlist(negneg) - unsize), query_set_size);
+ first <- unlist(lapply(sizes, function(x) max(0, x-1)));
+ easematrix <- cbind(first, (set.num - unsize + 1), (query_set_size - unsize), unlist(negneg));
+
+ res.mat[,1] <- path.num;
+ res.mat[,2] <- set.num;
+ res.mat[,3] <- unsize;
+ res.mat[,4] <- query_set_size*(path.num/uniq.count); #expected
+ res.mat[,5] <- apply(fishermatrix, 1, function(x) phyper(x[1], x[2], x[3], x[4], lower.tail=FALSE));
+ res.mat[,6] <- apply(easematrix, 1, function(x) fisher.test(matrix(x, nrow=2), alternative = "greater")$p.value);
+
+ colnames(res.mat) <- c("Pathway total", "Hits.total", "Hits.sig", "Expected", "FET", "EASE");
+ rownames(res.mat) <- mSetObj$pathways$name
+
+ mSetObj$pvals <- res.mat;
+ permutations_hits <- matrix(unlist(mSetObj$perm_hits), nrow=length(mSetObj$perm_hits), byrow=TRUE);
+ sig_hits <- res.mat[,3]; # sighits
+ sigpvalue <- res.mat[,5]; # EASE scores
+
+ perm_record <- unlist(mSetObj$perm_record);
+ perm_minus <- abs(0.9999999999 - perm_record);
+
+ if(length(sig_hits[sig_hits!=0]) < round(length(sig_hits)*0.05)){ # too few hits that can't calculate gamma dist!
+ if(!exists("adjustedp")){
+ adjustedp <- rep(NA, length = length(res.mat[,1]))
+ }
+ res.mat <- cbind(res.mat, Gamma=adjustedp);
+ }else{
+ tryCatch({
+ fit.gamma <- fitdistrplus::fitdist(perm_minus, distr = "gamma", method = "mle", lower = c(0, 0), start = list(scale = 1, shape = 1));
+ rawpval <- as.numeric(sigpvalue);
+ adjustedp <- 1 - (pgamma(1-rawpval, shape = fit.gamma$estimate["shape"], rate = fit.gamma$estimate["scale"]));
+ }, error = function(e){
+ if(mSetObj$dataSet$mumType == "table"){
+ if(!exists("adjustedp")){
+ adjustedp <- rep(NA, length = length(res.mat[,1]))
+ }
+ res.mat <- cbind(res.mat, Gamma=adjustedp);
+ }
+ print(e)
+ }, finally = {
+ if(!exists("adjustedp")){
+ adjustedp <- rep(NA, length = length(res.mat[,1]))
+ }
+ res.mat <- cbind(res.mat, Gamma=adjustedp);
+ })
+ }
+
+ #calculate empirical p-values
+ record <- mSetObj$perm_record
+ fisher.p <- as.numeric(res.mat[,5])
+
+ #pathway in rows, perms in columns
+ record_matrix <- do.call(cbind, do.call(cbind, record))
+ num_perm <- ncol(record_matrix)
+
+ #number of better hits for web
+ better.hits <- sapply(seq_along(record_matrix[,1]), function(i) sum(record_matrix[i,] <= fisher.p[i]) )
+
+ #account for a bias due to finite sampling - Davison and Hinkley (1997)
+ emp.p <- sapply(seq_along(record_matrix[,1]), function(i) (sum(record_matrix[i,] <= fisher.p[i])/num_perm) )
+
+ res.mat <- cbind(res.mat, Emp.Hits = better.hits, Empirical = emp.p, EC.Hits = feat_vec)
+
+ # remove pathways with no hits
+ hit.inx <- as.numeric(as.character(res.mat[,3])) > 0;
+ res.mat <- res.mat[hit.inx, , drop=FALSE];
+
+ if(nrow(res.mat) <= 1){
+ AddErrMsg("Not enough m/z to compound hits for pathway analysis! Try Version 1 (no RT considerations)!")
+ return(0)
+ }
+
+ # prepare json element for network
+ # need to convert ecpds to cpds
+ # and get average expression based on ec
+ cpds <- lapply(ecpds, function(x) unique(unlist(mSetObj$ecpd_cpd_dict[match(x, names(mSetObj$ecpd_cpd_dict))])) )
+ cpd.exp.vec <- sapply(ecpds, function(x) mean(mSetObj$ec_exp[match(x, names(mSetObj$ec_exp))]) )
+ cpds_feats <- lapply(feats, function(x) unique(unlist(mSetObj$ecpd_cpd_dict[match(x, names(mSetObj$ecpd_cpd_dict))])) )
+
+ # now make exp vec for all compounds
+ cpds2ec <- mSetObj$cpd_ecpd_dict
+ cpds.all <- unique(unlist(mSetObj$ecpd_cpd_dict[match(total_ecpds, names(mSetObj$ecpd_cpd_dict))]))
+ cpd.exp.vec <- sapply(cpds.all, function(x) sapply(seq_along(x), function(i) mean(mSetObj$ec_exp[match(unique(unlist(cpds2ec[match(x[[i]], names(cpds2ec))])), names(mSetObj$ec_exp))]) ) )
+
+ hits.all <- cpds[hit.inx];
+ hits.sig <- cpds_feats[hit.inx];
+ path.nms <- mSetObj$pathways$name[hit.inx];
+
+ # order by p-values
+ if(length(na.omit(res.mat[,7])) == 0){
+ ord.inx <- order(res.mat[,5]); # order by FET if gamma not able to be calc
+ }else{
+ ord.inx <- order(res.mat[,7]); # order by gamma
+ }
+
+ EC.Hits = res.mat[ord.inx, 10]
+ res.mat <- signif(apply(as.matrix(res.mat[ord.inx, 1:9]), 2, as.numeric), 5); # loop through columns and keep rownames
+ rownames(res.mat) <- path.nms[ord.inx]
+
+ mSetObj$mummi.resmat <- res.mat[,-9];
+ mSetObj$path.nms <- path.nms[ord.inx]
+ mSetObj$path.hits <- convert2JsonList(hits.all[ord.inx])
+ mSetObj$path.pval <- as.numeric(res.mat[,5])
+ matched_res <- qs::qread("mum_res.qs");
+
+ json.res <- list(
+ cmpd.exp = cpd.exp.vec,
+ path.nms = path.nms[ord.inx],
+ hits.all = convert2JsonList(hits.all[ord.inx]),
+ hits.all.size = as.numeric(res.mat[,2]),
+ hits.sig = convert2JsonList(hits.sig[ord.inx]),
+ hits.sig.size = as.numeric(res.mat[,3]),
+ fisher.p = as.numeric(res.mat[,7]),
+ peakToMet = mSetObj$cpd_form_dict,
+ peakTable = matched_res
+ );
+
+ matri = res.mat[,-8]
+ matri = cbind(res.mat, paste0("P", seq.int(1, nrow(res.mat))))
+ colnames(matri)[ncol(matri)] = "Pathway Number"
+ matri <- cbind(matri, EC.Hits)
+ fast.write.csv(matri, file=mSetObj$mum_nm_csv, row.names=TRUE);
+ json.mat <- RJSONIO::toJSON(json.res, .na='null');
+ sink(mSetObj$mum_nm);
+ cat(json.mat);
+ sink();
+ return(mSetObj);
+}
+
+#' Internal function for calculating GSEA, no RT
+.compute.mummichog.fgsea <- function(mSetObj, permNum){
+
+ num_perm <- permNum;
+ total_cpds <- mSetObj$cpd_exp #scores from all matched compounds
+
+ current.mset <- mSetObj$pathways$cpds; #all compounds per pathway
+ names(current.mset) <- mSetObj$pathways$name
+ path.size <- unlist(lapply(mSetObj$pathways$cpds, length)) #total size of pathways
+
+ df.scores <- data.frame(id=names(total_cpds), scores=total_cpds)
+ ag.scores <- aggregate(id ~ scores, data = df.scores, paste, collapse = "; ")
+
+ ag.sorted <- ag.scores[order(-ag.scores$scores),]
+ row.names(ag.sorted) <- NULL
+
+ dt.scores <- data.table::data.table(ag.sorted)
+ dt.scores.out <- dt.scores[, list(scores=scores, id = unlist(strsplit(id, "; ", fixed = TRUE))), by=1:nrow(dt.scores)]
+
+ rank.vec <- as.numeric(dt.scores.out$nrow)
+ names(rank.vec) <- as.character(dt.scores.out$id)
+
+ scores.vec <- as.numeric(ag.sorted$scores)
+ names(scores.vec) <- as.character(ag.sorted$id)
+
+ # run fgsea
+ if(mumDataContainsPval == 0){
+ rank.vec = seq.int(1, length(mSetObj$cpd_exp))
+ names(rank.vec) <- names(mSetObj$cpd_exp)
+ scores.vec = seq.int(1, length(mSetObj$cpd_exp))
+ names(scores.vec) <- names(mSetObj$cpd_exp)
+ }
+
+ fgseaRes <- fgsea2(mSetObj, current.mset, scores.vec, rank.vec, num_perm)
+
+ res.mat <- matrix(0, nrow=length(fgseaRes$pathway), ncol=5)
+
+ path.size <- unlist(lapply(current.mset, length))
+ matched.size <- path.size[match(fgseaRes$pathway, names(path.size))]
+
+ # create result table
+ res.mat[,1] <- matched.size
+ res.mat[,2] <- fgseaRes$size
+ res.mat[,3] <- fgseaRes$pval
+ res.mat[,4] <- fgseaRes$padj
+ res.mat[,5] <- fgseaRes$NES
+
+ rownames(res.mat) <- fgseaRes$pathway
+ colnames(res.mat) <- c("Pathway_Total", "Hits", "P_val", "P_adj", "NES")
+
+ # order by p-values
+ ord.inx <- order(res.mat[,3]);
+ res.mat <- signif(as.matrix(res.mat[ord.inx, ]), 4);
+
+ mSetObj$mummi.gsea.resmat <- res.mat;
+
+ Cpd.Hits <- qs::qread("pathwaysFiltered.qs")
+ Cpd.Hits <- unlist(lapply(seq_along(Cpd.Hits), function(i) paste(names(Cpd.Hits[[i]]), collapse = ";")))
+ Cpd.Hits <- Cpd.Hits[Cpd.Hits != ""]
+
+ res.mat <- cbind(res.mat, Cpd.Hits[ord.inx])
+ fast.write.csv(res.mat, file="mummichog_fgsea_pathway_enrichment.csv", row.names=TRUE);
+
+ matched_cpds <- names(mSetObj$cpd_exp)
+ inx2<-na.omit(match(rownames(res.mat), mSetObj$pathways$name))
+ filt_cpds <- lapply(inx2, function(f) { mSetObj$pathways$cpds[f] })
+
+ cpds <- lapply(filt_cpds, function(x) intersect(unlist(x), matched_cpds))
+ mSetObj$path.nms <- rownames(res.mat)
+ mSetObj$path.hits<- convert2JsonList(cpds)
+ mSetObj$path.pval <- as.numeric(res.mat[,3])
+ json.res <- list(cmpd.exp = total_cpds,
+ path.nms = rownames(res.mat),
+ hits.all = convert2JsonList(cpds),
+ hits.all.size = as.numeric(res.mat[,2]),
+ nes = fgseaRes$NES,
+ fisher.p = as.numeric(res.mat[,3]))
+
+ json.mat <- RJSONIO::toJSON(json.res, .na='null');
+ sink(mSetObj$mum_nm);
+ cat(json.mat);
+ sink();
+
+ return(mSetObj);
+}
+
+#' Internal function for calculating GSEA, with RT
+.compute.mummichog.RT.fgsea <- function(mSetObj, permNum){
+
+ # Need to perform in EC space
+ num_perm <- permNum;
+ total_ecpds <- mSetObj$ec_exp #scores from all matched compounds
+
+ current.mset <- mSetObj$pathways$emp_cpds; #all compounds per pathway
+ names(current.mset) <- mSetObj$pathways$name
+ path.size <- unlist(lapply(mSetObj$pathways$ecpds, length)) #total size of pathways
+
+ df.scores <- data.frame(id=names(total_ecpds), scores=total_ecpds)
+ ag.scores <- aggregate(id ~ scores, data = df.scores, paste, collapse = "; ")
+
+ ag.sorted <- ag.scores[order(-ag.scores$scores),]
+ row.names(ag.sorted) <- NULL
+
+ dt.scores <- data.table::data.table(ag.sorted)
+ dt.scores.out <- dt.scores[, list(scores=scores, id = unlist(strsplit(id, "; ", fixed = TRUE))), by=1:nrow(dt.scores)]
+
+ rank.vec <- as.numeric(dt.scores.out$nrow)
+ names(rank.vec) <- as.character(dt.scores.out$id)
+
+ scores.vec <- as.numeric(ag.sorted$scores)
+ names(scores.vec) <- as.character(ag.sorted$id)
+
+ # run fgsea
+ if(mumDataContainsPval == 0){
+ rank.vec = seq.int(1, length(mSetObj$ec_exp))
+ names(rank.vec) <- names(mSetObj$ec_exp)
+ scores.vec = seq.int(1, length(mSetObj$ec_exp))
+ names(scores.vec) <- names(mSetObj$ec_exp)
+ }
+
+ fgseaRes <- fgsea2(mSetObj, current.mset, scores.vec, rank.vec, num_perm)
+
+ res.mat <- matrix(0, nrow=length(fgseaRes$pathway), ncol=5)
+
+ path.size <- unlist(lapply(current.mset, length))
+ matched.size <- path.size[match(fgseaRes$pathway, names(path.size))]
+
+ # create result table
+ res.mat[,1] <- matched.size
+ res.mat[,2] <- fgseaRes$size
+ res.mat[,3] <- fgseaRes$pval
+ res.mat[,4] <- fgseaRes$padj
+ res.mat[,5] <- fgseaRes$NES
+
+ rownames(res.mat) <- fgseaRes$pathway
+ colnames(res.mat) <- c("Pathway_Total", "Hits", "P_val", "P_adj", "NES")
+
+ # order by p-values
+ ord.inx <- order(res.mat[,3]);
+ res.mat <- signif(as.matrix(res.mat[ord.inx, ]), 4);
+
+ mSetObj$mummi.gsea.resmat <- res.mat;
+
+ EC.Hits <- qs::qread("pathwaysFiltered.qs")
+ EC.Hits <- lapply(seq_along(EC.Hits), function(i) paste(names(EC.Hits[[i]]), collapse = ";"))
+ res.mat <- cbind(res.mat, EC.Hits)
+ fast.write.csv(res.mat, file="mummichog_fgsea_pathway_enrichment.csv", row.names=TRUE);
+
+ # need to convert ECs to compounds for json
+ total_ecpds <- unique(mSetObj$total_matched_ecpds) #all matched compounds
+ current.mset <- current.mset[match(rownames(res.mat), mSetObj$pathways$name)]
+ ecpds <- lapply(current.mset, function(x) intersect(x, total_ecpds)); #pathways & all ref ecpds
+ cpds <- lapply(ecpds, function(x) unique(unlist(mSetObj$ecpd_cpd_dict[match(x, names(mSetObj$ecpd_cpd_dict))])) )
+
+ # now make exp vec for all compounds
+ cpds2ec <- mSetObj$cpd_ecpd_dict
+ cpds.all <- unique(unlist(mSetObj$ecpd_cpd_dict[match(total_ecpds, names(mSetObj$ecpd_cpd_dict))]))
+ cpds.exp <- sapply(cpds.all, function(x) sapply(seq_along(x), function(i) mean(mSetObj$ec_exp[match(unique(unlist(cpds2ec[match(x[[i]], names(cpds2ec))])), names(mSetObj$ec_exp))]) ) )
+
+ mSetObj$path.nms <- rownames(res.mat)
+ mSetObj$path.hits <- convert2JsonList(cpds)
+ mSetObj$path.pval <- as.numeric(res.mat[,3])
+
+ json.res <- list(cmpd.exp = cpds.exp,
+ path.nms = rownames(res.mat),
+ hits.all = convert2JsonList(cpds),
+ hits.all.size = as.numeric(res.mat[,2]),
+ nes = fgseaRes$NES,
+ fisher.p = as.numeric(res.mat[,3]))
+
+ json.mat <- RJSONIO::toJSON(json.res, .na='null');
+ sink(mSetObj$mum_nm);
+ cat(json.mat);
+ sink();
+
+ return(mSetObj);
+}
+
+#####################################################################
+
+#'Map currency metabolites to KEGG & BioCyc
+#'@description This function maps the user selected list
+#'of compounds to its corresponding KEGG IDs and BioCyc IDs
+#'@param mSetObj Input the name of the created mSetObj object
+#'@author Jasmine Chong, Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+PerformCurrencyMapping <- function(mSetObj = NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ qvec <- mSetObj$dataSet$cmpd;
+ curr_db <- .get.my.lib("currency_cmpd.qs");
+ hit.inx <- match(tolower(qvec), tolower(curr_db$DisplayName));
+
+ num_hits <- length(na.omit(hit.inx))
+
+ if(num_hits == 0){
+ mSetObj$mummi$curr.msg <- c("No currency metabolites were selected or mapped!")
+ print(mSetObj$mummi$curr.msg)
+ return(0)
+ }
+
+ match.values <- curr_db[hit.inx,];
+ curr.met <- nrow(match.values)
+
+ mSetObj$curr.map <- match.values
+
+ if(curr.met > 0){
+ mSetObj$mummi$curr.msg <- paste("A total of ", curr.met ," currency metabolites were successfully uploaded!", sep = "")
+ }
+
+ mSetObj$curr.cust <- TRUE;
+ return(.set.mSet(mSetObj));
+}
+
+#'Read Adduct List
+#'@description This function reads in the user's adduct list and
+#'saves it as a matrix.
+#'@usage Read.AdductData(mSetObj=NA, adductList)
+#'@param mSetObj Input the name of the created mSetObj object
+#'@param adductList Input the name of the adduct list
+#'@author Jasmine Chong, Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+PerformAdductMapping <- function(mSetObj=NA, add.mode){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ adducts <- mSetObj$dataSet$adduct.list
+
+ if(add.mode == "positive"){
+ add_db <- .get.my.lib("pos_adduct.qs");
+ }else if(add.mode == "negative"){
+ add_db <- .get.my.lib("neg_adduct.qs");
+ }else if(add.mode == "mixed"){
+ add_db <- .get.my.lib("mixed_adduct.qs");
+ }else{
+ msg <- c("Adduct mode is not valid")
+ }
+
+ hit.inx <- match(tolower(adducts), tolower(add_db$Ion_Name));
+ hits <- length(na.omit(hit.inx))
+
+ if(hits == 0){
+ mSetObj$mummi$add.msg <- c("No adducts were selected!")
+ return(0)
+ }
+
+ match.values <- add_db[na.omit(hit.inx),];
+ sel.add <- nrow(match.values)
+
+ if(sel.add > 0){
+ mSetObj$mummi$add.msg <- paste("A total of ", sel.add ," adducts were successfully selected!", sep = "")
+ }
+
+ mSetObj$adduct.custom <- TRUE
+ mSetObj$add.map <- match.values
+
+ return(.set.mSet(mSetObj));
+}
+
+# internal function to create new mz matrix from user-curated list of adducts
+new_adduct_mzlist <- function(mSetObj=NA, mw){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ mode <- mSetObj$dataSet$mode
+
+ ion.name <- mSetObj$add.map$Ion_Name
+ ion.mass <- mSetObj$add.map$Ion_Mass
+
+ mw_modified <- NULL;
+
+ if(mode!="mixed"){ #pos or neg
+
+ mass.list <- as.list(ion.mass)
+ mass.user <- lapply(mass.list, function(x) eval(parse(text=paste(gsub("PROTON", 1.00727646677, x)))) )
+ mw_modified <- cbind(mw, do.call(cbind, mass.user));
+
+ if(mode == "positive"){
+ mw_modified.pos <- mw_modified[,-1, drop = FALSE]
+ mw_modified.neg <- as.matrix(mw_modified[,1, drop = FALSE])
+ colnames(mw_modified.pos) <- ion.name;
+ colnames(mw_modified.neg) <- "M"
+ }else{ #negative
+ mw_modified.neg <- mw_modified[,-1, drop = FALSE]
+ mw_modified.pos <- as.matrix(mw_modified[,1, drop = FALSE])
+ colnames(mw_modified.neg) <- ion.name;
+ colnames(mw_modified.pos) <- "M"
+ }
+
+ mw_modified <- list(mw_modified.neg, mw_modified.pos)
+ names(mw_modified) <- c("neg", "pos")
+
+ }else{
+ #deal w. mixed ion mode, need to return pos and neg
+
+ neg.ions <- c("M-H [1-]", "M-2H [2-]", "M-3H [3-]", "M-H2O-H [1-]", "M-H+O [1-]", "M+K-2H [1-]", "M+Na-2H [1- ]", "M+Cl [1-]", "M+Cl37 [1-]",
+ "M+K-2H [1-]", "M+FA-H [1-]", "M+Hac-H [1-]", "M+Br [1-]", "M+Br81 [1-]", "M+TFA-H [1-]", "M+ACN-H [1-]", "M+HCOO [1-]", "M+CH3COO [1-]",
+ "2M-H [1-]", "2M+FA-H [1-]", "2M+Hac-H [1-]", "3M-H [1-]", "M(C13)-H [1-]", "M(S34)-H [1-]", "M(Cl37)-H [1-]")
+
+ ion.name.neg <- intersect(ion.name, neg.ions)
+ ion.mass.neg <- ion.mass[which(ion.name %in% neg.ions)]
+
+ ion.name.pos <- setdiff(ion.name, neg.ions)
+ ion.mass.pos <- ion.mass[which(ion.name %in% ion.name.pos)]
+
+ mass.list.neg <- as.list(ion.mass.neg)
+ mass.user.neg <- lapply(mass.list.neg, function(x) eval(parse(text=paste(gsub("PROTON", 1.00727646677, x)))) )
+ mw_modified.neg <- do.call(cbind, mass.user.neg);
+ colnames(mw_modified.neg) <- ion.name.neg;
+
+ mass.list.pos <- as.list(ion.mass.pos)
+ mass.user.pos <- lapply(mass.list.pos, function(x) eval(parse(text=paste(gsub("PROTON", 1.00727646677, x)))) )
+ mw_modified.pos <- do.call(cbind, mass.user.pos);
+ colnames(mw_modified.pos) <- ion.name.pos;
+
+ mw_modified <- list(mw_modified.neg, mw_modified.pos)
+ names(mw_modified) <- c("neg", "pos")
+ }
+ return(mw_modified);
+}
+
+#'Update the mSetObj with user-selected parameters for MS Peaks to Pathways.
+#'@description This functions handles updating the mSet object for mummichog analysis.
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects).
+#'@param force_primary_ion Character, if "yes", only mz features that match compounds with a primary ion are kept.
+#'@param rt_tol Numeric. Input the retention time tolerance used for determining ECs (in seconds).
+#'@author Jasmine Chong, Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+UpdateEC_Rules <- function(mSetObj = NA, force_primary_ion, rt_tol){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ mSetObj$dataSet$primary_ion <- force_primary_ion;
+
+ ok <- is.numeric(rt_tol)
+
+ if(ok){
+ mSetObj$dataSet$rt_tol <- rt_tol;
+ }else{
+ AddErrMsg("Retention time tolerance must be numeric!")
+ return(0)
+ }
+
+ msg.vec <- "EC Rules successfully updated."
+ mSetObj$mummi$ec.msg <- msg.vec
+
+ return(.set.mSet(mSetObj));
+}
+
+##############################
+##### Plotting Functions #####
+##############################
+
+#'Plot MS Peaks to Paths mummichog permutation p-values
+#'@description Plots the mummichog permutation p-values
+#'@param mSetObj Input name of the created mSet Object
+#'@param pathway Input the name of the pathway
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+PlotMSPeaksPerm <- function(mSetObj=NA, pathway, imgName, format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ bw.vec <- unlist(mSetObj$perm_record);
+
+ len <- length(bw.vec);
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+
+ if(is.na(width)){
+ w <- 8;
+ }else if(width == 0){
+ w <- 7;
+ }else{
+ w <- width;
+ }
+ h <- w*6/8;
+
+ mSetObj$imgSet$mspeaks.permut <- imgName;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ par(mar=c(5,5,2,4));
+ hst <- hist(bw.vec, breaks = "FD", freq=T,
+ ylab="Frequency", xlab= 'Permutation test statistics', col="lightblue", main="");
+
+ # add the indicator using original label
+ h <- max(hst$counts)
+ inx <- which(rownames(mSetObj$mummi.resmat) == pathway)
+ raw.p <- mSetObj$mummi.resmat[inx,5]
+ arrows(raw.p, h/5, raw.p, 0, col="red", lwd=2);
+ text(raw.p, h/3.5, paste('Raw \n statistic \n', raw.p), xpd=T);
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+#' PlotPeaks2Paths
+#' @description Plots either the original mummichog or GSEA results.
+#' @param mSetObj Input the name of the created mSetObj object
+#' @param imgName Input a name for the plot
+#' @param format Character, input the format of the image to create.
+#' @param dpi Numeric, input the dpi of the image to create.
+#' @param width Numeric, input the width of the image to create.
+#' @param Labels Character, indicate if the plot should be labeled. By default
+#' it is set to "default", and the 5 top-ranked pathways per each algorithm will be plotted.
+#' Users can adjust the number of pathways to be annotated per pathway using the "num_annot"
+#' parameter.
+#' @author Jasmine Chong, Jeff Xia \email{jeff.xia@mcgill.ca}
+#' McGill University, Canada
+#' License: GNU GPL (>= 2)
+#' @export
+
+PlotPeaks2Paths <- function(mSetObj=NA, imgName, format = "png", dpi = 72, width = 9, labels = "default",
+ num_annot = 5){
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(anal.type == "mummichog"){
+ mummi.mat <- mSetObj$mummi.resmat
+ y <- -log10(mummi.mat[,5]);
+ x <- mummi.mat[,3]/mummi.mat[,4]
+ pathnames <- rownames(mummi.mat)
+ }else{
+ gsea.mat <- mSetObj$mummi.gsea.resmat
+ y <- -log10(gsea.mat[,3])
+ x <- gsea.mat[,2]/gsea.mat[,1]
+ pathnames <- rownames(gsea.mat)
+ }
+
+ inx <- order(y, decreasing= T);
+
+ y <- y[inx];
+ x <- x[inx];
+ path.nms <- pathnames[inx];
+
+ # set circle size based on enrichment factor
+ sqx <- sqrt(x);
+ min.x <- min(sqx, na.rm = TRUE);
+ max.x <- max(sqx, na.rm = TRUE);
+
+ if(min.x == max.x){ # only 1 value
+ max.x = 1.5*max.x;
+ min.x = 0.5*min.x;
+ }
+
+ maxR <- (max.x - min.x)/40;
+ minR <- (max.x - min.x)/160;
+ radi.vec <- minR+(maxR-minR)*(sqx-min.x)/(max.x-min.x);
+
+ # set background color according to combo.p
+ bg.vec <- heat.colors(length(y));
+
+ if(format == "png"){
+ bg = "transparent";
+ }else{
+ bg="white";
+ }
+
+ if(is.na(width)){
+ w <- 7;
+ }else if(width == 0){
+ w <- 7;
+ }else{
+ w <- width;
+ }
+ h <- w;
+
+ df <- data.frame(path.nms, x, y)
+
+ if(labels == "default"){
+ pk.inx <- GetTopInx(df$y, num_annot, T)
+ }
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ mSetObj$imgSet$mummi.plot <- imgName
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg=bg);
+ op <- par(mar=c(6,5,2,3));
+ plot(x, y, type="n", axes=F, xlab="Enrichment Factor", ylab="-log10(p)", bty = "l");
+ axis(1);
+ axis(2);
+ symbols(x, y, add = TRUE, inches = F, circles = radi.vec, bg = bg.vec, xpd=T);
+
+ if(labels=="default"){
+ text(x[pk.inx], y[pk.inx], labels = path.nms[pk.inx], pos=3, xpd=T, cex=0.8)
+ }else if(labels == "all"){
+ text(x, y, labels = path.nms, pos=3, xpd=T, cex=0.8)
+ }
+
+ par(op);
+ dev.off();
+ if(anal.type == "mummichog"){
+ df <- list(pval=unname(y), enr=unname(x), pathnames=path.nms);
+ sink("scattermum.json");
+ cat(RJSONIO::toJSON(df));
+ sink();
+ }else{
+ df <- list(pval=unname(y), enr=unname(gsea.mat[,5]), pathnames=path.nms);
+ sink("scattergsea.json");
+ cat(RJSONIO::toJSON(df));
+ sink();
+ }
+
+ return(.set.mSet(mSetObj));
+
+}
+
+#' PlotIntegPaths
+#' @description Plots both the original mummichog and the GSEA results by combining p-values
+#' using the Fisher's method (sumlog).
+#' @param mSetObj Input the name of the created mSetObj object
+#' @param imgName Input a name for the plot
+#' @param format Character, input the format of the image to create.
+#' @param dpi Numeric, input the dpi of the image to create.
+#' @param width Numeric, input the width of the image to create.
+#' @param Labels Character, indicate if the plot should be labeled. By default
+#' it is set to "default", and the 5 top-ranked pathways per each algorithm will be plotted.
+#' Users can adjust the number of pathways to be annotated per pathway using the "labels.x"
+#' and "labels.y" parameters.
+#' Users can set this to "none" for no annotations, or "all" to annotate all pathways.
+#' @param labels.x Numeric, indicate the number of top-ranked pathways using the fGSEA algorithm
+#' to annotate on the plot.
+#' @param labels.y Numeric, indicate the number of top-ranked pathways using the original
+#' mummichog algorithm to annotate on the plot.
+#' @author Jasmine Chong, Jeff Xia \email{jeff.xia@mcgill.ca}
+#' McGill University, Canada
+#' License: GNU GPL (>= 2)
+#' @export
+#' @import metap
+#' @import scales
+
+PlotIntegPaths <- function(mSetObj=NA, imgName, format = "png", dpi = 72, width = 9, labels = "default",
+ labels.x = 5, labels.y = 5, scale.axis = TRUE){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # check if mummichog + gsea was performed
+ if(is.null(mSetObj$mummi.resmat) | is.null(mSetObj$mummi.gsea.resmat)){
+ print("Both mummichog and fGSEA must be performed!")
+ return(0)
+ }
+
+ combo.resmat <- mSetObj$integ.resmat
+ pathnames <- rownames(combo.resmat)
+ # Sort values based on combined pvalues
+ y <- -log10(combo.resmat[,4]);
+ x <- -log10(combo.resmat[,5]);
+ combo.p <- -log10(combo.resmat[,6])
+
+ if(scale.axis){
+ y <- scales::rescale(y, c(0,4))
+ x <- scales::rescale(x, c(0,4))
+ combo.p <- scales::rescale(combo.p, c(0,4))
+ }
+
+ inx <- order(combo.p, decreasing= T);
+
+ combo.p <- combo.p[inx]
+ x <- x[inx];
+ y <- y[inx];
+ path.nms <- pathnames[inx];
+
+ # set circle size based on combined pvalues
+ min.x <- min(combo.p, na.rm = TRUE);
+ max.x <- max(combo.p, na.rm = TRUE);
+
+ if(min.x == max.x){ # only 1 value
+ max.x = 1.5*max.x;
+ min.x = 0.5*min.x;
+ }
+
+ maxR <- (max.x - min.x)/40;
+ minR <- (max.x - min.x)/160;
+ radi.vec <- minR+(maxR-minR)*(combo.p-min.x)/(max.x-min.x);
+
+ # set background color according to combo.p
+ bg.vec <- heat.colors(length(combo.p));
+
+ if(format == "png"){
+ bg = "transparent";
+ }else{
+ bg="white";
+ }
+
+ if(is.na(width)){
+ w <- 7;
+ }else if(width == 0){
+ w <- 7;
+ }else{
+ w <- width;
+ }
+ h <- w;
+
+ df <- data.frame(path.nms, x, y)
+
+ if(labels == "default"){
+ mummi.inx <- GetTopInx(df$y, labels.y, T)
+ gsea.inx <- GetTopInx(df$x, labels.x, T)
+ all.inx <- mummi.inx | gsea.inx;
+ }
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ mSetObj$imgSet$integpks.plot <- imgName
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg=bg);
+ op <- par(mar=c(6,5,2,3));
+
+ # color blocks only make sense if scaled...
+ if(scale.axis){
+ plot(x, y, type="n", axes=F, xlab="GSEA -log10(p)", ylab="Mummichog -log10(p)", bty = "l");
+ axis(1);
+ axis(2);
+ symbols(x, y, add = TRUE, inches = F, circles = radi.vec, bg = bg.vec, xpd=T);
+
+ axis.lims <- par("usr")
+
+ # mummichog sig
+ mum.x <- c(axis.lims[1], axis.lims[1], axis.lims[2], axis.lims[2])
+ mum.y <- c(2, axis.lims[4], axis.lims[4], 2)
+ polygon(mum.x, mum.y, col=rgb(82/255,193/255,188/255,0.3), border = NA)
+
+ # gsea sig
+ gsea.x <- c(2,2,axis.lims[4],axis.lims[4])
+ gsea.y <- c(axis.lims[1],axis.lims[4],axis.lims[4],axis.lims[1])
+ polygon(gsea.x, gsea.y, col=rgb(216/255,126/255,178/255,0.3), border = NA)
+ }else{
+ plot(x, y, type="n", xlim=c( 0, round(max(x)) ), ylim=c(0, round(max(y)) ), xlab="GSEA -log10(p)", ylab="Mummichog -log10(p)", bty = "l");
+ symbols(x, y, add = TRUE, inches = F, circles = radi.vec, bg = bg.vec, xpd=T);
+ }
+
+ if(labels=="default"){
+ text(x[all.inx], y[all.inx], labels = path.nms[all.inx], pos=3, xpd=T, cex=0.8)
+ }else if(labels == "all"){
+ text(x, y, labels = path.nms, pos=3, xpd=T, cex=0.8)
+ }
+
+ par(op);
+ dev.off();
+
+ df <- list(pval=unname(y), enr=unname(x), metap= unname(combo.p), pathnames=pathnames);
+ sink("scatterinteg.json");
+ cat(RJSONIO::toJSON(df));
+ sink();
+
+ return(.set.mSet(mSetObj));
+}
+
+#' Plot m/z hits in a pathway
+#' @description Function to create a boxplot of m/z features
+#' within a specific pathway. m/z features used by the original
+#' mummichog algorithm are highlighted with an asterisk.
+#' @param mSetObj Input the name of the created mSetObj object.
+#' @param msetNM Character, input the name of the pathway.
+#' @param format Character, input the format of the image to create.
+#' @param dpi Numeric, input the dpi of the image to create. Default
+#' is set to 300.
+#' @param width Numeric, input the width of the image to create.
+#' Default is set to 10.
+#' @author Jasmine Chong, Jeff Xia \email{jeff.xia@mcgill.ca}
+#' McGill University, Canada
+#' License: GNU GPL (>= 2)
+#' @export
+#' @import ggplot2
+#' @import reshape2
+#' @import scales
+
+PlotPathwayMZHits <- function(mSetObj=NA, msetNM, format="png", dpi=300, width=10){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ inx <- which(mSetObj$pathways$name == msetNM)
+
+ # Brief sanity check
+ if(length(inx) == 0){
+ print(paste0(msetNM, " is not found in the pathway library! Please verify the spelling."))
+ AddErrMsg("Invalid pathway selected!")
+ return(0)
+ }
+
+ if(mum.version=="v2" & mSetObj$dataSet$mumRT){
+ mset <- mSetObj$pathways$emp_cpds[[inx]];
+ mzs <- as.numeric(unique(unlist(mSetObj$ec2mz_dict[mset])))
+ }else{
+ mset <- mSetObj$pathways$cpds[[inx]];
+ mzs <- as.numeric(unique(unlist(mSetObj$cpd2mz_dict[mset])))
+ }
+
+ if(anal.type == "integ_peaks"){
+ # check if mummichog + gsea was performed
+ if(is.null(mSetObj$mummi.resmat) | is.null(mSetObj$mummi.gsea.resmat)){
+ AddErrMsg("Both mummichog and fGSEA must be performed!")
+ return(0)
+ }
+ }
+
+ pvals <- mSetObj$dataSet$mummi.proc[mSetObj$dataSet$mummi.proc[, 2] %in% mzs, ]
+
+ pval.cutoff <- mSetObj$dataSet$cutoff
+
+ if(anal.type %in% c("integ_peaks", "mummichog")){
+ used.inx <- pvals[,1] < pval.cutoff
+ mummi <- which(used.inx)
+ mummi_mzs <- pvals[,2]
+
+ # add astericks if used by mummichog
+ mummi_mzs_star <- mummi_mzs
+ mummi_mzs_star[mummi] <- paste(mummi_mzs_star[mummi], "*",sep="");
+ }else{
+ mummi_mzs_star <- pvals[,2]
+ }
+
+ # create boxdata
+ data <- data.frame(mSetObj$dataSet$proc)
+
+ boxdata <- data[,as.character(mummi_mzs)]
+ colnames(boxdata) <- mummi_mzs_star
+ boxdata$class <- mSetObj$dataSet$cls
+
+ num.feats <- length(result)
+
+ boxdata.m <- reshape2::melt(boxdata, id.vars="class")
+ boxdata.m$value <- scales::rescale(boxdata.m$value, c(0,1))
+
+ boxplotName <- paste(msetNM, ".", format, sep="");
+
+ if(num.feats == 1){
+
+ w = width
+ h = width
+ p <- ggplot(data = boxdata.m, aes(x=variable, y=value)) + geom_boxplot(aes(fill=class), outlier.shape = NA, outlier.colour=NA)
+ p <- p + ggtitle(msetNM) + theme(plot.title = element_text(hjust = 0.5)) + guides(fill=guide_legend(title="Group"))
+ p <- p + xlab("m/z feature") + ylab("Intensity")
+
+ ggsave(p, filename = boxplotName, dpi=300, width=w, height=h, limitsize = FALSE)
+
+ return(mSetObj)
+
+ }else if(num.feats<10){
+ w = width
+ h <- num.feats
+ cols = 3
+ }else if(num.feats<5){
+ w = width
+ h = width
+ }else{
+ w = width
+ h <- num.feats * 0.35
+ cols = 6
+ }
+
+ p <- ggplot(data = boxdata.m, aes(x=variable, y=value)) + geom_boxplot(aes(fill=class), outlier.shape = NA, outlier.colour=NA)
+ p <- p + facet_wrap( ~ variable, scales="free", ncol=cols) + xlab("m/z features") + ylab("Intensity")
+ p <- p + ggtitle(msetNM) + theme(plot.title = element_text(hjust = 0.5)) + guides(fill=guide_legend(title="Group"))
+
+ ggsave(p, filename = boxplotName, dpi=300, width=w, height=h, limitsize = FALSE)
+
+ return(.set.mSet(mSetObj));
+}
+
+###############################
+######## For R Package ########
+###############################
+
+#' Function to get compound details from a specified pathway
+#' @description Function to get compound details from a specified pathway.
+#' The results will be both printed in the console as well as saved
+#' as a csv file. Note that performing this function multiple times will
+#' overwrite previous queries. Significant compounds will be indicated with an asterisk.
+#' @param mSetObj Input the name of the created mSetObj object.
+#' @param msetNm Input the name of the pathway
+#' @export
+GetMummichogPathSetDetails <- function(mSetObj=NA, msetNm){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(!is.null(mSetObj$api$lib)){
+
+ # get file from api.metaboanalyst.ca
+ toSend = list(pathName = msetNm)
+
+ load_httr()
+ base <- api.base
+ endpoint <- paste0("/pathsetdetails/", mSetObj$api$guestName)
+ call <- paste(base, endpoint, sep="")
+ query_results <- httr::POST(call, body = toSend, encode= "json")
+
+ if(query_results$status_code == 200){
+ filename <- httr::content(query_results, "text")
+ }
+
+ endpointfile <- paste0("/getFile", "/", mSetObj$api$guestName, "/", filename)
+ callfile <- paste(base, endpointfile, sep="")
+ download.file(callfile, destfile = basename(filename))
+ print(paste0(filename, " saved to current working directory!"))
+ return(.set.mSet(mSetObj));
+ }
+
+ version <- mum.version
+ inx <- which(mSetObj$pathways$name == msetNm)
+
+ if(is.na(inx)){
+ AddErrMsg("Invalid pathway name!")
+ return(0)
+ }
+
+ if(version=="v2" & mSetObj$dataSet$mumRT){
+ mset <- mSetObj$pathways$emp_cpds[[inx]];
+ mset_cpds <- mSetObj$pathways$cpds[[inx]];
+
+ hits.all <- unique(mSetObj$total_matched_ecpds)
+ hits.sig <- mSetObj$input_ecpdlist;
+
+ refs <- mset %in% hits.all;
+ sigs <- mset %in% hits.sig;
+
+ ref.ecpds <- mset[which(refs & !sigs)]
+ sig.ecpds <- mset[sigs]
+
+ ref.mzs <- lapply(ref.ecpds, function(x) paste(as.numeric(unique(unlist(mSetObj$ec2mz_dict[x]))), collapse = "; "))
+ sig.mzs <- lapply(sig.ecpds, function(x) paste(as.numeric(unique(unlist(mSetObj$ec2mz_dict[x]))), collapse = "; "))
+
+ ref.cpds <- lapply(ref.ecpds, function(x) paste(unique(unlist(mSetObj$ecpd_cpd_dict[x])), collapse = "; "))
+ sig.cpds <- lapply(sig.ecpds, function(x) paste(unique(unlist(mSetObj$ecpd_cpd_dict[x])), collapse = "; "))
+
+ path.results <- matrix(c(unlist(sig.mzs), unlist(ref.mzs), unlist(sig.cpds), unlist(ref.cpds)), ncol=2)
+ colnames(path.results) <- c("mzs", "cpds")
+ rownames(path.results) <- c(paste0(sig.ecpds, "*"), ref.ecpds)
+
+ name <- paste0(gsub(" ", "_", msetNm), "_ecpd_mz_info.csv")
+ fast.write.csv(path.results, name)
+ }else{
+ mset <- mSetObj$pathways$cpds[[inx]];
+
+ hits.all <- unique(mSetObj$total_matched_cpds)
+ hits.sig <- mSetObj$input_cpdlist;
+
+ refs <- mset %in% hits.all;
+ sigs <- mset %in% hits.sig;
+
+ ref.cpds <- mset[which(refs & !sigs)]
+ sig.cpds <- mset[sigs]
+
+ ref.mzs <- lapply(ref.cpds, function(x) paste(as.numeric(unique(unlist(mSetObj$cpd2mz_dict[x]))), collapse = "; "))
+ sig.mzs <- lapply(sig.cpds, function(x) paste(as.numeric(unique(unlist(mSetObj$cpd2mz_dict[x]))), collapse = "; "))
+
+ path.results <- matrix(c(unlist(sig.mzs), unlist(ref.mzs)), ncol=1)
+ colnames(path.results) <- "mzs"
+ rownames(path.results) <- c(paste0(sig.cpds, "*"), ref.cpds)
+
+ name <- paste0(gsub(" ", "_", msetNm), "_cpd_mz_info.csv")
+ fast.write.csv(path.results, name)
+ }
+
+ return(.set.mSet(mSetObj));
+}
+
+#' Function to get adduct details from a specified compound
+#' @description Function to get adduct details from a specified compound.
+#' The results will be both printed in the console as well as saved
+#' as a csv file. Note that performing this function multiple times will
+#' overwrite previous queries.
+#' @param mSetObj Input the name of the created mSetObj object.
+#' @param cmpd.id Input the name of the selected compound.
+#'@import qs
+#' @export
+GetCompoundDetails <- function(mSetObj=NA, cmpd.id){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(!is.null(mSetObj$api$lib)){
+
+ # get file from api.metaboanalyst.ca
+ toSend = list(cmpdId = cmpd.id)
+
+ load_httr()
+ base <- api.base
+ endpoint <- paste0("/compounddetails/", mSetObj$api$guestName)
+ call <- paste(base, endpoint, sep="")
+ query_results <- httr::POST(call, body = toSend, encode= "json")
+
+ if(query_results$status_code == 200){
+ filename <- httr::content(query_results, "text")
+ }
+
+ endpointfile <- paste0("/getFile", "/", mSetObj$api$guestName, "/", filename)
+ callfile <- paste(base, endpointfile, sep="")
+ download.file(callfile, destfile = basename(filename))
+ print(paste0(filename, " saved to current working directory!"))
+ return(.set.mSet(mSetObj));
+ }
+
+ forms <- mSetObj$cpd_form_dict[[cmpd.id]];
+
+ if(is.null(forms)){
+ print("This compound is not valid!")
+ return(0)
+ }
+
+ matched_res <- qs::qread("mum_res.qs");
+ mz <- matched_res[which(matched_res$Matched.Compound == cmpd.id), 1]
+ mass.diff <- matched_res[which(matched_res$Matched.Compound == cmpd.id), 4]
+ tscores <- mSetObj$cpd_exp_dict[[cmpd.id]];
+
+ res <- cbind(rep(cmpd.id, length(mz)), mz, forms, mass.diff, tscores)
+ colnames(res) <- c("Matched.Compound", "m.z", "Matched.Form", "Mass.Diff", "T.Scores")
+ fast.write.csv(res, "mummichog_compound_details.csv")
+ return(.set.mSet(mSetObj));
+}
+
+# Function to return the unique m/zs from the selected pathways
+# based on the compounds
+
+GetMummichogMZHits <- function(mSetObj=NA, msetNm){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(!is.null(mSetObj$api$lib)){
+
+ # get file from api.metaboanalyst.ca
+ toSend = list(pathName = msetNm)
+
+ load_httr()
+ base <- api.base
+ endpoint <- paste0("/mzhits/", mSetObj$api$guestName)
+ call <- paste(base, endpoint, sep="")
+ query_results <- httr::POST(call, body = toSend, encode= "json")
+
+ if(query_results$status_code == 200){
+ result <- httr::content(query_results, "text")
+ }
+ mSetObj$mz.hits <- result
+ print(paste0("Unique m/z features in ", msetNm, ": ", result))
+ return(.set.mSet(mSetObj));
+ }
+
+ inx <- which(mSetObj$pathways$name == msetNm)
+ mset <- mSetObj$pathways$cpds[[inx]];
+ mzs <- as.numeric(unique(unlist(mSetObj$cpd2mz_dict[mset])))
+ result <- intersect(mzs, mSetObj$dataSet$input_mzlist)
+ mSetObj$mz.hits <- result
+
+ return(.set.mSet(mSetObj));
+}
+
+###############################
+####### Getters For Web #######
+###############################
+
+GetMatchingDetails <- function(mSetObj=NA, cmpd.id){
+
+ mSetObj <- .get.mSet(mSetObj);
+ forms <- mSetObj$cpd_form_dict[[cmpd.id]];
+ tscores <- mSetObj$cpd_exp_dict[[cmpd.id]];
+ # create html table
+ res <- paste("<li>", "<b>", forms, "</b>: ", tscores, "</li>",sep="", collapse="");
+ return(res);
+}
+
+GetMummichogHTMLPathSet <- function(mSetObj=NA, msetNm){
+
+ mSetObj <- .get.mSet(mSetObj);
+ inx <- which(mSetObj$pathways$name == msetNm)
+
+ mset <- mSetObj$pathways$cpds[[inx]];
+
+ # all matched compounds
+ if(mum.version == "v2" & mSetObj$dataSet$mumRT){
+ hits.all <- unique(unlist(mSetObj$ecpd_cpd_dict))
+ }else{
+ hits.all <- unique(mSetObj$total_matched_cpds)
+ }
+
+ if(anal.type == "mummichog"|anal.type == "integ_peaks"){
+
+ # get the sig compounds
+ if(mum.version == "v2" & mSetObj$dataSet$mumRT){
+ hits.sig <- mSetObj$input_ecpdlist;
+ hits.sig.inx <- match(hits.sig, names(mSetObj$ecpd_cpd_dict))
+ hits.sig <- unlist(mSetObj$ecpd_cpd_dict[hits.sig.inx])
+ }else{
+ hits.sig <- mSetObj$input_cpdlist;
+ }
+
+ # highlighting with different colors
+ refs <- mset %in% hits.all;
+ sigs <- mset %in% hits.sig;
+
+ red.inx <- which(sigs);
+ blue.inx <- which(refs & !sigs);
+
+ # use actual cmpd names
+ nms <- mset;
+ nms[red.inx] <- paste("<font color=\"red\">", "<b>", nms[red.inx], "</b>", "</font>",sep="");
+ nms[blue.inx] <- paste("<font color=\"blue\">", "<b>", nms[blue.inx], "</b>", "</font>",sep="");
+ }else{
+ refs <- mset %in% hits.all;
+ red.inx <- which(refs);
+ nms <- mset;
+ nms[red.inx] <- paste("<font color=\"red\">", "<b>", nms[red.inx], "</b>", "</font>",sep="");
+ }
+
+ # for large number, return only hits (context already enough)
+ if(length(nms) > 200){
+ nms <- nms[refs];
+ }
+ return(cbind(msetNm, paste(unique(nms), collapse="; ")));
+}
+
+GetMummiResMatrix <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ if(anal.type == "mummichog"){
+
+ return(mSetObj$mummi.resmat);
+ }else if(anal.type == "gsea_peaks"){
+ return(mSetObj$mummi.gsea.resmat);
+ }else{
+ return(mSetObj$integ.resmat);
+ }
+}
+
+GetMummiResRowNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ if(anal.type == "mummichog"){
+ return(rownames(mSetObj$mummi.resmat));
+ }else if(anal.type == "gsea_peaks"){
+ return(rownames(mSetObj$mummi.gsea.resmat));
+ }else{
+ return(rownames(mSetObj$integ.resmat));
+ }
+}
+
+GetMummiResColNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(colnames(mSetObj$mummi.resmat));
+}
+
+GetCurrencyMsg <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$mummi$curr.msg)
+}
+
+GetAdductMsg <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$mummi$add.msg)
+}
+
+GetECMsg <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$mummi$ec.msg)
+}
+
+GetDefaultPvalCutoff <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet();
+
+ if(peakFormat %in% c("rmp", "rmt")){
+ maxp <- 0;
+ }else{
+ pvals <- c(0.25, 0.2, 0.15, 0.1, 0.05, 0.01, 0.005, 0.001, 0.0005, 0.0001, 0.00005, 0.00001)
+ ndat <- mSetObj$dataSet$mummi.proc;
+
+ ### Handle something very wrong for mass table
+ if(is.null(ndat)){
+ res <- PerformFastUnivTests(mSetObj$dataSet$norm, mSetObj$dataSet$cls, var.equal=TRUE);
+ ndat <- res[order(res[,2]),];
+ n <- floor(0.1*length(ndat[,2]))
+ cutoff <- ndat[n+1,2]
+ } else {
+ n <- floor(0.1*length(ndat[,"p.value"]))
+ cutoff <- ndat[n+1,1]
+ }
+
+ if(!any(pvals <= cutoff)){
+ maxp <- 0.00001
+ }else{
+ maxp <- max(pvals[pvals <= cutoff])
+ }
+ }
+ return(maxp)
+}
+
+GetDefaultRTTol <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ rt_tol <- mSetObj$dataSet$rt_tol;
+ if(is.na(rt_tol)){
+ rt_tol <- 0
+ }
+ return(rt_tol)
+}
+
+GetMummiMode <- function(mSetObj){
+ mSetObj <- .get.mSet(mSetObj);
+ mode <- mSetObj$dataSet$mode
+ return(mode);
+}
+
+GetMummiDataType <- function(mSetObj){
+ mSetObj <- .get.mSet(mSetObj);
+ type <- mSetObj$dataSet$type
+ return(type)
+}
+
+# Replicate because do not want to have to read in stats_univariate to perform MS Peaks
+GetTopInx <- function(vec, n, dec=T){
+ inx <- order(vec, decreasing = dec)[1:n];
+ # convert to T/F vec
+ vec<-rep(F, length=length(vec));
+ vec[inx] <- T;
+ return (vec);
+}
+
+#########################################
+########### Utility Functions ###########
+#########################################
+
+# Global variables define currency compounds
+currency <- c('C00001', 'C00080', 'C00007', 'C00006', 'C00005', 'C00003',
+ 'C00004', 'C00002', 'C00013', 'C00008', 'C00009', 'C00011',
+ 'G11113', '', 'H2O', 'H+', 'Oxygen', 'NADP+',
+ 'NADPH', 'NAD+', 'NADH', 'ATP',
+ 'Pyrophosphate', 'ADP', 'CO2');
+
+all_currency <- c('C00001', 'C00080', 'C00007', 'C00006', 'C00005', 'C00003',
+ 'C00004', 'C00002', 'C00013', 'C00008', 'C00009', 'C00011',
+ 'G11113', '', 'H2O', 'Water', 'H+', 'Hydron', 'O2', 'Oxygen', 'NADP+',
+ 'NADP', 'NADPH', 'NAD+', 'NAD', 'NADH', 'ATP', 'Diphosphate',
+ 'Pyrophosphate', 'ADP','Orthophosphate', 'CO2', 'Carbon dioxide');
+
+primary_ions <- c('M+H[1+]', 'M+Na[1+]', 'M-H2O+H[1+]', 'M-H[-]', 'M-2H[2-]', 'M-H2O-H[-]',
+ 'M+H [1+]', 'M+Na [1+]', 'M-H2O+H [1+]', 'M-H [1-]', 'M-2H [2-]', 'M-H2O-H [1-]')
+
+# mz tolerance based on instrument type
+# input: a vector of mz,
+# output: a vector of distance tolerance
+# Review on mass accuracy by Fiehn: https://www.ncbi.nlm.nih.gov/pmc/articles/PMC1464138/
+
+mz_tolerance <- function(mz, ms.type){
+ return(ms.type*1e-06*mz)
+}
+
+#'Utility function to create compound lists for permutation analysis
+#'@description From a vector of m/z features, this function outputs a vector of compounds.
+#'@usage make_cpdlist(mSetObj=NA, input_mzs)
+#'@param mSetObj Input the name of the created mSetObj
+#'@param input_mzs The vector of randomly drawn m/z features.
+#'@author Jasmine Chong, Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+make_cpdlist <- function(mSetObj=NA, input_mzs){
+ cpd <- unique(unlist(mSetObj$mz2cpd_dict[input_mzs]));
+ cpd <- cpd[!is.null(cpd)];
+ return(cpd);
+}
+
+#'Utility function to create compound lists for permutation analysis
+#'@description From a vector of m/z features, this function outputs a vector of compounds.
+#'@usage make_cpdlist(mSetObj=NA, input_mzs)
+#'@param mSetObj Input the name of the created mSetObj
+#'@param input_mzs The vector of randomly drawn m/z features.
+#'@author Jasmine Chong, Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+make_ecpdlist <- function(mSetObj=NA, input_mzs){
+ ecpd <- unique(unlist(mSetObj$mz2ec_dict[input_mzs]));
+ ecpd <- ecpd[!is.null(ecpd)];
+ return(ecpd);
+}
+
+# Utility function to adjust for the fact that a single m/z feature can match to several compound identifiers
+# input: a vector of compound ids
+# output: a length of unique mzs corresponding to those compounds
+
+count_cpd2mz <- function(cpd2mz_dict, cpd.ids, inputmzlist){ # inputmz is either t or input cpd_list and cpd.ids are overlap features
+
+ if(length(cpd.ids)==0){
+ return(0);
+ }
+ mzs <- as.numeric(unique(unlist(cpd2mz_dict[cpd.ids])));
+ if(length(mzs)==0){
+ return(0);
+ }else{
+ result <- intersect(mzs, inputmzlist); #intersect to only mzs from the input mz list
+ return(length(result));
+ }
+}
+
+# convert single element vector in list to matrix
+# b/c single element vector will convert to scalar in javascript, force to matrix
+convert2JsonList <- function(my.list){
+ lapply(my.list, function(x){
+ if(length(x) == 1){
+ matrix(x);
+ }else{
+ x;
+ }
+ });
+}
+
+# input: a two-col (id, val) data with potential duplicates (same id may be associated with 1 or more values
+# output: a list named by unique id, with multiple values will be merged to vector
+Convert2Dictionary <- function(data, quiet=T){
+
+ all.ids <- data[,1];
+ dup.inx <- duplicated(all.ids);
+ if(sum(dup.inx) > 0){
+ uniq.ids <- all.ids[!dup.inx];
+ uniq.vals <- data[!dup.inx,2];
+
+ # convert two-col data it to list (vals as list values, ids as list names)
+ uniq.list <- split(uniq.vals, uniq.ids)
+
+ # the list element orde will be sorted by the names alphabetically, need to get updated ones
+ uniq.id.list <- names(uniq.list)
+
+ dup.ids <- all.ids[dup.inx];
+ uniq.dupids <- unique(dup.ids);
+ uniq.duplen <- length(uniq.dupids);
+
+ for(id in uniq.dupids){ # only update those with more than one hits
+ hit.inx.all <- which(all.ids == id);
+ hit.inx.uniq <- which(uniq.id.list == id);
+ uniq.list[[hit.inx.uniq]]<- data[hit.inx.all,2];
+ }
+
+ AddMsg(paste("A total of ", sum(dup.inx), " of duplicates were merged.", sep=""));
+ return(uniq.list);
+ }else{
+ AddMsg("All IDs are unique.");
+ uniq.list <- split(data[,2], data[,1]);
+ return(uniq.list);
+ }
+}
+
+# utility function for fast list expanding (dynamic length)
+# We need to repeatedly add an element to a list. With normal list concatenation
+# or element setting this would lead to a large number of memory copies and a
+# quadratic runtime. To prevent that, this function implements a bare bones
+# expanding array, in which list appends are (amortized) constant time.
+# https://stackoverflow.com/questions/2436688/append-an-object-to-a-list-in-r-in-amortized-constant-time-o1
+
+myFastList <- function(capacity = 100) {
+ buffer <- vector('list', capacity)
+ names <- character(capacity)
+ length <- 0
+ methods <- list()
+
+ methods$double.size <- function() {
+ buffer <<- c(buffer, vector('list', capacity))
+ names <<- c(names, character(capacity))
+ capacity <<- capacity * 2
+ }
+
+ methods$add <- function(name, val) {
+ if(length == capacity) {
+ methods$double.size()
+ }
+
+ length <<- length + 1
+ buffer[[length]] <<- val
+ names[length] <<- name
+ }
+
+ methods$as.list <- function() {
+ b <- buffer[0:length]
+ names(b) <- names[0:length]
+ return(b)
+ }
+
+ methods
+}
+
+####
+####
+#### from the fgsea R package, minor edits to adapt to untargeted metabolomics
+
+#'Pre-ranked gsea adapted for untargeted metabolomics
+#'@export
+#'@import fgsea
+
+fgsea2 <- function(mSetObj, pathways, stats, ranks,
+ nperm,
+ minSize=1, maxSize=Inf,
+ nproc=0,
+ gseaParam=1,
+ BPPARAM=NULL) {
+
+ # Warning message for ties in stats
+ ties <- sum(duplicated(stats[stats != 0]))
+ if (ties != 0) {
+ warning("There are ties in the preranked stats (",
+ paste(round(ties * 100 / length(stats), digits = 2)),
+ "% of the list).\n",
+ "The order of those tied m/z features will be arbitrary, which may produce unexpected results.")
+ }
+
+ # Warning message for duplicate gene names
+ if (any(duplicated(names(stats)))) {
+ warning("There are duplicate m/z feature names, fgsea may produce unexpected results")
+ }
+
+ granularity <- 1000
+ permPerProc <- rep(granularity, floor(nperm / granularity))
+ if (nperm - sum(permPerProc) > 0) {
+ permPerProc <- c(permPerProc, nperm - sum(permPerProc))
+ }
+ set.seed(123)
+ seeds <- sample.int(10^9, length(permPerProc))
+
+ if (is.null(BPPARAM)) {
+ if (nproc != 0) {
+ if (.Platform$OS.type == "windows") {
+ # windows doesn't support multicore, using snow instead
+ BPPARAM <- BiocParallel::SnowParam(workers = nproc)
+ } else {
+ BPPARAM <- BiocParallel::MulticoreParam(workers = nproc)
+ }
+ } else {
+ BPPARAM <- BiocParallel::bpparam()
+ }
+ }
+
+ minSize <- max(minSize, 1)
+ stats <- abs(stats) ^ gseaParam
+
+ # returns list of indexs of matches between pathways and rank names
+ pathwaysPos <- lapply(pathways, function(p) { as.vector(na.omit(fastmatch::fmatch(p, names(ranks)))) })
+ pathwaysFiltered <- lapply(pathwaysPos, function(s) { ranks[s] })
+ qs::qsave(pathwaysFiltered, "pathwaysFiltered.qs")
+
+ # adjust for the fact that a single m/z feature can match to several compound identifiers (not when in EC space)
+ # subsets m/z features responsible for a compound and matches it to total set of matched m/z features
+ # returns the length
+
+ matched_res <- qs::qread("mum_res.qs");
+
+ if(mSetObj$dataSet$mumRT){
+ pathwaysSizes <- sapply(pathwaysFiltered, length)
+ }else{
+ pathway2mzSizes <- sapply(pathways, function(z) { length(intersect(as.numeric(unique(unlist(mSetObj$cpd2mz_dict[z]))), unique(matched_res[,1])))} )
+ oldpathwaysSizes <- sapply(pathwaysFiltered, length)
+ pathwaysSizes <- pmin(pathway2mzSizes, oldpathwaysSizes)
+ }
+
+ toKeep <- which(minSize <= pathwaysSizes & pathwaysSizes <= maxSize)
+ m <- length(toKeep)
+
+ if (m == 0) {
+ return(data.table::data.table(pathway=character(),
+ pval=numeric(),
+ padj=numeric(),
+ ES=numeric(),
+ NES=numeric(),
+ nMoreExtreme=numeric(),
+ size=integer(),
+ leadingEdge=list()))
+ }
+
+ pathwaysFiltered <- pathwaysFiltered[toKeep]
+ pathwaysSizes <- pathwaysSizes[toKeep]
+
+ K <- max(pathwaysSizes)
+
+ #perform gsea
+ gseaStatRes <- do.call(rbind,
+ lapply(pathwaysFiltered, fgsea::calcGseaStat,
+ stats=stats,
+ returnLeadingEdge=TRUE))
+
+ leadingEdges <- mapply("[", list(names(stats)), gseaStatRes[, "leadingEdge"], SIMPLIFY = FALSE)
+ pathwayScores <- unlist(gseaStatRes[, "res"])
+
+ #perform permutations
+ universe <- seq_along(stats)
+ set.seed(123)
+ counts <- BiocParallel::bplapply(seq_along(permPerProc), function(i) {
+ nperm1 <- permPerProc[i]
+ leEs <- rep(0, m)
+ geEs <- rep(0, m)
+ leZero <- rep(0, m)
+ geZero <- rep(0, m)
+ leZeroSum <- rep(0, m)
+ geZeroSum <- rep(0, m)
+ if (m == 1) {
+ for (i in seq_len(nperm1)) {
+ randSample <- sample.int(length(universe), K)
+ randEsP <- fgsea::calcGseaStat(
+ stats = stats,
+ selectedStats = randSample,
+ gseaParam = 1)
+ leEs <- leEs + (randEsP <= pathwayScores)
+ geEs <- geEs + (randEsP >= pathwayScores)
+ leZero <- leZero + (randEsP <= 0)
+ geZero <- geZero + (randEsP >= 0)
+ leZeroSum <- leZeroSum + pmin(randEsP, 0)
+ geZeroSum <- geZeroSum + pmax(randEsP, 0)
+ }
+ } else {
+ if (packageVersion("fgsea") > "1.12.0"){
+ aux <- fgsea:::calcGseaStatCumulativeBatch(
+ stats = stats,
+ gseaParam = 1,
+ pathwayScores = pathwayScores,
+ pathwaysSizes = pathwaysSizes,
+ iterations = nperm1,
+ seed = seeds[i],
+ scoreType = "std")} else {
+ aux <- fgsea:::calcGseaStatCumulativeBatch(
+ stats = stats,
+ gseaParam = 1,
+ pathwayScores = pathwayScores,
+ pathwaysSizes = pathwaysSizes,
+ iterations = nperm1,
+ seed = seeds[i])
+ }
+ leEs = get("leEs", aux)
+ geEs = get("geEs", aux)
+ leZero = get("leZero", aux)
+ geZero = get("geZero", aux)
+ leZeroSum = get("leZeroSum", aux)
+ geZeroSum = get("geZeroSum", aux)
+ }
+ data.table::data.table(pathway=seq_len(m),
+ leEs=leEs, geEs=geEs,
+ leZero=leZero, geZero=geZero,
+ leZeroSum=leZeroSum, geZeroSum=geZeroSum
+ )
+ }, BPPARAM=BPPARAM)
+
+ counts <- data.table::rbindlist(counts)
+
+ # Getting rid of check NOTEs
+ leEs=leZero=geEs=geZero=leZeroSum=geZeroSum=NULL
+ pathway=padj=pval=ES=NES=geZeroMean=leZeroMean=NULL
+ nMoreExtreme=nGeEs=nLeEs=size=NULL
+ leadingEdge=NULL
+ .="damn notes"
+
+ pval <- unlist(lapply(counts$pathway, function(c) min((1+sum(counts[c,]$leEs)) / (1 + sum(counts[c,]$leZero)),
+ (1+sum(counts[c,]$geEs)) / (1 + sum(counts[c,]$geZero)))))
+
+ leZeroMean <- unlist(lapply(counts$pathway, function(d) sum(counts[d,]$leZeroSum) / sum(counts[d,]$leZero)))
+ geZeroMean <- unlist(lapply(counts$pathway, function(e) sum(counts[e,]$geZeroSum) / sum(counts[e,]$geZero)))
+ nLeEs <- unlist(lapply(counts$pathway, function(f) sum(counts[f,]$leEs)))
+ nGeEs <- unlist(lapply(counts$pathway, function(g) sum(counts[g,]$geEs)))
+
+ pvals <- data.frame(pval=pval, leZeroMean=leZeroMean, geZeroMean=geZeroMean, nLeEs=nLeEs, nGeEs=nGeEs)
+
+ padj <- p.adjust(pvals$pval, method="fdr")
+ ES <- pathwayScores
+ NES <- ES / ifelse(ES > 0, pvals$geZeroMean, abs(pvals$leZeroMean))
+ pvals$leZeroMean <- NULL
+ pvals$geZeroMean <- NULL
+
+ nMoreExtreme <- ifelse(ES > 0, pvals$nGeEs, pvals$nLeEs)
+ pvals$nLeEs <- NULL
+ pvals$nGeEs <- NULL
+
+ size <- pathwaysSizes
+ pathway <- names(pathwaysFiltered)
+
+ leadingEdge <- sapply(leadingEdges, paste0, collapse = "; ")
+ leadingEdge2 <- sapply(leadingEdge, function(x) strsplit(x, "; "))
+ pathway.cpds <- sapply(pathwaysFiltered, attributes)
+
+ matches <- mapply(intersect, leadingEdge2, pathway.cpds)
+
+ leadingEdgeMatched <- sapply(matches, paste0, collapse = "; ")
+
+ pvals.done <- cbind(pathway, pvals, padj, ES, NES, nMoreExtreme, size, leadingEdgeMatched)
+
+ return(pvals.done)
+}
+
+calcGseaStat2 <- function(stats, selectedStats, gseaParam=1,
+ returnAllExtremes=FALSE,
+ returnLeadingEdge=FALSE) {
+
+ S <- selectedStats
+ r <- stats
+ p <- gseaParam
+
+ S <- sort(S)
+
+ # account for 1 mz can be multiple cpds
+ S.scores <- r[S]
+ u.S <- S[!duplicated(S.scores)]
+ scores <- unique(S.scores)
+
+ m <- length(scores)
+ N <- length(r)
+
+ if (m == N) {
+ stop("GSEA statistic is not defined when all genes are selected")
+ }
+
+ NR <- (sum(abs(scores)^p))
+ rAdj <- abs(scores)^p
+ if (NR == 0) {
+ # this is equivalent to rAdj being rep(eps, m)
+ rCumSum <- seq_along(rAdj) / length(rAdj)
+ } else {
+ rCumSum <- cumsum(rAdj) / NR
+ }
+
+ tops <- rCumSum - (u.S - seq_along(u.S)) / (N - m)
+ if (NR == 0) {
+ # this is equivalent to rAdj being rep(eps, m)
+ bottoms <- tops - 1 / m
+ } else {
+ bottoms <- tops - rAdj / NR
+ }
+
+ maxP <- max(tops)
+ minP <- min(bottoms)
+
+ if(maxP > -minP) {
+ geneSetStatistic <- maxP
+ } else if (maxP < -minP) {
+ geneSetStatistic <- minP
+ } else {
+ geneSetStatistic <- 0
+ }
+
+ if (!returnAllExtremes && !returnLeadingEdge) {
+ return(geneSetStatistic)
+ }
+
+ res <- list(res=geneSetStatistic)
+ if (returnAllExtremes) {
+ res <- c(res, list(tops=tops, bottoms=bottoms))
+ }
+ if (returnLeadingEdge) {
+ leadingEdge <- if (maxP > -minP) {
+ u.S[seq_along(u.S) <= which.max(bottoms)]
+ } else if (maxP < -minP) {
+ rev(u.S[seq_along(u.S) >= which.min(bottoms)])
+ } else {
+ NULL
+ }
+
+ res <- c(res, list(leadingEdge=leadingEdge))
+ }
+ res
+}
+
+sumlog <-function(p) {
+ keep <- (p > 0) & (p <= 1)
+ lnp <- log(p[keep])
+ chisq <- (-2) * sum(lnp)
+ df <- 2 * length(lnp)
+ if(sum(1L * keep) < 2)
+ stop("Must have at least two valid p values")
+ if(length(lnp) != length(p)) {
+ warning("Some studies omitted")
+ }
+ res <- list(chisq = chisq, df = df,
+ p = pchisq(chisq, df, lower.tail = FALSE), validp = p[keep])
+ class(res) <- c("sumlog", "metap")
+ res
+}
+
+####
+####
+#### for heatmap view (online only)
+
+.rt.included <- function(mSetObj = NA, rt){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(rt %in% c("minutes", "seconds")){
+ is.rt <<- TRUE
+ mumRT.type <<- rt
+ }else{
+ is.rt <<- FALSE
+ mumRT.type <<- rt
+ }
+ mSetObj$dataSet$mumRT.type <- rt;
+ return(.set.mSet(mSetObj));
+}
+
+CreateHeatmapJson <- function(mSetObj=NA, libOpt, libVersion, minLib, fileNm, filtOpt,
+ version="v1"){
+ mSetObj <- .get.mSet(mSetObj);
+ dataSet <- mSetObj$dataSet;
+ data <- t(dataSet$norm)
+ sig.ids <- rownames(data);
+
+ res <- PerformFastUnivTests(mSetObj$dataSet$norm, mSetObj$dataSet$cls);
+
+ if(dataSet$mode == "positive"){
+ mSetObj$dataSet$pos_inx = rep(TRUE, nrow(data))
+ }else if(dataSet$mode == "negative"){
+ mSetObj$dataSet$pos_inx = rep(FALSE, nrow(data))
+ }
+
+ mSetObj$dataSet$mumRT <- is.rt
+ mSetObj$dataSet$mumRT.type <- mumRT.type
+
+ if(mSetObj$dataSet$mumRT){
+ feat_info <- rownames(data)
+ feat_info_split <- matrix(unlist(strsplit(feat_info, "__", fixed=TRUE)), ncol=2, byrow=T)
+ colnames(feat_info_split) <- c("m.z", "r.t")
+
+ if(length(unique(feat_info_split[,1])) != length(feat_info_split[,1])){
+
+ # ensure features are unique
+ mzs_unq <- feat_info_split[,1][duplicated(feat_info_split[,1])]
+ set.seed(123)
+ if(length(mzs_unq)>0){
+ feat_info_split[,1][duplicated(feat_info_split[,1])] <- sapply(mzs_unq, function(x) paste0(x, sample(1:999, 1, replace = FALSE)))
+ }
+ }
+
+ if(mSetObj$dataSet$mumRT.type == "minutes"){
+ rtime <- as.numeric(feat_info_split[,2])
+ rtime <- rtime * 60
+ feat_info_split[,2] <- rtime
+ }
+
+ new_feats <- paste(feat_info_split[,1], feat_info_split[,2], sep = "__")
+ rownames(data) <- make.unique(new_feats)
+
+ rownames(res) <- l <- mSetObj$dataSet$ref_mzlist <- make.unique(feat_info_split[,1]);
+ retention_time <- as.numeric(feat_info_split[,2]);
+ names(retention_time) <- mSetObj$dataSet$ref_mzlist;
+ mSetObj$dataSet$ret_time <- retention_time;
+
+ if(is.na(mSetObj$dataSet$rt_tol)){
+ rt_tol <- max(mSetObj$dataSet$ret_time) * mSetObj$dataSet$rt_frac
+ print(paste0("Retention time tolerance is ", rt_tol))
+ mSetObj$dataSet$rt_tol <- rt_tol
+ }
+ mSetObj$dataSet$expr_dic= res[,1];
+ names(mSetObj$dataSet$expr_dic) = rownames(res)
+ }else{
+ l <- sapply(rownames(data), function(x) return(unname(strsplit(x,"/")[[1]][1])))
+ mSetObj$dataSet$ref_mzlist <- rownames(res) <- l <- as.numeric(unname(unlist(l)))
+ mSetObj$dataSet$expr_dic= res[,1];
+ names(mSetObj$dataSet$expr_dic) = rownames(data)
+ }
+
+ mum.version <<- version
+
+ if(filtOpt == "filtered"){
+ mSetObj <- .setup.psea.library(mSetObj, libOpt, libVersion, minLib);
+ matched_res <- qs::qread("mum_res.qs");
+ res_table <- matched_res;
+ data = data[which(l %in% res_table[,"Query.Mass"]),]
+ res = res[which(rownames(res) %in% res_table[,"Query.Mass"]),]
+ }
+
+ stat.pvals <- unname(as.vector(res[,2]));
+ t.stat <- unname(as.vector(res[,1]));
+ org = unname(strsplit(libOpt,"_")[[1]][1])
+ # scale each gene
+ dat <- t(scale(t(data)));
+
+ rankPval = order(as.vector(stat.pvals))
+ stat.pvals = stat.pvals[rankPval]
+ dat = dat[rankPval,]
+
+ t.stat = t.stat[rankPval]
+
+ # now pearson and euclidean will be the same after scaleing
+ dat.dist <- dist(dat);
+
+ orig.smpl.nms <- colnames(dat);
+ orig.gene.nms <- rownames(dat);
+
+ # do clustering and save cluster info
+ # convert order to rank (score that can used to sort)
+ if(nrow(dat)> 1){
+ dat.dist <- dist(dat);
+ gene.ward.ord <- hclust(dat.dist, "ward.D")$order;
+ gene.ward.rk <- match(orig.gene.nms, orig.gene.nms[gene.ward.ord]);
+ gene.ave.ord <- hclust(dat.dist, "ave")$order;
+ gene.ave.rk <- match(orig.gene.nms, orig.gene.nms[gene.ave.ord]);
+ gene.single.ord <- hclust(dat.dist, "single")$order;
+ gene.single.rk <- match(orig.gene.nms, orig.gene.nms[gene.single.ord]);
+ gene.complete.ord <- hclust(dat.dist, "complete")$order;
+ gene.complete.rk <- match(orig.gene.nms, orig.gene.nms[gene.complete.ord]);
+
+ dat.dist <- dist(t(dat));
+ smpl.ward.ord <- hclust(dat.dist, "ward.D")$order;
+ smpl.ward.rk <- match(orig.smpl.nms, orig.smpl.nms[smpl.ward.ord])
+ smpl.ave.ord <- hclust(dat.dist, "ave")$order;
+ smpl.ave.rk <- match(orig.smpl.nms, orig.smpl.nms[smpl.ave.ord])
+ smpl.single.ord <- hclust(dat.dist, "single")$order;
+ smpl.single.rk <- match(orig.smpl.nms, orig.smpl.nms[smpl.single.ord])
+ smpl.complete.ord <- hclust(dat.dist, "complete")$order;
+ smpl.complete.rk <- match(orig.smpl.nms, orig.smpl.nms[smpl.complete.ord])
+ }else{
+ # force not to be single element vector which will be scaler
+ #stat.pvals <- matrix(stat.pvals);
+ gene.ward.rk <- gene.ave.rk <- gene.single.rk <- gene.complete.rk <- matrix(1);
+ smpl.ward.rk <- smpl.ave.rk <- smpl.single.rk <- smpl.complete.rk <- 1:ncol(dat);
+ }
+
+ gene.cluster <- list(
+ ward = gene.ward.rk,
+ average = gene.ave.rk,
+ single = gene.single.rk,
+ complete = gene.complete.rk,
+ pval = stat.pvals,
+ stat = t.stat
+ );
+
+ sample.cluster <- list(
+ ward = smpl.ward.rk,
+ average = smpl.ave.rk,
+ single = smpl.single.rk,
+ complete = smpl.complete.rk
+ );
+
+ # prepare meta info
+ # 1) convert meta.data info numbers
+ # 2) match number to string (factor level)
+ meta <- data.frame(dataSet$cls);
+ grps <- "Condition"
+ nmeta <- meta.vec <- NULL;
+ uniq.num <- 0;
+ for (i in 1:ncol(meta)){
+ cls <- meta[,i];
+ grp.nm <- grps[i];
+ meta.vec <- c(meta.vec, as.character(cls))
+ # make sure each label are unqiue across multiple meta data
+ ncls <- paste(grp.nm, as.numeric(cls)); # note, here to retain ordered factor
+ nmeta <- c(nmeta, ncls);
+ }
+
+ # convert back to numeric
+ nmeta <- as.numeric(as.factor(nmeta))+99;
+ unik.inx <- !duplicated(nmeta)
+
+ # get corresponding names
+ meta_anot <- meta.vec[unik.inx];
+ names(meta_anot) <- nmeta[unik.inx]; # name annotatation by their numbers
+
+ nmeta <- matrix(nmeta, ncol=ncol(meta), byrow=F);
+ colnames(nmeta) <- grps;
+
+ # for each gene/row, first normalize and then tranform real values to 30 breaks
+ res <- t(apply(dat, 1, function(x){as.numeric(cut(x, breaks=30))}));
+
+ # note, use {} will lose order; use [[],[]] to retain the order
+
+ gene.id = orig.gene.nms; if(length(gene.id) ==1) { gene.id <- matrix(gene.id) };
+ json.res <- list(
+ data.type = dataSet$type,
+ gene.id = gene.id,
+ gene.entrez = gene.id,
+ gene.name = gene.id,
+ gene.cluster = gene.cluster,
+ sample.cluster = sample.cluster,
+ sample.names = orig.smpl.nms,
+ meta = data.frame(nmeta),
+ meta.anot = meta_anot,
+ data = res,
+ org = org
+ );
+
+ mSetObj$dataSet$hm_peak_names = gene.id
+ mSetObj$dataSet$gene.cluster = gene.cluster
+
+ .set.mSet(mSetObj)
+ require(RJSONIO);
+ json.mat <- toJSON(json.res, .na='null');
+ sink(fileNm);
+ cat(json.mat);
+ sink();
+ current.msg <<- "Data is now ready for heatmap visualization!";
+ return(1);
+}
+
+doHeatmapMummichogTest <- function(mSetObj=NA, nm, libNm, ids){
+
+ mSetObj<-.get.mSet(mSetObj);
+
+ if(ids == "overall"){
+ .on.public.web <<- F;
+ mSetObj<-PreparePrenormData(mSetObj)
+ mSetObj<-Normalization(mSetObj, "MedianNorm", "LogNorm", "AutoNorm", ratio=FALSE, ratioNum=20)
+ mSetObj<-Ttests.Anal(mSetObj, F, 0.05, FALSE, TRUE)
+ mSetObj<-Convert2Mummichog(mSetObj, is.rt, F, mSetObj$dataSet$mumRT.type, "tt", mSetObj$dataSet$mode);
+ mSetObj<-InitDataObjects("mass_all", "mummichog", FALSE)
+ SetPeakFormat("mpt")
+ #mSetObj<-UpdateInstrumentParameters(mSetObj, 10, mSetObj$dataSet$mode);
+ filename <- paste0("mummichog_input_", Sys.Date(), ".txt")
+ mSetObj<-Read.PeakListData(mSetObj, filename);
+ mSetObj<-SanityCheckMummichogData(mSetObj)
+ mSetObj<-SetPeakEnrichMethod(mSetObj, "mum", "v2")
+ mSetObj<-SetMummichogPval(mSetObj, 0.05)
+ .on.public.web <<- T;
+ .set.mSet(mSetObj);
+ anal.type <<- "integ";
+ }else{
+ gene.vec <- unlist(strsplit(ids, "; "));
+ anal.type <<- "mummichog";
+
+ if(is.rt){
+ feat_info_split <- matrix(unlist(strsplit(gene.vec, "__", fixed=TRUE)), ncol=2, byrow=T)
+ colnames(feat_info_split) <- c("m.z", "r.t")
+ mSetObj$dataSet$input_mzlist <- as.numeric(feat_info_split[,1]);
+ mSetObj$dataSet$N <- length(mSetObj$dataSet$input_mzlist);
+ }else{
+ mSetObj$dataSet$input_mzlist <- gene.vec;
+ mSetObj$dataSet$N <- length(gene.vec);
+ }
+ }
+
+ mSetObj$mum_nm <- paste0(nm,".json");
+ mSetObj$mum_nm_csv <- paste0(nm,".csv");
+ .set.mSet(mSetObj);
+ PerformPSEA("NA", libNm, "current", 3, 100);
+}
+
+DoPeakConversion <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ res <- Ttests.Anal(mSetObj, F, 1, FALSE, TRUE)
+ ####### NOTE: need to use Ttests.Anal because Convert2Mummichog function takes as input result list from Ttests.anal: mSetObj$analSet$tt
+
+ if(.on.public.web){
+ if(res==0){
+ AddErrMsg("T-test failed, please consider trying different data normalization option!");
+ return(0);
+ }
+ mSetObj <- .get.mSet();
+ .on.public.web <<- F;
+ mSetObj<-Convert2Mummichog(mSetObj, is.rt, F, mSetObj$dataSet$mumRT.type, "tt", mSetObj$dataSet$mode);
+ SetPeakFormat("mpt")
+ filename <- paste0("mummichog_input_", Sys.Date(), ".txt")
+ mSetObj<-Read.PeakListData(mSetObj, filename);
+ mSetObj<-SanityCheckMummichogData(mSetObj)
+ .on.public.web <<- T;
+ .set.mSet(mSetObj);
+ return(1)
+ }else{
+ if(mSetObj$analSet$tt$sig.num == 0){
+ AddErrMsg("T-test failed, please consider trying different data normalization option!");
+ return(0);
+ }
+ mSetObj <- Convert2Mummichog(mSetObj, is.rt, F, mSetObj$dataSet$mumRT.type, "tt", mSetObj$dataSet$mode);
+ SetPeakFormat("mpt")
+ filename <- paste0("mummichog_input_", Sys.Date(), ".txt")
+ mSetObj <- Read.PeakListData(mSetObj, filename);
+ mSetObj <- SanityCheckMummichogData(mSetObj)
+ }
+ return(.set.mSet(mSetObj));
+}
+
+CreateListHeatmapJson <- function(mSetObj=NA, libOpt, libVersion, minLib, fileNm, filtOpt, version="v1"){
+
+ mSetObj <- .get.mSet();
+ sig.ids <- as.character(mSetObj$dataSet$mummi.proc[,"m.z"]);
+ gene.symbols <- as.character(mSetObj$dataSet$mummi.proc[,"m.z"]);
+ stat.pvals <- mSetObj$dataSet$mummi.proc[,"p.value"];
+ if("t.score" %in% colnames(mSetObj$dataSet$mummi.proc)){
+ t.stat <- mSetObj$dataSet$mummi.proc[,"t.score"];
+ }else{
+ t.stat <- 0;
+ }
+ data <- mSetObj$dataSet$mummi.proc
+ res <- data
+ rownames(data) <- sig.ids
+
+ data <- data[,-which(colnames(data) %in% c("m.z","pos_inx","r.t"))]
+
+ # prepare meta info
+ # 1) convert meta.data info numbers
+ # 2) match number to string (factor level)
+
+ grps <- "datalist1"
+ cls <- "datalist1"
+
+ mSetObj$dataSet$mumRT <- is.rt
+ mSetObj$dataSet$mumRT.type <- mumRT.type
+
+ if(mSetObj$dataSet$mumRT){
+ feat_info <- rownames(data)
+ feat_info_split <- matrix(unlist(strsplit(feat_info, "__", fixed=TRUE)), ncol=2, byrow=T)
+ colnames(feat_info_split) <- c("m.z", "r.t")
+
+ if(mSetObj$dataSet$mumRT.type == "minutes"){
+ rtime <- as.numeric(feat_info_split[,2])
+ rtime <- rtime * 60
+ feat_info_split[,2] <- rtime
+ }
+
+ new_feats <- paste(feat_info_split[,1], feat_info_split[,2], sep = "__")
+ rownames(data) <- new_feats
+
+ rownames(res) <- l <- mSetObj$dataSet$ref_mzlist <- as.numeric(feat_info_split[,1]);
+ retention_time <- as.numeric(feat_info_split[,2]);
+ names(retention_time) <- mSetObj$dataSet$ref_mzlist;
+ mSetObj$dataSet$ret_time <- retention_time;
+
+ if(is.na(mSetObj$dataSet$rt_tol)){
+ rt_tol <- max(mSetObj$dataSet$ret_time) * mSetObj$dataSet$rt_frac
+ print(paste0("Retention time tolerance is ", rt_tol))
+ mSetObj$dataSet$rt_tol <- rt_tol
+ }
+ mSetObj$dataSet$expr_dic= res[,1];
+ names(mSetObj$dataSet$expr_dic) = rownames(res)
+ }else{
+ l <- sapply(rownames(data), function(x) return(unname(strsplit(x,"/")[[1]][1])))
+ mSetObj$dataSet$ref_mzlist <- rownames(res) <- l <- as.numeric(unname(unlist(l)))
+ mSetObj$dataSet$expr_dic= res[,1];
+ names(mSetObj$dataSet$expr_dic) = rownames(data)
+ }
+
+ if(filtOpt == "filtered"){
+ mSetObj <- .setup.psea.library(mSetObj, libOpt, libVersion, minLib);
+ matched_res <- qs::qread("mum_res.qs");
+ res_table <- matched_res;
+ data = data[which(l %in% res_table[,"Query.Mass"]),]
+ res = res[which(rownames(res) %in% res_table[,"Query.Mass"]),]
+ }
+
+ expval <- 0
+ expval <- sum(data)
+
+ # scale each gene
+ dat <- data
+
+ # now pearson and euclidean will be the same after scaleing
+ dat.dist <- dist(dat);
+
+ orig.smpl.nms <- colnames(dat);
+ orig.gene.nms <- rownames(dat);
+
+
+ mum.version <<- version
+ # convert back to numeric
+
+ # for each gene/row, first normalize and then tranform real values to 30 breaks
+ resl <- list();
+ if(expval !=0){
+ datall <- dat
+ for(i in 1:ncol(dat)){
+ dat_pos <- as.matrix(dat[sign(dat[,i]) == 1,i])
+ dat_neg <- as.matrix(dat[sign(dat[,i]) == -1,i])
+ inx_pos <- sign(dat[,i]) == 1
+ inx_neg <- sign(dat[,i]) == -1
+ datsub <- as.matrix(dat[,i])
+ if(colnames(dat)[i] == "p.value"){
+ datsub= 1 - datsub
+ }
+ if(nrow(dat_pos) == 0){
+ datall[,i] <- apply(unname(datsub), 2, function(x){
+ y =log(abs(x)) + 0.000001
+ 16-as.numeric(cut(y, breaks=15))
+ });
+ }else if(nrow(dat_neg) == 0){
+ datall[,i] <- apply(unname(datsub), 2, function(x){
+ y =log(x) + 0.000001
+ 15+as.numeric(cut(y, breaks=15))
+ });
+ }else{
+ res_pos <- apply(unname(dat_pos), 2, function(x){
+ y =log(x) + 0.000001
+ as.numeric(cut(y, breaks=15))+15
+ });
+ res_neg <- apply(unname(dat_neg), 2, function(x){
+ y =log(abs(x)) + 0.000001
+ 16 - as.numeric(cut(y, breaks=15))
+ });
+ datall[inx_pos, i] = as.vector(res_pos)
+ datall[inx_neg, i] = as.vector(res_neg)
+ }
+
+ }
+ res = datall;
+ }else{
+
+ zero.inx <- dat == 0
+ res <- dat;
+ res[zero.inx] <- 32
+ }
+
+ res_list <- list()
+ for(i in 1:nrow(res)){
+ res_list[[i]] <- unname(res[i,])
+ }
+
+ if(nrow(dat)> 1){
+ dat.dist <- dist(dat);
+ gene.ward.ord <- hclust(dat.dist, "ward.D")$order;
+ gene.ward.rk <- match(orig.gene.nms, orig.gene.nms[gene.ward.ord]);
+ gene.ave.ord <- hclust(dat.dist, "ave")$order;
+ gene.ave.rk <- match(orig.gene.nms, orig.gene.nms[gene.ave.ord]);
+ gene.single.ord <- hclust(dat.dist, "single")$order;
+ gene.single.rk <- match(orig.gene.nms, orig.gene.nms[gene.single.ord]);
+ gene.complete.ord <- hclust(dat.dist, "complete")$order;
+ gene.complete.rk <- match(orig.gene.nms, orig.gene.nms[gene.complete.ord]);
+
+ dat.dist <- dist(t(dat));
+ smpl.ward.ord <- hclust(dat.dist, "ward.D")$order;
+ smpl.ward.rk <- match(orig.smpl.nms, orig.smpl.nms[smpl.ward.ord])
+ smpl.ave.ord <- hclust(dat.dist, "ave")$order;
+ smpl.ave.rk <- match(orig.smpl.nms, orig.smpl.nms[smpl.ave.ord])
+ smpl.single.ord <- hclust(dat.dist, "single")$order;
+ smpl.single.rk <- match(orig.smpl.nms, orig.smpl.nms[smpl.single.ord])
+ smpl.complete.ord <- hclust(dat.dist, "complete")$order;
+ smpl.complete.rk <- match(orig.smpl.nms, orig.smpl.nms[smpl.complete.ord])
+ }else{
+ # force not to be single element vector which will be scaler
+ rankPval = order(as.vector(stat.pvals))
+ stat.pvals = unname(stat.pvals[rankPval])
+ t.stat = unname(t.stat[rankPval])
+ gene.ward.rk <- gene.ave.rk <- gene.single.rk <- gene.complete.rk <- matrix(1);
+ smpl.ward.rk <- smpl.ave.rk <- smpl.single.rk <- smpl.complete.rk <- 1:ncol(dat);
+ }
+
+ gene.cluster <- list(
+ ward = gene.ward.rk,
+ average = gene.ave.rk,
+ single = gene.single.rk,
+ complete = gene.complete.rk,
+ pval = stat.pvals
+ );
+
+ if(t.stat != 0){
+ gene.cluster[["stat"]] = t.stat;
+ }
+
+ sample.cluster <- list(
+ ward = smpl.ward.rk,
+ average = smpl.ave.rk,
+ single = smpl.single.rk,
+ complete = smpl.complete.rk
+ );
+
+
+
+ # note, use {} will lose order; use [[],[]] to retain the order
+
+
+ nmeta <- as.numeric(as.factor(colnames(data))) + 99
+ nmeta.anot <- list()
+
+ for(i in 1:length(unique(nmeta))){
+ nmeta.anot[[colnames(data)[i]]] <- nmeta[i]
+ }
+ nmeta <- list(nmeta)
+ names(nmeta) <- "Statistics"
+
+
+ json.res <- list(
+ data.type = "singlelist",
+ gene.id = gene.symbols,
+ gene.entrez = sig.ids,
+ gene.name = gene.symbols,
+ gene.cluster = gene.cluster,
+ sample.cluster = sample.cluster,
+ sample.names = colnames(dat),
+ meta = nmeta,
+ meta.anot = nmeta.anot,
+ data = res_list,
+ expval = expval
+ );
+ .set.mSet(mSetObj);
+ require(RJSONIO);
+ json.mat <- toJSON(json.res, .na='null');
+ sink(fileNm);
+ cat(json.mat);
+ sink();
+ current.msg <<- "Data is now ready for heatmap visualization!";
+ return(1);
+}
+
+#'Set organism for further analysis
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param org Set organism ID
+#'@export
+SetOrganism <- function(mSetObj=NA, org){
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$org <- org;
+ return(.set.mSet(mSetObj))
+}
\ No newline at end of file
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/power_utils.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/power_utils.R
new file mode 100755
index 0000000000000000000000000000000000000000..bab3facda3b0993f4d10a3049a2f11e10d4f62ee
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/power_utils.R
@@ -0,0 +1,200 @@
+#'Function for power analysis
+#'@description Perform power analysis, requires the SSPA R package.
+#'@usage InitPowerAnal(mSetObj, clsOpts)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param clsOpts For data with >2 groups, specify the two classes on which to perform power analysis,
+#'otherwise for data with 2 groups, "NA" will automatically select the 2 groups.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+InitPowerAnal <- function(mSetObj=NA, clsOpts){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(clsOpts == "NA"){
+ grp.nms <- levels(mSetObj$dataSet$cls)[1:2];
+ }else{
+ grp.nms <- strsplit(clsOpts, " vs. ", fixed=TRUE)[[1]];
+ }
+ inx1 <- which(mSetObj$dataSet$cls==grp.nms[1]);
+ inx2 <- which(mSetObj$dataSet$cls==grp.nms[2]);
+ stats <- apply(as.matrix(mSetObj$dataSet$norm), 2, function(x) {
+ tmp <- try(t.test(x[inx1], x[inx2], paired = mSetObj$dataSet$paired, var.equal = T));
+ if(class(tmp) == "try-error") {
+ return(NA);
+ }else{
+ return(tmp$statistic);
+ }
+ })
+
+ stats <- stats[!is.na(stats)];
+ n1 <- length(inx1);
+ n2 <- length(inx2);
+
+ pdD <- SSPA::pilotData(statistics = stats,
+ samplesize = sqrt(n1+n2),
+ distribution="t",
+ df=n1+n2-2);
+ mSetObj$analSet$power <- list(pdD = pdD);
+ return(.set.mSet(mSetObj));
+}
+
+#'Plot power statistics
+#'@description Create plot for power statistics
+#'@usage PlotPowerStat(mSetObj, imgName, format="png", dpi=72, width=NA)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param imgName Specify the name to save the image as.
+#'@param format Specify the format of the image to save it as, either "png" or "pdf"
+#'@param dpi Specify the dots-per-inch (dpi). By default it is 72, for publications
+#'the recommended dpi is 300.
+#'@param width Specify the width of the image. NA or 0 specifies a width of 10, otherwise input a chosen width.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'@import lattice
+
+PlotPowerStat <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- 10;
+ }else if(width == 0){
+ w <- 10;
+ }else{
+ w <- width;
+ }
+ h <- w;
+
+ mSetObj$imgSet$powerstat<-imgName;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ if(.on.public.web){
+ load_lattice()
+ }
+ SSPA::plot(mSetObj$analSet$power$pdD);
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+#'Retrieve sample size ladder
+#'@description Return sample size ladder, used in higher functions
+#'@param maxNum Numeric
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+GetSampleSizeLadder <- function(maxNum){
+ Jpred <- c(3, 6, 10, 16, 24, 40, 60, 100, 150, seq(200, 1000, 100));
+ inx <- which(Jpred == min(Jpred[Jpred>=maxNum]))
+ return(Jpred[1:inx]);
+}
+
+#'Perform power profiling
+#'@description Perform power profiling of data
+#'@usage PerformPowerProfiling(mSetObj=NA, fdr.lvl, smplSize)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param fdr.lvl Specify the false-discovery rate level.
+#'@param smplSize Specify the maximum sample size, the number must be between 60-1000.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PerformPowerProfiling <- function(mSetObj=NA, fdr.lvl, smplSize){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ res <- round(length(mSetObj$analSet$power$pdD@statistics)/2);
+ ssD <- SSPA::sampleSize(mSetObj$analSet$power$pdD, method="congrad", control=list(from=-6, to=6, resolution=res));
+ Jpred <- GetSampleSizeLadder(smplSize);
+ N <- sqrt(Jpred/2);
+
+ pi0 <- ssD@pi0;
+ if(fdr.lvl >= pi0){
+ fdr.lvl <- signif(pi0-pi0/10, 3);
+ }
+ pwrD <- SSPA::predictpower(ssD, samplesizes=N, alpha=fdr.lvl)
+ mSetObj$analSet$power$ssD <- ssD;
+ mSetObj$analSet$power$Jpred <- Jpred;
+ mSetObj$analSet$power$pwrD <- pwrD;
+
+ if(.on.public.web){
+ .set.mSet(mSetObj);
+ return(fdr.lvl);
+ }
+ return(.set.mSet(mSetObj));
+}
+
+#'Plot power profile
+#'@description Plot power profile, specifying FDR level and sample size. It will
+#'return the image as well as the predicted power at various sample sizes.
+#'@usage PlotPowerProfile(mSetObj=NA, fdr.lvl, smplSize, imgName, format, dpi, width)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param fdr.lvl Specify the false-discovery rate level.
+#'@param smplSize Specify the maximum sample size, the number must be between 60-1000.
+#'@param imgName Specify the name to save the image as.
+#'@param format Specify the format of the image to save it as, either "png" or "pdf".
+#'@param dpi Specify the dots-per-inch (dpi). By default it is 72, for publications
+#'the recommended dpi is 300.
+#'@param width Specify the width of the image. NA specifies a width of 9, 0 specifies a width
+#'of 7, otherwise input a chosen width.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+PlotPowerProfile <- function(mSetObj=NA, fdr.lvl, smplSize, imgName, format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ Jpred <- GetSampleSizeLadder(smplSize);
+ N <- sqrt(Jpred/2);
+ pwrD <- SSPA::predictpower(mSetObj$analSet$power$ssD, samplesizes=N, alpha=fdr.lvl)
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- 9;
+ }else if(width == 0){
+ w <- 7;
+ }else{
+ w <- width;
+ }
+
+ h <- w*(6/9);
+
+ mSetObj$imgSet$powerprofile<-imgName;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ plot(Jpred, pwrD, type="n", ylim=c(0,1), ylab="Predicted power", xlab="Sample Size (per group)");
+ grid(col = "lightgray", lty = "dotted", lwd = 1);
+ lines(Jpred, pwrD, lwd=4, col="orange");
+ points(Jpred, pwrD, pch=17);
+ dev.off();
+
+ mSetObj$analSet$power$pwrD <- pwrD;
+ mSetObj$analSet$power$Jpred <- Jpred;
+
+ if(.on.public.web){
+ .set.mSet(mSetObj);
+ return(pwrD);
+ }
+ return(.set.mSet(mSetObj));
+}
+
+##############################################
+##############################################
+########## Utilities for web-server ##########
+##############################################
+##############################################
+
+GetPowerValuesX <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$analSet$power$Jpred);
+}
+
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/preproc_utils.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/preproc_utils.R
new file mode 100755
index 0000000000000000000000000000000000000000..c77422f9a7804852b11a809b878584e02af1373e
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/preproc_utils.R
@@ -0,0 +1,1642 @@
+#' Import raw MS data
+#' @description This function handles the reading in of
+#' raw MS data (.mzML, .CDF and .mzXML). Users must provide
+#' a matrix with meta information about file such that each file has the name,
+#' file path, group class and extension type.
+#' The function will output two chromatograms into the user's working directory, a
+#' base peak intensity chromatogram (BPIC) and a total ion
+#' chromatogram (TIC). Further, this function sets the number of cores
+#' to be used for parallel processing. It first determines the number of cores
+#' within a user's computer and then sets it that number/2.
+#' @param dataset.meta Matrix, input the meta data for files containing
+#' the raw MS spectra to be processed.
+#' @param format Character, input the format of the image to create.
+#' @param dpi Numeric, input the dpi of the image to create.
+#' @param width Numeric, input the width of the image to create.
+#' @param par.cores Logical, if true, the function will automatically
+#' set the number of parallel cores. If false, it will not.
+#' @param plot Logical, if true the function will create BPIS and TICS plots.
+#' @param bpis_name Character, input the name of the BPIS image to create.
+#' @param tics_name Character, input the name of the TICS image to create.
+#' @author Jasmine Chong \email{jasmine.chong@mail.mcgill.ca},
+#' Mai Yamamoto \email{yamamoto.mai@mail.mcgill.ca}, and Jeff Xia \email{jeff.xia@mcgill.ca}
+#' McGill University, Canada
+#' License: GNU GPL (>= 2)
+#' @export
+#' @import MSnbase
+#' @import BiocParallel
+#' @import parallel
+
+ImportRawMSDataList <- function(dataset.meta, format = "png", dpi = 72, width = 9,
+ par.cores=TRUE, plot=TRUE, bpis_name = "BPIS_", tics_name="TICS_"){
+
+ msg.vec <<- vector(mode="character")
+
+ if(bpis_name == "BPIS_"){
+ bpis_name = paste("BPIS_", dpi, ".", format, sep="");
+ }
+ if(tics_name == "TICS_"){
+ tics_name <- paste("TICS_", dpi, ".", format, sep="");
+ }
+
+ msg <- c("The uploaded files are raw MS spectra.");
+
+ # The dataset.meta should be a matrix such that each row has the following:
+ # 1- file name, 2- file path, 3- group and 4- file extension type
+ # provided. The accepted file extensions are (.mzML/.CDF/.mzXML files)
+
+ if(nrow(dataset.meta) == 0 || is.na(dataset.meta)){
+ AddErrMsg("No spectra were found!");
+ return(0);
+ }
+
+ compfile.types <- sum(sapply(dataset.meta[,3], function(x){x %in% c("mzml", "cdf", "mzxml")}))
+ if(compfile.types < nrow(dataset.meta)){
+ AddErrMsg("Only mzML, cdf and mzXML input types can be handled!");
+ return(0);
+ }
+
+ snames <- dataset.meta[,1]
+ files <- dataset.meta[,2]; files <- as.character(files); # Otherwise, a factor form of files will cause an error
+ sclass <- dataset.meta[,4]
+
+ # some sanity check before proceeds
+ sclass <- as.factor(sclass);
+ if(length(levels(sclass))<2){
+ AddErrMsg("You must provide classes labels (at least two classes)!");
+ return(0);
+ }
+
+ SetClass(sclass)
+
+ # check for unique sample names
+ if(length(unique(snames))!=length(snames)){
+ AddErrMsg("Duplicate sample names are not allowed!");
+ dup.nm <- paste(snames[duplicated(snames)], collapse=" ");
+ AddErrMsg("Duplicate sample names are not allowed!");
+ AddErrMsg(dup.nm);
+ return(0);
+ }
+
+ pd <- data.frame(sample_name = snames,
+ sample_group = sclass,
+ stringsAsFactors = FALSE)
+
+ if(!.on.public.web & par.cores==TRUE){
+ cores <- parallel::detectCores()
+ num_cores <- ceiling(cores/2)
+ print(paste0("The number of CPU cores to be used is set to ", num_cores, "."))
+
+ if (.Platform$OS.type == "unix") {
+ BiocParallel::register(BiocParallel::bpstart(BiocParallel::MulticoreParam(num_cores)))
+ } else { # for windows
+ BiocParallel::register(BiocParallel::bpstart(BiocParallel::SnowParam(num_cores)))
+ }
+ }
+
+ raw_data <- suppressMessages(read.MSdata(files = files, pdata = new("NAnnotatedDataFrame", pd),
+ mode = "onDisk"))
+
+ if(plot==TRUE){
+ # Plotting functions to see entire chromatogram
+ bpis <- chromatogram(raw_data, aggregationFun = "max")
+ tics <- chromatogram(raw_data, aggregationFun = "sum")
+
+ groupNum <- nlevels(groupInfo)
+
+ if(groupNum > 9){
+ col.fun <- grDevices::colorRampPalette(RColorBrewer::brewer.pal(12, "Set3"))
+ group_colors <- col.fun(groupNum)
+ }else{
+ group_colors <- paste0(RColorBrewer::brewer.pal(9, "Set1")[1:groupNum], "60")
+ }
+
+ names(group_colors) <- levels(groupInfo)
+
+ Cairo::Cairo(file = bpis_name, unit="in", dpi=dpi, width=width, height= width*5/9,
+ type=format, bg="white");
+ plot(bpis, col = group_colors[raw_data$sample_group])
+ legend("topright", legend=levels(groupInfo), pch=15, col=group_colors);
+ dev.off();
+
+ Cairo::Cairo(file = tics_name, unit="in", dpi=dpi, width=width, height=width*5/9,
+ type=format, bg="white");
+ plot(tics, col = group_colors[raw_data$sample_group])
+ legend("topright", legend=levels(groupInfo), pch=15, col=group_colors);
+ dev.off();
+ }
+
+ print("Successfully imported raw MS data!")
+
+ return(raw_data)
+}
+
+#' Import raw MS data
+#' @description This function handles the reading in of
+#' raw MS data (.mzML, .CDF and .mzXML). Users must set
+#' their working directory to the folder containing their raw
+#' data, divided into two subfolders named their desired group labels. The
+#' function will output two chromatograms into the user's working directory, a
+#' base peak intensity chromatogram (BPIC) and a total ion
+#' chromatogram (TIC). Further, this function sets the number of cores
+#' to be used for parallel processing. It first determines the number of cores
+#' within a user's computer and then sets it that number/2.
+#' @param foldername Character, input the file path to the folder containing
+#' the raw MS spectra to be processed.
+#' @param mode Character, the data input mode. Default is "onDisk" to avoid memory crash. "inMemory" will
+#' absorb data into the memory.
+#' @param plotSettings List, plotting parameters produced by SetPlotParam Function. "plot.opts" can be added through this
+#' function for samples numbers for plotting. Defalut is "default", "all" will apply all samples for plotting and may cause
+#' memory crash, especially for large sample dataset.
+#' @author Zhiqiang Pang \email{zhiqiang.pang@mail.mcgill.ca}, Jasmine Chong \email{jasmine.chong@mail.mcgill.ca},
+#' Mai Yamamoto \email{yamamoto.mai@mail.mcgill.ca}, and Jeff Xia \email{jeff.xia@mcgill.ca}
+#' McGill University, Canada
+#' License: GNU GPL (>= 2)
+#' @export
+#' @import MSnbase
+#' @import BiocParallel
+#' @import parallel
+
+ImportRawMSData <- function(foldername, mode="onDisk", ncores=4, plotSettings){
+
+ msg.vec <<- vector(mode="character")
+
+ msg <- c("The uploaded files are raw MS spectra.");
+
+ # the "upload" folder should contain two subfolders (groups, i.e. Healthy vs. Disease)
+ # each subfolder must contain samples (.mzML/.CDF/.mzXML files)
+
+ files <- dir(foldername, pattern=".mzML|.cdf|.mzXML|.mzData", recursive=T, full.name=TRUE)
+
+ if (length(files) == 0) {
+ AddErrMsg("No spectra were found!");
+ return(0);
+ }
+
+ snames <- gsub("\\.[^.]*$", "", basename(files));
+ msg<-c(msg, paste("A total of ", length(files), "samples were found."));
+
+ sclass <- gsub("^\\.$", "sample", dirname(files));
+
+ scomp <- strsplit(substr(sclass, 1, min(nchar(sclass))), "");
+ scomp <- matrix(c(scomp, recursive = TRUE), ncol = length(scomp));
+ i <- 1
+
+ while(all(scomp[i,1] == scomp[i,-1]) && i < nrow(scomp)){
+ i <- i + 1;
+ }
+
+ i <- min(i, tail(c(0, which(scomp[1:i,1] == .Platform$file.sep)), n = 1) + 1)
+
+ if (i > 1 && i <= nrow(scomp)){
+ sclass <- substr(sclass, i, max(nchar(sclass)))
+ }
+
+ # some sanity check before proceeds
+ sclass <- as.factor(sclass);
+ if(length(levels(sclass))<2){
+ AddErrMsg("You must provide classes labels (at least two classes)!");
+ return(0);
+ }
+
+ SetClass(sclass)
+
+ # check for unique sample names
+ if(length(unique(snames))!=length(snames)){
+ AddErrMsg("Duplicate sample names are not allowed!");
+ dup.nm <- paste(snames[duplicated(snames)], collapse=" ");
+ AddErrMsg("Duplicate sample names are not allowed!");
+ AddErrMsg(dup.nm);
+ return(0);
+ }
+
+ pd <- data.frame(sample_name = snames,
+ sample_group = sclass,
+ stringsAsFactors = FALSE)
+
+ if(!.on.public.web){
+
+ cores <- parallel::detectCores()
+
+ if(missing(ncores)){
+ num_cores <- ceiling(cores*2/3)
+ } else{
+ ncores -> num_cores
+ }
+
+ print(paste0("The number of CPU cores to be used is set to ", num_cores, "."))
+
+ if (.Platform$OS.type == "unix") {
+ BiocParallel::register(BiocParallel::bpstart(BiocParallel::MulticoreParam(num_cores)))
+ } else { # for windows
+ BiocParallel::register(BiocParallel::bpstart(BiocParallel::SnowParam(num_cores)))
+ }
+
+ }
+
+ raw_data <- suppressMessages(readMSData(files = files, pdata = new("NAnnotatedDataFrame", pd),
+ mode = mode, msLevel =1))
+
+
+ if(plotSettings$Plot==TRUE){
+
+ if (is.null(plotSettings$plot.opts)){
+ plot.opts <- "default";
+ } else {
+ plot.opts <- plotSettings$plot.opts;
+ }
+
+ if(plot.opts=="default"){
+ #subset raw_data to first 50 samples
+ print("To reduce memory usage BPIS and TICS plots will be created using only 10 samples per group.")
+
+ grp_nms <- names(table(pd$sample_group))
+ files <- NA
+
+ for(i in 1:length(grp_nms)){
+ numb2ext <- min(table(pd$sample_group)[i], 10)
+ filt_df <- pd[pd$sample_group==grp_nms[i],]
+ files.inx <- sample(nrow(filt_df), numb2ext)
+ sel.samples <- filt_df$sample_name[files.inx]
+ files <- c(files, which(pd$sample_name %in% sel.samples))
+ }
+
+ raw_data_filt <- filterFile(raw_data, file=na.omit(files));
+
+ }else{
+
+ raw_data_filt <- raw_data; # just for plotting
+
+ }
+
+ if(plot.opts=="all"){
+ h <- readline(prompt="Using all samples to create BPIS and TICS plots may cause severe memory issues! Press [0] to continue, or [1] to cancel: ")
+ h <- as.integer(h)
+ if(h==1){
+ print("ImportRawMSData function aborted!")
+ return(0)
+ }
+ }
+
+ print("Plotting BPIS and TICS.")
+
+ # Plotting functions to see entire chromatogram
+ bpis <- chromatogram(raw_data_filt, aggregationFun = "max")
+ tics <- chromatogram(raw_data_filt, aggregationFun = "sum")
+
+ groupNum <- nlevels(groupInfo)
+
+ if(groupNum > 9){
+ col.fun <- grDevices::colorRampPalette(RColorBrewer::brewer.pal(12, "Set3"))
+ group_colors <- col.fun(groupNum)
+ }else{
+ group_colors <- paste0(RColorBrewer::brewer.pal(9, "Set1")[1:groupNum], "60")
+ }
+
+ names(group_colors) <- levels(groupInfo)
+
+ bpis_name <- paste("BPIS_", plotSettings$dpi, ".", plotSettings$format, sep="");
+ tics_name <- paste("TICS_", plotSettings$dpi, ".", plotSettings$format, sep="");
+
+ Cairo::Cairo(file = bpis_name, unit="in", dpi=plotSettings$dpi, width=plotSettings$width,
+ height= plotSettings$width*5/9, type=plotSettings$format, bg="white");
+
+ plot(bpis, col = group_colors[raw_data_filt$sample_group])
+ legend("topright", legend=levels(groupInfo), pch=15, col=group_colors);
+
+ dev.off();
+
+ Cairo::Cairo(file = tics_name, unit="in", dpi=plotSettings$dpi, width=plotSettings$width,
+ height=plotSettings$width*5/9, type=plotSettings$format, bg="white");
+
+ plot(tics, col = group_colors[raw_data_filt$sample_group])
+ legend("topright", legend=levels(groupInfo), pch=15, col=group_colors);
+
+ dev.off();
+ }
+
+ print("Successfully imported raw MS data!")
+
+ return(raw_data)
+}
+
+#' Set class information for MS data
+#' @description This function sets the class information
+#' for preprocessing MS data.
+#' @author Jasmine Chong \email{jasmine.chong@mail.mcgill.ca},
+#' Mai Yamamoto \email{yamamoto.mai@mail.mcgill.ca}, and Jeff Xia \email{jeff.xia@mcgill.ca}
+#' McGill University, Canada
+#' License: GNU GPL (>= 2)
+#' @export
+SetClass <- function(class){
+ groupInfo <<- class
+}
+
+#' Plot EIC
+#' @description This functionn creates an extracted ion chromatogram (EIC) for a specific
+#' m/z and retention time. This is used for quality-control of raw m/s data.
+#' @param raw_data The object created using the ImportRawMSData function,
+#' containing the raw MS data.
+#' @param rt_mn Numeric, specify the minimum bound of the retention time range.
+#' @param rt_mx Numeric, specify the maximum bound of the retention time range.
+#' @param mz_mn Numeric, specify the minimum bound of the m/z range.
+#' @param mz_mx Numeric, specify the maximum bound of the m/z range.
+#' @param aggreg Character, if "sum", creates a total ion chromatogram.
+#' If "max", creates a base peak chromatogram. By default it is set
+#' to "sum".
+#' @param format Character, input the format of the image to create.
+#' @param dpi Numeric, input the dpi of the image to create.
+#' @param width Numeric, input the width of the image to create.
+#' @export
+
+PlotEIC <- function(raw_data, rt_mn, rt_mx, mz_mn, mz_mx, aggreg = "sum",
+ format = "png", dpi = 72, width = 9){
+
+ filt_data <- filterRt(raw_data, rt = c(rt_mn, rt_mx))
+ filt_mz <- filterMz(filt_data, mz = c(mz_mn, mz_mx))
+ mz_slice <- chromatogram(filt_mz, aggregationFun = aggreg)
+
+ groupNum <- nlevels(groupInfo)
+
+ if(groupNum > 9){
+ col.fun <- grDevices::colorRampPalette(RColorBrewer::brewer.pal(12, "Set3"))
+ group_colors <- col.fun(groupNum)
+ }else{
+ group_colors <- paste0(RColorBrewer::brewer.pal(9, "Set1")[1:groupNum], "60")
+ }
+
+ names(group_colors) <- unique(raw_data$sample_group)
+
+ eic_name <- paste("EIC_", dpi, ".", format, sep="");
+
+ Cairo::Cairo(file = eic_name, unit="in", dpi=dpi, width=width, height= width*5/9,
+ type=format, bg="white");
+ plot(mz_slice, col = group_colors[raw_data$sample_group])
+ legend("topright", legend=unique(raw_data$sample_group), pch=15, col=group_colors);
+ dev.off();
+
+ print("EIC created!")
+ return(1)
+}
+
+
+#' Perform peak profiling
+#' This function performs feature extraction of user's raw MS data using
+#' the rawData object created using the ImportRawMSData function.
+#' @param rawData The object created using the ImportRawMSData function,
+#' containing the raw MS data.
+#' @param Params The object created using the SetPeakParam function,
+#' containing user's specified or default parameters for downstream
+#' raw MS data pre-processing.
+#' @param plotSettings List, plotting parameters produced by SetPlotParam Function.
+#' Defaut is set to true.
+#' @param ncore Numeric, used to define the cores' number for Peak Profiling.
+#' @author Zhiqiang Pang \email{zhiqiang.pang@mail.mcgill.ca}, Jasmine Chong \email{jasmine.chong@mail.mcgill.ca},
+#' Mai Yamamoto \email{yamamoto.mai@mail.mcgill.ca}, and Jeff Xia \email{jeff.xia@mcgill.ca}
+#' McGill University, Canada
+#' License: GNU GPL (>= 2)
+#' @export
+#' @import stats
+#' @import MSnbase
+#' @import BiocParallel
+#' @import ggplot2
+
+PerformPeakProfiling <- function(rawData, Params, plotSettings, ncore){
+
+ ### Update parameters' style
+ param <- updateRawSpectraParam (Params);
+
+ ### Setting the different parallel method for linux or windows
+ if (missing(ncore)){
+ total_threads <- detectCores()*2/3
+ } else {
+ total_threads <- ncore
+ }
+
+
+ if(.Platform$OS.type=="unix" ){
+ register(bpstart(MulticoreParam(ceiling(total_threads))))
+ } else if(.Platform$OS.type=="windows"){
+ register(bpstart(SnowParam(ceiling(total_threads))))
+ }
+
+ print(paste0(ceiling(total_threads)," CPU Threads will be used for peak profiling !"))
+
+ # ---------===========----- I. Peak picking -----===========------------
+
+ print("Step 1/3: Started peak picking! This step will take some time...")
+
+ mSet <- PerformPeakPicking(rawData, param = param); gc()
+
+ # --------===========----- II. Peak alignment -----===========------------
+
+ print("Step 2/3: Started peak alignment! This step is running...")
+
+ mSet <- PerformPeakAlignment(mSet, param); gc()
+
+ # --------===========----- III. Peak filling -----===========------------
+
+ print("Step 3/3: Started peak filling! This step may take some time...")
+
+ mSet <- PerformPeakFiling (mSet, param); gc()
+
+ print("Peak picking finished successfully !")
+
+
+ # ---------------====------IV. Plotting Results --------========-----------
+
+ sample_idx <- mSet[["onDiskData"]]@phenoData@data[["sample_group"]];
+
+
+ if (missing(plotSettings)){
+ plotSettings <- SetPlotParam(name_peak_in="Peak_Intensity",
+ name_PCA="PCA",
+ name_adj_RT="Adjusted_RT",
+ name_adj_BPI="Adjusted_BPI")
+ } else {
+ plotSettings$name_peak_in="Peak_Intensity";
+ plotSettings$name_PCA="PCA";
+ plotSettings$name_adj_RT="Adjusted_RT";
+ plotSettings$name_adj_BPI="Adjusted_BPI"
+ }
+
+ if (plotSettings$Plot ==T){
+ ### 1. Peak Intensity plotting -----
+ PlotSpectraInsensityStistics(mSet, paste0(plotSettings$name_peak_in,".",plotSettings$format), plotSettings$format, plotSettings$dpi, 8);
+
+ ### 2. PCA plotting -----
+ if (.on.public.web){
+ load_ggplot();
+ }
+
+ PlotSpectraPCA(mSet, paste0(plotSettings$name_PCA,".",plotSettings$format), plotSettings$format, plotSettings$dpi, 8);
+
+ ### 3. Adjusted RT plotting -----
+ PlotSpectraRTadj(mSet, paste0(plotSettings$name_adj_RT,".",plotSettings$format), plotSettings$format, plotSettings$dpi, plotSettings$width);
+
+ ### 4. Chromatogram Generation -----
+ PlotSpectraBPIadj(mSet, paste0(plotSettings$name_adj_BPI,".",plotSettings$format), plotSettings$format, plotSettings$dpi, plotSettings$width)
+
+ }
+
+
+ return(mSet)
+}
+
+#' Set generic Plotting Parameters
+#' @description This function sets the generic Plotting Parameters for different functions
+#' @param Plot Logical, if true, the function will plot internal figures for different functions.
+#' @param labels Logical, if true, the labels in the plot will be added.
+#' @param format Numeric, input the format of the image to create.
+#' @param dpi Numeric, input the dpi of the image to create.
+#' @param width Numeric, input the width of the image to create.
+#' @param ... Other specific parameters for specific function. Please set them according to the corresponding function.
+#' @author Zhiqiang Pang \email{zhiqiang.pang@mail.mcgill.ca}, and Jeff Xia \email{jeff.xia@mcgill.ca}
+#' McGill University, Canada
+#' License: GNU GPL (>= 2)
+#' @export
+
+SetPlotParam<-function(Plot = F, labels = TRUE, format = "png", dpi = 72, width = 9,...){
+
+ return(list(Plot = Plot,
+ labels = labels,
+ format = format,
+ dpi = dpi,
+ width = width,
+ ...))
+}
+
+#' Set annotation parameters
+#' @description This function sets the parameters for peak annotation.
+#' @param polarity Character, specify the polarity of the MS instrument. Either
+#' "negative" or "positive".
+#' @param perc_fwhm Numeric, set the percentage of the width of the FWHM for peak grouping.
+#' Default is set to 0.6.
+#' @param mz_abs_iso Numeric, set the allowed variance for the search (for isotope annotation).
+#' The default is set to 0.005.
+#' @param max_charge Numeric, set the maximum number of the isotope charge. For example,
+#' the default is 2, therefore the max isotope charge is 2+/-.
+#' @param max_iso Numeric, set the maximum number of isotope peaks. For example, the default
+#' is 2, therefore the max number of isotopes per peaks is 2.
+#' @param corr_eic_th Numeric, set the threshold for intensity correlations across samples.
+#' Default is set to 0.85.
+#' @param mz_abs_add Numeric, set the allowed variance for the search (for adduct annotation).
+#' The default is set to 0.001.
+#' @author Jasmine Chong \email{jasmine.chong@mail.mcgill.ca},
+#' Mai Yamamoto \email{yamamoto.mai@mail.mcgill.ca}, and Jeff Xia \email{jeff.xia@mcgill.ca}
+#' McGill University, Canada
+#' License: GNU GPL (>= 2)
+#' @export
+SetAnnotationParam <- function(polarity = "positive", perc_fwhm = 0.6, mz_abs_iso = 0.005,
+ max_charge = 2, max_iso = 2, corr_eic_th = 0.85,
+ mz_abs_add = 0.001){
+
+ annParams <- list()
+
+ annParams$polarity <- polarity
+ annParams$perf.whm <- perc_fwhm
+ annParams$mz.abs.iso <- mz_abs_iso
+ annParams$max.charge <- max_charge
+ annParams$max.iso <- max_iso
+ annParams$corr.eic.th <- corr_eic_th
+ annParams$mz.abs.add <- mz_abs_add
+
+ return(annParams)
+}
+
+#' Perform peak annotation
+#' @description This function performs peak annotation on
+#' the xset object created using the PerformPeakPicking function.
+#' @param xset The object created using the PerformPeakPicking function,
+#' containing the peak picked MS data.
+#' @param annParams The object created using the SetAnnotationParam function,
+#' containing user's specified or default parameters for downstream
+#' raw MS data pre-processing.
+#' @author Zhiqiang Pang \email{zhiqiang.pang@mail.mcgill.ca}, Jasmine Chong \email{jasmine.chong@mail.mcgill.ca},
+#' Mai Yamamoto \email{yamamoto.mai@mail.mcgill.ca}, and Jeff Xia \email{jeff.xia@mcgill.ca}
+#' McGill University, Canada
+#' License: GNU GPL (>= 2)
+#' @export
+#' @import MSnbase
+#' @importFrom graph ftM2graphNEL
+#' @importFrom RBGL highlyConnSG
+#' @references Kuhl C, Tautenhahn R, Boettcher C, Larson TR, Neumann S (2012).
+#' "CAMERA: an integrated strategy for compound spectra extraction and annotation of
+#' liquid chromatography/mass spectrometry data sets." Analytical Chemistry, 84, 283-289.
+#' http://pubs.acs.org/doi/abs/10.1021/ac202450g.
+
+PerformPeakAnnotation <- function(mSet, annotaParam, ncore=1){
+
+ if (ncore > 1){
+ print("Only single core mode is supported now. Parallel will be supported later !")
+ ncore <- 1
+ }
+
+ ## 1. Prepare the Annotation Object-------
+
+ xs <- mSet$xcmsSet
+
+ if(is.null(xs)) {
+ stop("No xcmsSet object in 'mSet' was given !")
+ } else if (!class(xs)=="xcmsSet"){
+ stop("There is correct xcmsSet object in mSet !")
+ }
+
+
+ mSet$AnnotateObject <- list();
+
+ if(length(xs@phenoData[["sample_name"]]) > 1 && !nrow(xs@groups) > 0) {
+ stop ('No group information found or contain only one sample.')
+ }
+ mSet$AnnotateObject$sample <- as.numeric(NA)
+
+ mSet$AnnotateObject$groupInfo <- getPeaks_selection(xs);
+ runParallel <- list()
+ runParallel$enable <- 0;
+
+ if (ncore > 1) {
+ ## If MPI is available ...
+ rmpi = "Rmpi"
+ opt.warn <- options("warn")$warn
+ options("warn" = -1)
+ if ((Sys.info()["sysname"] != "Windows") && require(rmpi,character.only=TRUE) && !is.null(ncore)) {
+ if (is.loaded('mpi_initialize')) {
+ #test if not already slaves are running!
+ if(mpi.comm.size() >0){
+ warning("There are already intialized mpi slaves on your machine.\nCamera will try to uses them!\n");
+ runParallel$enable <-1;
+ runParallel$mode <- rmpi;
+ }else{
+ mpi.spawn.Rslaves(ncore=ncore, needlog=FALSE)
+ if(mpi.comm.size() > 1){
+ #Slaves have successfull spawned
+ runParallel$enable <-1;
+ runParallel$mode <- rmpi;
+ }else{ warning("Spawning of mpi slaves have failed. CAMERA will run without parallelization.\n");}
+ }
+ }else {
+ #And now??
+ warning("DLL mpi_initialize is not loaded. Run single core mode!\n");
+ }
+ } else {
+ #try local sockets using snow package
+ snow = "snow"
+ if (try(require(snow,character.only=TRUE,quietly=TRUE))) {
+ cat("Starting snow cluster with",ncore,"local sockets.\n")
+ snowclust <- makeCluster(ncore, type = "SOCK")
+ runParallel$enable <- 1
+ runParallel$mode <- snow;
+ runParallel$cluster <- snowclust
+ }
+ }
+ options("warn" = opt.warn)
+ cat("Run cleanParallel after processing to remove the spawned slave processes!\n")
+ }
+
+ if(!is.null(annotaParam[["polarity"]])){
+ if(is.na(match.arg(annotaParam[["polarity"]], c("positive","negative")))){
+ stop("Parameter polarity has to be 'positive' or 'negative' !")
+ }else{
+ mSet$AnnotateObject$polarity <- annotaParam[["polarity"]];
+ }
+ }
+ mSet$AnnotateObject$runParallel<-runParallel;
+
+ mSet$AnnotateObject$annoID <- matrix(ncol=4, nrow=0)
+ mSet$AnnotateObject$annoGrp <- matrix(ncol=4, nrow=0)
+ mSet$AnnotateObject$isoID <- matrix(ncol=4, nrow=0)
+
+ colnames(mSet$AnnotateObject$annoID) <- c("id","grpID","ruleID","parentID");
+ colnames(mSet$AnnotateObject$annoGrp)<- c("id","mass","ips","psgrp");
+ colnames(mSet$AnnotateObject$isoID) <- c("mpeak","isopeak","iso","charge")
+
+ ## 2. Group peaks according to their retention time into pseudospectra-groups-----
+
+ intval <- "maxo"; perfwhm <- annotaParam$perf.whm; sigma <- 6;
+
+ sample <- mSet$AnnotateObject$sample;
+ pspectra <- list();
+ psSamples <- NA;
+
+ print("Start grouping after retention time.")
+
+ if(mSet$AnnotateObject$groupInfo[1, "rt"] == -1) {
+ # Like FTICR Data
+ warning("Warning: no retention times avaiable. Do nothing\n");
+ return(invisible(mSet$AnnotateObject));
+ }else{
+ if(is.na(sample[1]) || length(mSet$xcmsSet@filepaths) > 1) {
+ # grouped peaktable within automatic selection or sub selection
+ if(is.na(sample[1])){
+ index <- 1:length(mSet$xcmsSet@filepaths);
+ }else{
+ index <- sample;
+ }
+
+ gvals <- groupval(mSet$xcmsSet)[,index,drop=FALSE];
+ peakmat <- mSet$xcmsSet@peaks;
+ groupmat <- mSet$xcmsSet@groups;
+
+ #calculate highest peaks
+ maxo <- as.numeric(apply(gvals, 1, function(x, peakmat){
+ val <- na.omit(peakmat[x, intval]);
+ if(length(val) == 0){
+ return(NA);
+ }else{
+ return(max(val))
+ }
+ }, peakmat));
+
+ maxo[which(is.na(maxo))] <- -1;
+ maxo <- cbind(1:length(maxo),maxo);
+
+ #highest peak index
+ int.max <- as.numeric(apply(gvals, 1, function(x, peakmat){which.max(peakmat[x, intval])}, peakmat));
+
+ peakrange <- matrix(apply(gvals, 1, function(x, peakmat) {
+ val <- peakmat[x, intval];
+ if(length(na.omit(val)) == 0){
+ return(c(0,1));
+ } else {
+ return(peakmat[x[which.max(val)], c("rtmin", "rtmax")]);
+ }
+ }, peakmat), ncol=2, byrow=TRUE);
+
+ colnames(peakrange) <- c("rtmin", "rtmax")
+
+ while(length(maxo) > 0){
+ iint <- which.max(maxo[,2]);
+ rtmed <- groupmat[iint, "rtmed"]; #highest peak in whole spectra
+ rt.min <- peakrange[iint, "rtmin"];
+ rt.max <- peakrange[iint, "rtmax"]; #begin and end of the highest peak
+ hwhm <- ((rt.max-rt.min) / sigma * 2.35 * perfwhm) / 2; #fwhm of the highest peak
+ #all other peaks whose retensiontimes are in the fwhm of the highest peak
+ irt <- which(groupmat[, 'rtmed'] > (rtmed-hwhm) & groupmat[, 'rtmed'] < (rtmed + hwhm))
+ if(length(irt) > 0){
+ #if peaks are found
+ idx <- maxo[irt,1];
+ pspectra[[length(pspectra)+1]] <- idx; #create groups
+ psSamples[length(pspectra)] <- index[int.max[maxo[iint,1]]] # saves the sample of the peak which is in charge for this pspectrum
+ maxo <- maxo[-irt, ,drop=FALSE]; #set itensities of peaks to NA, due to not to be found in the next cycle
+ groupmat <- groupmat[-irt, ,drop=FALSE];
+ peakrange <- peakrange[-irt, ,drop=FALSE];
+ }else{
+ idx <- maxo[iint,1];
+ cat("Warning: Feature ",idx," looks odd for at least one peak. Please check afterwards.\n");
+ pspectra[[length(pspectra)+1]] <- idx; #create groups
+ psSamples[length(pspectra)] <- index[int.max[maxo[iint,1]]] # saves the sample of the peak which is in charge for this pspectrum
+ maxo <- maxo[-iint, ,drop=FALSE]; #set itensities of peaks to NA, due to not to be found in the next cycle
+ groupmat <- groupmat[-iint, ,drop=FALSE];
+ peakrange <- peakrange[-iint, ,drop=FALSE];
+ }
+ }
+
+ }else{
+ #One sample experiment
+ peakmat <- mSet$xcmsSet@peaks;
+ maxo <- peakmat[, intval]; #max intensities of all peaks
+ maxo <- cbind(1:length(maxo),maxo);
+
+ while(length(maxo)> 0){
+ iint <- which.max(maxo[,2]);
+ rtmed <- peakmat[iint, "rt"]; #highest peak in whole spectra
+ rt.min <- peakmat[iint, "rtmin"];
+ rt.max <- peakmat[iint, "rtmax"]; #begin and end of the highest peak
+ hwhm <- ((rt.max - rt.min) / sigma * 2.35 * perfwhm) / 2; #fwhm of the highest peak
+ #all other peaks whose retensiontimes are in the fwhm of the highest peak
+ irt <- which(peakmat[, 'rt'] > (rtmed - hwhm) & peakmat[, 'rt'] < (rtmed + hwhm))
+ if(length(irt)>0){
+ #if peaks are found
+ idx <- maxo[irt,1];
+ pspectra[[length(pspectra)+1]] <- idx; #create groups
+ maxo <- maxo[-irt, ,drop=FALSE]; #set itensities of peaks to NA, due to not to be found in the next cycle
+ peakmat <- peakmat[-irt, ,drop=FALSE];
+ }else{
+ idx <- maxo[iint,1];
+ cat("Warning: Feature ",idx," looks odd for at least one peak. Please check afterwards.\n");
+ pspectra[[length(pspectra)+1]] <- idx; #create groups
+ maxo <- maxo[-iint, ,drop=FALSE]; #set itensities of peaks to NA, due to not to be found in the next cycle
+ peakmat <- peakmat[-iint, ,drop=FALSE];
+ }
+ }
+ psSamples <- rep(sample, length(pspectra))
+ }
+
+ mSet$AnnotateObject$pspectra <- pspectra;
+ mSet$AnnotateObject$psSamples <- psSamples;
+ message (paste("Created", length(mSet$AnnotateObject$pspectra), "pseudospectra."))
+ }
+
+
+ ## 3. Annotate isotope peaks -----
+
+ maxcharge <- annotaParam$max.charge; maxiso <- annotaParam$max.iso;
+ mzabs <- annotaParam$mz.abs.add; intval=c("maxo");
+ minfrac=0.5; isotopeMatrix=NULL; filter=TRUE; ppm <- 5;
+
+ if(!is.wholenumber(maxcharge) || maxcharge < 1){
+ stop("Invalid argument 'maxcharge'. Must be integer and > 0.\n")
+ }
+ if(!is.wholenumber(maxiso) || maxiso < 1){
+ stop("Invalid argument 'maxiso'. Must be integer and > 0.\n")
+ }
+ if(!is.numeric(mzabs) || mzabs < 0){
+ stop("Invalid argument 'mzabs'. Must be numeric and not negative.\n")
+ }
+
+ #intval <- match.arg(intval)
+
+ if(!is.null(isotopeMatrix)){
+ if(!is.matrix(isotopeMatrix) || ncol(isotopeMatrix) != 4 || nrow(isotopeMatrix) < 1
+ || !is.numeric(isotopeMatrix)){
+ stop("Invalid argument 'isotopeMatrix'. Must be four column numeric matrix.\n")
+ } else {
+ colnames(isotopeMatrix) <- c("mzmin", "mzmax", "intmin", "intmax")
+ }
+ }else if(maxiso > 8){
+ stop("Invalid argument 'maxiso'. Must be lower 9 or provide your own isotopeMatrix.\n")
+ }else{
+ isotopeMatrix <- calcIsotopeMatrix(maxiso=maxiso)
+ }
+ ####End Test arguments
+
+ npeaks.global <- 0; #Counter for % bar
+ npspectra <- length(mSet$AnnotateObject$pspectra);
+
+ # scaling
+ devppm <- ppm / 1000000;
+ filter <- filter;
+ #generate parameter list
+ params <- list(maxiso=maxiso, maxcharge=maxcharge, devppm=devppm,
+ mzabs=mzabs, IM=isotopeMatrix, minfrac=minfrac, filter=filter)
+
+ #Check if object have been preprocessed with groupFWHM
+ if(npspectra < 1) {
+ cat("xsAnnotate contains no pseudospectra. Regroup all peaks into one!\n")
+ npspectra <- 1;
+ mSet$AnnotateObject$pspectra[[1]] <- seq(1:nrow(mSet$AnnotateObject$groupInfo));
+ mSet$AnnotateObject$psSamples <- 1;
+ }
+
+ #number of peaks in pseudospectra
+ ncl <- sum(sapply(mSet$AnnotateObject$pspectra, length));
+
+ # get mz,rt and intensity values from peaktable
+ if(nrow(mSet$xcmsSet@groups) > 0){
+ ##multiple sample or grouped single sample
+ if(is.na(mSet$AnnotateObject$sample[1])){
+ index <- 1:length(mSet$xcmsSet@filepaths);
+ }else{
+ index <- mSet$AnnotateObject$sample;
+ }
+ message("Generating peak matrix...");
+ mint <- groupval(mSet$xcmsSet,value=intval)[,index,drop=FALSE];
+ imz <- mSet$AnnotateObject$groupInfo[, "mz", drop=FALSE];
+ irt <- mSet$AnnotateObject$groupInfo[, "rt", drop=FALSE];
+ }else{
+ ##one sample case
+ message("Generating peak matrix...");
+ imz <- mSet$AnnotateObject$groupInfo[, "mz", drop=FALSE];
+ irt <- mSet$AnnotateObject$groupInfo[, "rt", drop=FALSE];
+ mint <- mSet$AnnotateObject$groupInfo[, intval, drop=FALSE];
+ }
+
+ isotope <- vector("list", length(imz));
+
+ isomatrix <- matrix(ncol=5, nrow=0);
+ colnames(isomatrix) <- c("mpeak", "isopeak", "iso", "charge", "intrinsic")
+
+
+ message("Run isotope peak annotation");
+
+ lp <- -1;along = mSet$AnnotateObject$pspectra;
+ pb <- progress_bar$new(format = "Isotope [:bar] :percent Time left: :eta", total = length(along), clear = T, width= 75)
+
+ #look for isotopes in every pseudospectra
+ for(i in seq(along)){
+ #get peak indizes for i-th pseudospectrum
+ ipeak <- mSet$AnnotateObject$pspectra[[i]];
+
+ #Ouput counter
+ pb$tick();
+
+ #Pseudospectrum has more than one peak
+ if(length(ipeak) > 1){
+ #peak mass and intensity for pseudospectrum
+ mz <- imz[ipeak];
+ int <- mint[ipeak, , drop=FALSE];
+ isomatrix <- findIsotopesPspec(isomatrix, mz, ipeak, int, params)
+ }
+ }
+
+ #clean isotopes
+ if(is.null(nrow(isomatrix))) {
+ isomatrix = matrix(isomatrix, byrow=F, ncol=length(isomatrix))
+ }
+
+ #check if every isotope has only one annotation
+ if(length(idx.duplicated <- which(duplicated(isomatrix[, 2]))) > 0){
+ peak.idx <- unique(isomatrix[idx.duplicated, 2]);
+ for( i in 1:length(peak.idx)){
+ #peak.idx has two or more annotated charge
+ #select the charge with the higher cardinality
+ peak <- peak.idx[i];
+ peak.mono.idx <- which(isomatrix[,2] == peak)
+ if(length(peak.mono.idx) < 2){
+ #peak has already been deleted
+ next;
+ }
+ peak.mono <- isomatrix[peak.mono.idx,1]
+ #which charges we have
+ charges.list <- isomatrix[peak.mono.idx, 4];
+ tmp <- cbind(peak.mono,charges.list);
+ charges.length <- apply(tmp,1, function(x,isomatrix) {
+ length(which(isomatrix[, 1] == x[1] & isomatrix[,4] == x[2])) },
+ isomatrix);
+ idx <- which(charges.length == max(charges.length));
+ if(length(idx) == 1){
+ #max is unique
+ isomatrix <- isomatrix[-which(isomatrix[, 1] %in% peak.mono[-idx] & isomatrix[, 4] %in% charges.list[-idx]),, drop=FALSE]
+ }else{
+ #select this one, which lower charge
+ idx <- which.min(charges.list[idx]);
+ isomatrix <- isomatrix[-which(isomatrix[, 1] %in% peak.mono[-idx] & isomatrix[, 4] %in% charges.list[-idx]),, drop=FALSE]
+ }
+ }
+ }
+
+
+ #check if every isotope in one isotope grp, have the same charge
+ if(length(idx.duplicated <- which(duplicated(paste(isomatrix[, 1], isomatrix[, 3])))) > 0){
+ #at least one pair of peakindex and number of isotopic peak is identical
+ peak.idx <- unique(isomatrix[idx.duplicated,1]);
+ for( i in 1:length(peak.idx)){
+ #peak.idx has two or more annotated charge
+ #select the charge with the higher cardinality
+ peak <- peak.idx[i];
+ #which charges we have
+ charges.list <- unique(isomatrix[which(isomatrix[, 1] == peak), 4]);
+ #how many isotopes have been found, which this charges
+ charges.length <- sapply(charges.list, function(x,isomatrix,peak) { length(which(isomatrix[, 1] == peak & isomatrix[, 4] == x)) },isomatrix,peak);
+ #select the charge which the highest cardinality
+ idx <- which(charges.length == max(charges.length));
+ if(length(idx) == 1){
+ #max is unique
+ isomatrix <- isomatrix[-which(isomatrix[, 1] == peak & isomatrix[, 4] %in% charges.list[-idx]),, drop=FALSE]
+ }else{
+ #select this one, which lower charge
+ idx <- which.min(charges.list[idx]);
+ isomatrix <- isomatrix[-which(isomatrix[, 1] == peak & isomatrix[, 4] %in% charges.list[-idx]),, drop=FALSE]
+ }
+ }
+ }
+
+ #Combine isotope cluster, if they overlap
+ index2remove <- c();
+
+ if(length(idx.duplicated <- which(isomatrix[, 1] %in% isomatrix[, 2]))>0){
+ for(i in 1:length(idx.duplicated)){
+ index <- which(isomatrix[, 2] == isomatrix[idx.duplicated[i], 1])
+ index2 <- sapply(index, function(x, isomatrix) which(isomatrix[, 1] == isomatrix[x, 1] & isomatrix[,3] == 1),isomatrix)
+ if(length(index2) == 0){
+ index2remove <- c(index2remove,idx.duplicated[i])
+ }
+ max.index <- which.max(isomatrix[index,4]);
+ isomatrix[idx.duplicated[i], 1] <- isomatrix[index[max.index], 1];
+ isomatrix[idx.duplicated[i], 3] <- isomatrix[index[max.index], 3]+1;
+ }
+ }
+
+ if(length(index <- which(isomatrix[,"iso"] > maxiso)) > 0){
+ index2remove <- c(index2remove, index)
+ }
+
+ if(length(index2remove) > 0){
+ isomatrix <- isomatrix[-index2remove,, drop=FALSE];
+ }
+
+ isomatrix <- isomatrix[order(isomatrix[,1]),,drop=FALSE]
+ #Create isotope matrix within object
+ mSet$AnnotateObject$isoID <- matrix(nrow=0, ncol=4);
+ colnames(mSet$AnnotateObject$isoID) <- c("mpeak", "isopeak", "iso", "charge");
+
+ #Add isomatrix to object
+ mSet$AnnotateObject$isoID <- rbind(mSet$AnnotateObject$isoID, isomatrix[, 1:4]);
+
+ # counter for isotope groups
+ globalcnt <- 0;
+ oldnum <- 0;
+
+ if(nrow(isomatrix) > 0){
+ for( i in 1:nrow(isomatrix)){
+ if(!isomatrix[i, 1] == oldnum){
+ globalcnt <- globalcnt+1;
+ isotope[[isomatrix[i, 1]]] <- list(y=globalcnt, iso=0, charge=isomatrix[i, 4], val=isomatrix[i, 5]);
+ oldnum <- isomatrix[i, 1];
+ };
+ isotope[[isomatrix[i,2]]] <- list(y=globalcnt,iso=isomatrix[i,3],charge=isomatrix[i,4],val=isomatrix[i,5]);
+ }
+ }
+ cnt<-nrow(mSet$AnnotateObject$isoID);
+ cat("\nFound isotopes:",cnt,"\n");
+ mSet$AnnotateObject$isotopes <- isotope;
+
+
+ ## 4. Peak grouping with information -----
+
+ cor_eic_th <- annotaParam$corr.eic.th;
+ cor_exp_th <- 0.75; pval=0.05; graphMethod="hcs"
+ calcIso = FALSE; calcCaS = FALSE; psg_list=NULL; xraw=NULL; intval="into"
+
+
+ if (!is.numeric(cor_eic_th) || cor_eic_th < 0 || cor_eic_th > 1){
+ stop ("Parameter cor_eic_th must be numeric and between 0 and 1.\n");
+ }
+
+ npspectra <- length(mSet$AnnotateObject$pspectra);
+
+ print("Start grouping after correlation.")
+ #Data is not preprocessed with groupFWHM
+ if(npspectra < 1){
+ cat("Data was not preprocessed with groupFWHM, creating one pseudospectrum with all peaks.\n")
+ #Group all peaks into one group
+ npspectra <- 1;
+ mSet$AnnotateObject$pspectra[[1]] <- seq(1:nrow(mSet$AnnotateObject$groupInfo));
+ if(is.na(mSet$AnnotateObject$sample[1])){
+ mSet$AnnotateObject$psSamples <- rep(1,nrow(mSet$AnnotateObject$groupInfo)); ##TODO: Change if sample=NA or sample=number
+ }else{
+ mSet$AnnotateObject$psSamples <- rep(mSet$AnnotateObject$sample,nrow(mSet$AnnotateObject$groupInfo));
+ }
+ }
+
+ #save number of pspectra before groupCorr
+ cnt <- length(mSet$AnnotateObject$pspectra);
+ res <- list();
+
+ # Check LC information and calcCorr was selected
+
+ #Autoselect sample path for EIC correlation
+ index <- rep(0, nrow(mSet$AnnotateObject$groupInfo));
+
+ for(i in 1:npspectra){
+ index[mSet$AnnotateObject$pspectra[[i]]] <- mSet$AnnotateObject$psSamples[[i]];
+ }
+
+ #Generate EIC data
+
+ tmp <- getAllPeakEICs(mSet, index=index);
+
+ EIC <- tmp$EIC
+
+ scantimes <- tmp$scantimes
+ rm(tmp);gc()
+
+ res[[1]] <- calcCiS(mSet, EIC=EIC,
+ corval=cor_eic_th,
+ pval=pval,
+ psg_list=psg_list);
+
+ #Check if we have at least 2 result matrixes
+ if(length(res) > 2){
+ #combine the first two to create the result Table
+ resMat <- combineCalc(res[[1]], res[[2]], method="sum");
+ for( i in 3:length(res)){
+ resMat <- combineCalc(resMat, res[[i]], method="sum");
+ }
+ }else if(length(res) == 2){
+ #combine one time
+ resMat <- combineCalc(res[[1]], res[[2]], method="sum")
+ } else {
+ #Only one matrix
+ resMat <- res[[1]];
+ }
+
+ #Perform graph seperation to seperate co-eluting pseudospectra
+ mSet <- calcPC.hcs(mSet, ajc=resMat, psg_list=psg_list);
+
+ #Create pc groups based on correlation results
+ message (paste("mSet has now", length(mSet$AnnotateObject$pspectra), "groups, instead of", cnt, "!"));
+
+ ## 5. Annotate adducts (and fragments) -----
+ mSet$AnnotateObject$ruleset <- NULL
+ mSet <- findAdducts (mSet, polarity = annotaParam$polarity, mzabs = annotaParam$mz.abs.add,
+ maxcharge = annotaParam$max.charge)
+
+ ## 6. Data Organization -----
+ camera_output <- getPeaklist(mSet)
+
+ sample_names <- mSet$xcmsSet@phenoData[[1]]
+ sample_names_ed <- gsub(".mzML|.CDF|.mzXML", "", sample_names)
+
+ # Account for multiple groups
+ length <- ncol(camera_output)
+ end <- length-3
+ camnames <- colnames(camera_output)
+ groupNum <- nlevels(mSet[["xcmsSet"]]@phenoData[["sample_group"]])
+ start <- groupNum+8
+ camnames[start:end] <- sample_names_ed
+ colnames(camera_output) <- camnames
+
+ endGroup <- 7+groupNum
+ camera_output <- camera_output[,-c(7:endGroup)]
+
+ saveRDS(camera_output, "annotated_peaklist.rds")
+ write.csv(camera_output, "annotated_peaklist.csv")
+
+ message("Successfully performed peak annotation!")
+
+ ## 0. Final Output -----
+
+ return(mSet)
+
+}
+
+#' Format Peak List
+#' @description This function formats the CAMERA output to a usable format for MetaboAanlyst.
+#' @param annotPeaks The object created using the PerformPeakAnnotation.
+#' @param annParams The object created using the SetAnnotationParam function,
+#' containing user's specified or default parameters for downstream
+#' raw MS data pre-processing.
+#' @param filtIso Logical, filter out all isotopes except for [M]+ for
+#' positive ion mode and [M]- for negative ion mode. By default it is
+#' set to true.
+#' @param filtAdducts Logical, filter out all adducts except [M+H]+ for
+#' positive ion more and [M-H]- for negative ion mode. By default it is set to false.
+#' @param missPercent Numeric, specify the threshold to remove features
+#' missing in X\% of samples. For instance, 0.5 specifies to remove features
+#' that are missing from 50\% of all samples per group. Method is only valid
+#' when there are two groups.
+#' @param includeRT Logical, set to TRUE to include retention time information in
+#' the feature names. Feature names must be formatted
+#' so that the mz and retention time for a single peak is separated by two
+#' underscores. For instance, m/z of 410.2148 and retention time of 42.46914 seconds
+#' must be formatted as 410.2148__42.46914.
+#' @author Jasmine Chong \email{jasmine.chong@mail.mcgill.ca},
+#' Mai Yamamoto \email{yamamoto.mai@mail.mcgill.ca}, and Jeff Xia \email{jeff.xia@mcgill.ca}
+#' McGill University, Canada
+#' License: GNU GPL (>= 2)
+#' @export
+
+FormatPeakList <- function(annotPeaks, annParams, filtIso = TRUE, filtAdducts = FALSE,
+ missPercent = 0.5, includeRT = TRUE){
+
+ camera_output <- readRDS("annotated_peaklist.rds")
+
+ length <- ncol(camera_output)
+ end <- length-3
+
+ # Format peaklist for MetaboAnalyst
+ camera_ma <- camera_output[, -length]
+
+ if(filtAdducts==TRUE){
+ if(annParams$polarity=="positive"){
+
+ if(filtIso==TRUE){
+ camera_isotopes <- camera_ma[grepl("\\[M\\]\\+", camera_ma$isotopes),]
+ }else{
+ camera_isotopes <- camera_ma[(camera_ma$isotopes != ""),]
+ }
+ camera_adducts <- camera_ma[grepl("\\[M\\+H\\]\\+", camera_ma$adduct),]
+ camera_feats <- camera_ma[(camera_ma$isotopes == "" & camera_ma$adduct == ""),]
+ unique_feats <- unique(rbind(camera_isotopes, camera_adducts, camera_feats))
+
+ }else{ # negative polarity
+ if(filtIso==TRUE){
+ camera_isotopes <- camera_ma[grepl("\\[M\\]-", camera_ma$isotopes),]
+ }else{
+ camera_isotopes <- camera_ma[(camera_ma$isotopes != ""),]
+ }
+ camera_adducts <- camera_ma[grepl("\\[M-H\\]-", camera_ma$adduct),]
+ camera_feats <- camera_ma[(camera_ma$isotopes == "" & camera_ma$adduct == ""),]
+ unique_feats <- unique(rbind(camera_isotopes, camera_adducts, camera_feats))
+ }
+ }else{
+ if(annParams$polarity=="positive"){
+
+ if(filtIso==TRUE){
+ camera_isotopes <- camera_ma[grepl("\\[M\\]\\+", camera_ma$isotopes),]
+ }else{
+ camera_isotopes <- camera_ma[(camera_ma$isotopes != ""),]
+ }
+ camera_adducts <- camera_ma[(camera_ma$adduct != ""),]
+ camera_feats <- camera_ma[(camera_ma$isotopes == ""),]
+ unique_feats <- unique(rbind(camera_isotopes, camera_adducts, camera_feats))
+
+ }else{ # negative polarity
+
+ if(filtIso==TRUE){
+ camera_isotopes <- camera_ma[grepl("\\[M\\]-", camera_ma$isotopes),]
+ }else{
+ camera_isotopes <- camera_ma[(camera_ma$isotopes != ""),]
+ }
+ camera_adducts <- camera_ma[(camera_ma$adduct != ""),]
+ camera_feats <- camera_ma[(camera_ma$isotopes == ""),]
+ unique_feats <- unique(rbind(camera_isotopes, camera_adducts, camera_feats))
+ }
+ }
+
+ # adjust decimal places, feats_info contains all samples
+ feats_info <- unique_feats[,7:end]
+ feats_digits <- round(feats_info, 5)
+
+ group_info <- annotPeaks$xcmsSet@phenoData[[2]]
+ combo_info <- rbind(as.character(group_info), feats_digits)
+
+ mzs_rd <- round(unique_feats[,1], 5)
+
+ if(includeRT){
+ r_rd <- round(unique_feats[,4], 5)
+ mz_rt <- paste(mzs_rd, r_rd, sep="__")
+ mzs <- data.frame(c("Label", mz_rt), stringsAsFactors = FALSE)
+ }else{
+ mzs <- data.frame(c("Label", mzs_rd), stringsAsFactors = FALSE)
+ # ensure features are unique
+ mzs_unq <- mzs[duplicated(mzs),]
+ while(length(mzs_unq)>0){
+ mzs[duplicated(mzs),] <- sapply(mzs_unq, function(x) paste0(x, sample(1:999, 1, replace = FALSE)));
+ mzs_unq <- mzs[duplicated(mzs),]
+ }
+ }
+
+ colnames(mzs) <- "Sample"
+ ma_feats <- cbind(mzs, combo_info)
+
+ # remove features missing in over X% of samples per group
+ # only valid for 2 group comparisons!!
+ ma_feats_miss <- ma_feats[which(rowMeans(is.na(ma_feats[,(ma_feats[1,]==as.character(unique(group_info[1])))]))
+ | rowMeans(is.na(ma_feats[,(ma_feats[1,]==as.character(unique(group_info[2])))])) < missPercent), ]
+
+ write.csv(ma_feats_miss, "metaboanalyst_input.csv", row.names = FALSE)
+
+ # provide index for CAMERA output
+ Pklist_inx <- row.names(ma_feats_miss)
+ ma_feats_miss_inx <- cbind(ma_feats_miss, Pklist_inx)
+
+ write.csv(ma_feats_miss_inx, "filtered_peaklist.csv", row.names = FALSE)
+
+ return(ma_feats_miss)
+}
+
+#' Centroid MS data
+#' @description This function is used to centorid different MS data (specially designed for .CDF/.cdf, other formats are also supported).
+#' ProteoWizard (PMID: 27186799) based on docker is optional but strongly suggested to be installed. Current user of the docker also
+#' need to be added into thte sudo list to make it configured well to this function.
+#' @param in_path Character, the path of your MS data folder, only
+#' one format should be included in the folder. If you have different kinds of formats,
+#' please separate them into different folder and do this centroid multiple times.
+#' @param ncore Numeric, how many cores you want to use for data centroid, default is 1.
+#' @param rm logic, to remove the original data (TRUE) or not (FALSE, default).
+#' @author Zhiqiang Pang \email{zhiqiang.pang@mail.mcgill.ca},
+#' @export
+CentroidMSData <- function(in_path, ncore=1, rm=F) {
+
+ files.list <- list.files(in_path,full.names = T,recursive = T);
+
+ if (MSnbase:::isCdfFile(files.list)) {
+
+ if (ncore ==1){
+
+ files.list2 <- NULL;
+ for(i in files.list){
+
+ profile_data <- read.InMemMSd.data(i, NULL, 1, F, NA, 1);
+ fileNM <- sub(pattern = "(.*)\\..*$", replacement = "\\1", basename(i));
+ filepath <- strsplit(i, basename(i))[[1]][1];
+ files.mzml <- paste0(in_path, fileNM, ".mzML");
+ writeMSData(profile_data, file = files.mzml);
+ files.list2 <- c(files.list2,files.mzml);
+
+ }
+
+ } else {
+ files.list2 <- NULL; require(BiocParallel);require(progress)
+ files.list2 <- BiocParallel::bplapply(files.list,FUN = function(i, in_path){
+
+ profile_data <- read.InMemMSd.data(i, NULL, 1, NA, NA, 1);
+ fileNM <- sub(pattern = "(.*)\\..*$", replacement = "\\1", basename(i));
+ filepath <- strsplit(i, basename(i))[[1]][1];
+ files.mzml <- paste0(in_path, fileNM, ".mzML");
+ writeMSData(profile_data, file = files.mzml);
+ return(files.mzml);
+
+ },BPPARAM = MulticoreParam(workers = ncore), in_path = in_path)
+
+ }
+ files.list2 <- unlist(files.list2);
+
+ ## MS convert with ProteoWizard !
+ MSConvert_CMD <- paste0("docker run --rm -e WINEDEBUG=-all -v ",
+ in_path,
+ ":/data chambm/pwiz-skyline-i-agree-to-the-vendor-licenses wine msconvert ",
+ "*.mzML",
+ " --mzXML --filter 'peakPicking true 1-' --filter 'zeroSamples removeExtra' --filter 'msLevel 1' --64 --zlib")
+
+ a1<-tryCatch(system(MSConvert_CMD), error = function(e){e})
+
+ ## Remove the old or cache files
+ if(a1==0 & rm){
+
+ rm_CMD <- paste0("rm -rf ", c(files.list, files.list2))
+ sapply(rm_CMD, FUN=function(x){system(x)});
+
+ ## mv the converted files to their corresponding folder
+ files.list.converted <- list.files(in_path,full.names = T,recursive = T);
+ for (j in 1:length(files.list.converted)){
+
+ if(sub(pattern = "(.*)\\..*$", replacement = "\\1", basename(files.list[j])) ==
+ sub(pattern = "(.*)\\..*$", replacement = "\\1", basename(files.list.converted[j]))){
+
+ if(basename(strsplit(files.list[j], basename(files.list[j]))[[1]][1]) !=
+ basename(strsplit(files.list.converted[j], basename(files.list.converted[j]))[[1]][1])){
+
+ file_des_folder <- basename(strsplit(files.list[j], basename(files.list[j]))[[1]][1]);
+ mv_cmd <- paste0("mv ", files.list.converted[j]," ",in_path, "/", file_des_folder);
+ system(mv_cmd);
+ }
+
+ }
+
+ }
+
+
+ } else if (a1!=0){
+
+ print("There is some issues for MetaboAnalystR to start \"ProteoWizard\", please check following points:")
+ print("1.Installation of Docker and Proteowizard, if not please refer to: http://proteowizard.sourceforge.net/download.html;");
+ print("2.Set docker to the sudoer group list, please refer to: https://docs.docker.com/engine/install/linux-postinstall/;");
+ print("3.The file format has to be one of the .raw, .RAW, .wiff, .mzXML. .mzML, .d, .D, .mzData or .CDF, zipped files are not supported");
+ print("4.If issues still please use ProteoWizard directly with the files generated by this function;");
+
+ }
+
+
+ } else {
+
+ if (length(unique(sapply(files.list, FUN=function(x){tail(strsplit(basename(x), split="\\.")[[1]],1)}))) !=1){
+ stop("Cannot handle multiple formats at the same time !")
+ } else {
+ format <- unique(sapply(files.list, FUN=function(x){tail(strsplit(basename(x), split="\\.")[[1]],1)}));
+ }
+
+ if (!dir.exists(in_path)){stop("Please Provide the right MS folder path !")}
+ ## MS convert with ProteoWizard !
+ if(format == "mzxml" | format =="mzXML"){
+
+ MSConvert_CMD <- paste0("docker run --rm -e WINEDEBUG=-all -v ",
+ in_path,
+ ":/data chambm/pwiz-skyline-i-agree-to-the-vendor-licenses wine msconvert ",
+ "*.",format,
+ " --mzML --filter 'peakPicking true 1-' --filter 'zeroSamples removeExtra' --filter 'msLevel 1' --64 --zlib")
+
+ } else {
+
+ MSConvert_CMD <- paste0("docker run --rm -e WINEDEBUG=-all -v ",
+ in_path,
+ ":/data chambm/pwiz-skyline-i-agree-to-the-vendor-licenses wine msconvert ",
+ "*.",format,
+ " --mzXML --filter 'peakPicking true 1-' --filter 'zeroSamples removeExtra' --filter 'msLevel 1' --64 --zlib")
+
+ }
+
+ a1<-tryCatch(system(MSConvert_CMD), error = function(e){e})
+
+ ## Remove the old or cache files
+ if(a1==0 & rm){
+
+ rm_CMD <- paste0("rm -rf ", files.list)
+ sapply(rm_CMD, FUN=function(x){system(x)});
+
+ } else if(a1!=0){
+
+ print("There is some issues for MetaboAnalystR to start \"ProteoWizard\", please check following points:")
+ print("1.Installation of Docker and Proteowizard, if not please refer to: http://proteowizard.sourceforge.net/download.html;");
+ print("2.Set docker to the sudoer group list, please refer to: https://docs.docker.com/engine/install/linux-postinstall/;");
+ print("3.The file format has to be one of the .raw, .RAW, .wiff, .mzXML. .mzML, .d, .D, .mzData or .CDF, zipped files are not supported");
+ print("4.If issues still please use ProteoWizard directly with the files generated by this function;");
+
+ }
+
+
+ }
+
+}
+
+
+
+## Functions for other plotting
+PlotSpectraInsensityStistics <- function(mSet, imgName, format="png", dpi=72, width=NA){
+
+ sample_idx <- mSet[["onDiskData"]]@phenoData@data[["sample_group"]];
+ sample_num <- mSet[["onDiskData"]]@phenoData@data[["sample_name"]];
+
+ Cairo::Cairo(file = imgName,
+ unit="in",
+ dpi=dpi,
+ width=width,
+ height= length(sample_num)*0.65,
+ type=format,
+ bg="white")
+
+ if(length(unique(sample_idx)) > 9){
+
+ col.fun <- grDevices::colorRampPalette(RColorBrewer::brewer.pal(12, "Set3"))
+ group_colors <- col.fun(length(unique(sample_idx)))
+
+ }else{
+
+ group_colors <- paste0(RColorBrewer::brewer.pal(9, "Set1")[1:length(unique(sample_idx))], "60")
+ }
+
+ ints <- split(log2(mSet[["msFeatureData"]][["chromPeaks"]][, "into"]),
+ f = mSet[["msFeatureData"]][["chromPeaks"]][, "sample"])
+
+ names(ints) <- as.character(sample_num);
+ group_colors <- sapply(seq(length(levels(sample_idx))), FUN=function(x){
+ rep(group_colors[x],length(sample_idx[sample_idx==levels(sample_idx)[x]]))
+ })
+
+ op<-par(mar=c(3.5,10,4,1.5), xaxt="s");
+ boxplot(ints,
+ varwidth = TRUE,
+ col = as.character(unlist(group_colors)),
+ ylab = "",
+ horizontal = TRUE,
+ las = 2,
+ main = expression(log[2]~intensity),
+ cex.lab = 0.8,
+ cex.main = 1.25)
+
+ #title(ylab=expression(log[2]~intensity), line=7.5, cex.lab=1.2)
+ grid(nx = NA, ny = NULL)
+
+ dev.off()
+
+}
+
+PlotSpectraPCA <- function(mSet, imgName, format="png", dpi=72, width=NA){
+
+ Cairo::Cairo(file = imgName,
+ unit="in",
+ dpi=dpi,
+ width=width,
+ height=width*0.80,
+ type=format,
+ bg="white")
+
+ sample_idx <- mSet[["onDiskData"]]@phenoData@data[["sample_group"]];
+
+ feature_value <- .feature_values(pks = mSet[["msFeatureData"]][["chromPeaks"]],
+ fts = mSet[["FeatureGroupTable"]],
+ method = "medret", value = "into",
+ intensity = "into",
+ colnames = mSet[["onDiskData"]]@phenoData@data[["sample_name"]],
+ missing = NA);
+
+ pca_feats <- log2(feature_value);
+
+
+ df0 <- na.omit(pca_feats);
+ df1 <- df0[is.finite(rowSums(df0)),]
+ df <- t(df1);
+
+
+ mSet_pca <- prcomp(df, center = TRUE, scale=T)
+ sum.pca <- summary(mSet_pca)
+ var.pca <- sum.pca$importance[2,] # variance explained by each PCA
+
+ xlabel <- paste("PC1", "(", round(100*var.pca[1],1), "%)");
+ ylabel <- paste("PC2", "(", round(100*var.pca[2],1), "%)");
+
+ # using ggplot2
+ df <- as.data.frame(mSet_pca$x)
+ df$group <- sample_idx
+
+ if(.on.public.web){
+ require("ggrepel");
+
+ if(nrow(df) < 30){
+
+ if(length(unique(sample_idx))>9){
+ col.fun <- grDevices::colorRampPalette(RColorBrewer::brewer.pal(12, "Set3"))
+
+ p <- ggplot2::ggplot(df, aes(x = PC1, y = PC2, color=group, label=row.names(df))) +
+ geom_text_repel(force=1.5) + geom_point(size = 5) + fill=col.fun(length(unique(sample_idx))) + theme(axis.text=element_text(size=12))
+
+ }else{
+
+ p <- ggplot2::ggplot(df, aes(x = PC1, y = PC2, color=group, label=row.names(df))) +
+ geom_text_repel(force=1.5) + geom_point(size = 5) + scale_color_brewer(palette="Set1") + theme(axis.text=element_text(size=12))
+ }
+
+ } else {
+
+ if(length(unique(sample_idx))>9){
+ col.fun <- grDevices::colorRampPalette(RColorBrewer::brewer.pal(12, "Set3"))
+
+ p <- ggplot2::ggplot(df, aes(x = PC1, y = PC2, color=group)) + geom_point(size = 5) + fill=col.fun(length(unique(sample_idx)))
+
+ }else{
+
+ p <- ggplot2::ggplot(df, aes(x = PC1, y = PC2, color=group)) + geom_point(size = 5) + scale_color_brewer(palette="Set1")
+
+ }
+
+ }
+
+ }else{
+
+ if(length(unique(sample_idx))>9){
+ col.fun <- grDevices::colorRampPalette(RColorBrewer::brewer.pal(12, "Set3"))
+
+ p <- ggplot2::ggplot(df, aes(x = PC1, y = PC2, color=group)) +
+ geom_point(size = 3) + scale_color_brewer(palette="Set1") + fill=col.fun(length(unique(sample_idx)))
+
+ }else{
+ p <- ggplot2::ggplot(df, aes(x = PC1, y = PC2, color=group)) +
+ geom_point(size = 3) + scale_color_brewer(palette="Set1")
+ }
+
+ }
+
+ p <- p + xlab(xlabel) + ylab(ylabel) + theme_bw() + theme(axis.title=element_text(size=12))
+ print(p)
+
+ dev.off()
+
+}
+
+PlotSpectraRTadj <- function(mSet, imgName, format="png", dpi=72, width=NA){
+
+ sample_idx <- mSet[["onDiskData"]]@phenoData@data[["sample_group"]];
+
+ Cairo::Cairo(file = imgName,
+ unit="in",
+ dpi=dpi,
+ width=width,
+ height=width*0.618,
+ type=format,
+ bg="white")
+
+ if(length(unique(sample_idx)) > 9){
+ col.fun <- grDevices::colorRampPalette(RColorBrewer::brewer.pal(12, "Set3"))
+ group_colors <- col.fun(length(unique(sample_idx)))
+ }else{
+ group_colors <- paste0(RColorBrewer::brewer.pal(9, "Set1")[1:length(unique(sample_idx))], "60")
+ }
+
+
+ names(group_colors) <- unique(sample_idx)
+
+ ## Extract RT information
+
+ rt.set <- list(mSet[["xcmsSet"]]@rt$raw, unlist(mSet[["xcmsSet"]]@rt$corrected));
+ diffRt <- rt.set[[2]] - rt.set[[1]];
+ diffRt <- split(diffRt, fromFile(mSet$onDiskData));
+
+ xRt <- mSet[["msFeatureData"]][["adjustedRT"]];
+ col = group_colors[sample_idx];
+ lty = 1;
+ lwd = 1;
+ col <- rep(col, length(diffRt));
+ lty <- rep(lty, length(diffRt));
+ lwd <- rep(lwd, length(diffRt));
+
+ ylim <- range(diffRt, na.rm = TRUE);
+ plot(3, 3, pch = NA, xlim = range(xRt, na.rm = TRUE),
+ ylim = ylim, xlab = "RT_adj", ylab = "RT_diff");
+
+ for (i in 1:length(diffRt)){
+ points(x = xRt[[i]], y = diffRt[[i]], col = col[i], lty = lty[i],
+ type = "l", lwd = lwd[i])
+ }
+
+ rawRt <- split(mSet[["xcmsSet"]]@rt$raw, fromFile(mSet$onDiskData));
+ adjRt <- xRt;
+
+ ####
+ peaks_0 <- mSet[["msFeatureData"]][["chromPeaks"]]
+ subs <- seq_along(mSet[["onDiskData"]]@phenoData@data[["sample_name"]])
+ ####
+ pkGroup <- mSet[["msFeatureData"]][["pkGrpMat_Raw"]];
+ ####
+
+ rawRt <- rawRt[subs]
+ adjRt <- adjRt[subs]
+ ## Have to "adjust" these:
+ pkGroupAdj <- pkGroup
+
+ for (i in 1:ncol(pkGroup)) {
+ pkGroupAdj[, i] <- MetaboAnalystR:::.applyRtAdjustment(pkGroup[, i], rawRt[[i]], adjRt[[i]])
+ }
+
+ diffRt <- pkGroupAdj - pkGroup
+
+ xRt <- pkGroupAdj
+
+ ## Loop through the rows and plot points - ordered by diffRt!
+ for (i in 1:nrow(xRt)) {
+ idx <- order(diffRt[i, ])
+ points(x = xRt[i, ][idx], diffRt[i, ][idx],
+ col = "#00000080", type = "b",
+ pch = 16, lty = 3)
+ }
+ legend("topright", legend=unique(sample_idx), pch=15, col=group_colors);
+
+ dev.off()
+
+}
+
+PlotSpectraBPIadj <- function(mSet, imgName, format="png", dpi=72, width=NA){
+
+ Cairo::Cairo(file = imgName,
+ unit="in",
+ dpi=dpi,
+ width=width,
+ height=width*0.618,
+ type=format,
+ bg="white")
+
+ sample_idx <- mSet[["onDiskData"]]@phenoData@data[["sample_group"]];
+
+ if(length(unique(sample_idx)) > 9){
+
+ col.fun <- grDevices::colorRampPalette(RColorBrewer::brewer.pal(12, "Set3"))
+ group_colors <- col.fun(length(unique(sample_idx)))
+
+ }else{
+
+ group_colors <- paste0(RColorBrewer::brewer.pal(9, "Set1")[1:length(unique(sample_idx))], "60")
+ }
+ group_colors2 <- group_colors;
+ names(group_colors2) <- unique(sample_idx);
+
+ group_colors <- sapply(seq(length(levels(sample_idx))), FUN=function(x){
+ rep(group_colors[x],length(sample_idx[sample_idx==levels(sample_idx)[x]]))
+ })
+
+ object_od <- mSet$onDiskData
+ adj_rt <- unlist(mSet$msFeatureData$adjustedRT)
+
+ object_od <- selectFeatureData(
+ object_od, fcol = c("fileIdx", "spIdx", "seqNum",
+ "acquisitionNum", "msLevel",
+ "polarity", "retentionTime",
+ "precursorScanNum"))
+ object_od@featureData$retentionTime <- adj_rt
+
+ res <- MSnbase::chromatogram(object_od,
+ aggregationFun = "sum",
+ missing = NA_real_, msLevel = 1,
+ BPPARAM = bpparam())
+
+ plot(res,col=as.character(unlist(group_colors)))
+
+ legend("topright", legend=unique(sample_idx), pch=15, col=group_colors2)
+
+ dev.off()
+}
+
+
+
+
+
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/project_sharing_utils.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/project_sharing_utils.R
new file mode 100755
index 0000000000000000000000000000000000000000..78a47db117469a7a8e002c63475d88b8decdb9f2
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/project_sharing_utils.R
@@ -0,0 +1,95 @@
+PrepareSignatureOfMetaboAnalyst <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ if(exists('sam.cmpds', where=mSetObj$analSet)){
+ if(dim(mSetObj$analSet$sam.cmpds)[1] > 0){
+ signature.cmpds <- mSetObj$analSet$sam.cmpds;
+ signature.cmpds <- as.matrix(signature.cmpds[,4])
+ }
+ }else if(exists('ebam.cmpds', where=mSetObj$analSet)){
+ if(dim(mSetObj$analSet$ebam.cmpds)[1] > 0){
+ signature.cmpds <- mSetObj$analSet$ebam.cmpds;
+ signature.cmpds <- as.matrix(signature.cmpds[,3])
+ }
+ }else if(exists('fc', where=mSetObj$analSet)){
+ sig.mat <- mSet$analSet$fc$sig.mat;
+ if(dim(sig.mat)[1] > 0){
+ signature.cmpds <- sig.mat;
+ signature.cmpds <- as.matrix(sig.mat[,2])
+ }
+ }else if(exists('tt', where=mSetObj$analSet)){
+ sig.mat <- mSet$analSet$tt$sig.mat;
+ if(dim(sig.mat)[1] > 0){
+ signature.cmpds <- sig.mat;
+ signature.cmpds <- as.matrix(sig.mat[,2])
+ }
+ }else if(exists('volcano', where=mSetObj$analSet)){
+ sig.mat <- mSet$analSet$volcano$sig.mat;
+ if(dim(sig.mat)[1] > 0){
+ signature.cmpds <- sig.mat;
+ signature.cmpds <- as.matrix(sig.mat[,2])
+ }
+ }else if(exists('pca', where=mSetObj$analSet)){
+ sig.mat <- mSet$analSet$pca$imp.loads;
+ if(dim(sig.mat)[1] > 0){
+ signature.cmpds <- sig.mat;
+ signature.cmpds <- as.matrix(sig.mat[,1])
+ }
+ }else if(exists('rf', where=mSetObj$analSet)){
+ sig.mat <- mSet$analSet$rf$importance;
+ if(dim(sig.mat)[1] > 0){
+ signature.cmpds <- as.matrix(sig.mat[,ncol(sig.mat)])
+ }
+ }else if(exists('svm', where=mSetObj$analSet)){
+ sig.mat <- mSet$analSet$svm$sig.mat;
+ if(dim(sig.mat)[1] > 0){
+ signature.cmpds <- sig.mat;
+ signature.cmpds <- as.matrix(sig.mat[,1])
+ }
+ }else if(exists('oplsda', where=mSetObj$analSet)){
+ sig.mat <- mSet$analSet$oplsda$loadingMN;
+ if(dim(sig.mat)[1] > 0){
+ signature.cmpds <- sig.mat;
+ signature.cmpds <- as.matrix(sig.mat[,1])
+ }
+ }else{
+ return(-1);
+ }
+
+ if(mSetObj$dataSet$type == "conc"){
+ LoadScripts("mset")
+ cmpd.vec <- rownames(signature.cmpds);
+ Setup.MapData(mSet, cmpd.vec);
+ CrossReferencing(mSet, "name");
+ CreateMappingResultTable(mSet);
+ cmpdlist <- unlist(mSet$dataSet$map.table[,3]);
+ signature.cmpds <- as.matrix(signature.cmpds[cmpdlist != "NA",]);
+ cmpdlist <- cmpdlist[cmpdlist != "NA"];
+ rownames(signature.cmpds) <- cmpdlist
+ signature.type <- "hmdb"
+ save(signature.cmpds, signature.type, file="RShare_metaboanalyst.RData");
+ }else if((mSetObj$dataSet$type == "mspeak") || (mSetObj$dataSet$type == "pktable")){
+ LoadScripts("mummichog")
+ InitDataObjects("mass_all", "mummichog", FALSE)
+ SetPeakFormat("rmp")
+ UpdateInstrumentParameters(mSet, 1.0, "positive");
+ m.z <- sapply(strsplit(rownames(signature.cmpds), "/"), function(x) {x[[1]]})
+ write.table(x = m.z, file = "peaklist.csv", row.names = FALSE, col.names = "m.z", quote = FALSE);
+ Read.PeakListData(mSet, "peaklist.csv");
+ SanityCheckMummichogData(mSet)
+ SetPeakEnrichMethod(mSet, "mum")
+ SetMummichogPval(mSet, 0.0)
+ PerformPSEA(mSet, "hsa_mfn")
+
+ # handle cases with repeated ID matching of m.z values
+ # & cases with missed matchings for m.z values
+ idx <- match(unlist(unique(mSet$matches.res[,1])), unique(m.z))
+ signature.cmpds <- as.matrix(signature.cmpds[idx,])
+ idx <- match(unique(mSet$matches.res[,1]), mSet$matches.res[,1])
+ mSet$matches.res <- mSet$matches.res[idx,]
+ rownames(signature.cmpds) <- mSet$matches.res[,2]
+ signature.type <- "kegg"
+ save(signature.cmpds, signature.type, file="RShare_metaboanalyst.RData");
+ }
+
+ return(1);
+}
\ No newline at end of file
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/all/hsa.qs b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/all/hsa.qs
new file mode 100644
index 0000000000000000000000000000000000000000..bfbf2f4a6e3ed956c82ea90c447fdb52ccf8c436
Binary files /dev/null and b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/all/hsa.qs differ
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/all/mmu.qs b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/all/mmu.qs
new file mode 100644
index 0000000000000000000000000000000000000000..43533f32f0ae43448c531dc61be1558461632af3
Binary files /dev/null and b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/all/mmu.qs differ
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/blood.qs b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/blood.qs
new file mode 100644
index 0000000000000000000000000000000000000000..734c21fea88aef9913072bc48e8b559cd1f861da
Binary files /dev/null and b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/blood.qs differ
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/compound_db.qs b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/compound_db.qs
new file mode 100644
index 0000000000000000000000000000000000000000..1a7f8c150149e3b574db94a5569a36aeba437045
Binary files /dev/null and b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/compound_db.qs differ
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/csf.qs b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/csf.qs
new file mode 100644
index 0000000000000000000000000000000000000000..bc7f4aed11f9b317d8347fb5ade75878ec898321
Binary files /dev/null and b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/csf.qs differ
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/drug.qs b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/drug.qs
new file mode 100644
index 0000000000000000000000000000000000000000..4e52cc0a2a08f2d97b237ad602f2b6072ab9d509
Binary files /dev/null and b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/drug.qs differ
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/fecal.qs b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/fecal.qs
new file mode 100644
index 0000000000000000000000000000000000000000..b2b739f00fba42e33c594fb46525c27cb23b11f0
Binary files /dev/null and b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/fecal.qs differ
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/kegg_pathway.qs b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/kegg_pathway.qs
new file mode 100644
index 0000000000000000000000000000000000000000..cb87f79d965236b344c24be5cee4d7f1494cf6aa
Binary files /dev/null and b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/kegg_pathway.qs differ
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/lipid/lipid_compound_db.qs b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/lipid/lipid_compound_db.qs
new file mode 100644
index 0000000000000000000000000000000000000000..47251cf8ce1698ded186ad38be035c502bd90ebc
Binary files /dev/null and b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/lipid/lipid_compound_db.qs differ
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/lipid/lipid_syn_nms.qs b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/lipid/lipid_syn_nms.qs
new file mode 100644
index 0000000000000000000000000000000000000000..f4870beb7bbc77e69513843f3f29f0875761373b
Binary files /dev/null and b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/lipid/lipid_syn_nms.qs differ
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/location.qs b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/location.qs
new file mode 100644
index 0000000000000000000000000000000000000000..537e7158042d92071f392cab6d4af1bf253eaca7
Binary files /dev/null and b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/location.qs differ
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/main_class.qs b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/main_class.qs
new file mode 100644
index 0000000000000000000000000000000000000000..2d7ce1d5919368087ded02dd66e68f3117ec1171
Binary files /dev/null and b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/main_class.qs differ
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/master_compound_db.qs b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/master_compound_db.qs
new file mode 100644
index 0000000000000000000000000000000000000000..ffd64cdf3c9e9d2afadbfc867726b0edce4ab174
Binary files /dev/null and b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/master_compound_db.qs differ
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/metab/hsa.qs b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/metab/hsa.qs
new file mode 100644
index 0000000000000000000000000000000000000000..311c6c8452b04ae99c05f3ae47c8f1feb3864097
Binary files /dev/null and b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/metab/hsa.qs differ
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/metab/mmu.qs b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/metab/mmu.qs
new file mode 100644
index 0000000000000000000000000000000000000000..203f0044e7c32a99a4c229192ef18df4432e5b07
Binary files /dev/null and b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/metab/mmu.qs differ
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/metpa/kegg/hsa.qs b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/metpa/kegg/hsa.qs
new file mode 100644
index 0000000000000000000000000000000000000000..32c6fbdeb47d6b2d4fcf57991e19acc3b5431ff9
Binary files /dev/null and b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/metpa/kegg/hsa.qs differ
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/metpa/kegg/human.qs b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/metpa/kegg/human.qs
new file mode 100644
index 0000000000000000000000000000000000000000..6ebccc247033c65c5b090dab03def1737d153d7b
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/metpa/kegg/human.qs
@@ -0,0 +1 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"><html xmlns="http://www.w3.org/1999/xhtml"><head><title>Payara Server 5.194 #badassfish - Error report</title><style type="text/css"><!--H1 {font-family:Tahoma,Arial,sans-serif;color:white;background-color:#525D76;font-size:22px;} H2 {font-family:Tahoma,Arial,sans-serif;color:white;background-color:#525D76;font-size:16px;} H3 {font-family:Tahoma,Arial,sans-serif;color:white;background-color:#525D76;font-size:14px;} BODY {font-family:Tahoma,Arial,sans-serif;color:black;background-color:white;} B {font-family:Tahoma,Arial,sans-serif;color:white;background-color:#525D76;} P {font-family:Tahoma,Arial,sans-serif;background:white;color:black;font-size:12px;}A {color : black;}HR {color : #525D76;}--></style> </head><body><h1>HTTP Status 404 - Not Found</h1><hr/><p><b>type</b> Status report</p><p><b>message</b>Not Found</p><p><b>description</b>The requested resource is not available.</p><hr/><h3>Payara Server 5.194 #badassfish</h3></body></html>
\ No newline at end of file
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/metpa/kegg/mmu.qs b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/metpa/kegg/mmu.qs
new file mode 100644
index 0000000000000000000000000000000000000000..87b1a114720e17e8cc062aac84a62392c7e50425
Binary files /dev/null and b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/metpa/kegg/mmu.qs differ
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/metpa/smpdb/hsa.qs b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/metpa/smpdb/hsa.qs
new file mode 100644
index 0000000000000000000000000000000000000000..7bb06551b7a3350845f83d6186e151be69a8225d
Binary files /dev/null and b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/metpa/smpdb/hsa.qs differ
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/metpa/smpdb/mmu.qs b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/metpa/smpdb/mmu.qs
new file mode 100644
index 0000000000000000000000000000000000000000..0f686c5cbcc4012942fdeb9b4816b05449bd9f98
Binary files /dev/null and b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/metpa/smpdb/mmu.qs differ
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/predicted.qs b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/predicted.qs
new file mode 100644
index 0000000000000000000000000000000000000000..c87f9de0a568f063ab24fd81202420b32cf7538b
Binary files /dev/null and b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/predicted.qs differ
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/self-name.qs b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/self-name.qs
new file mode 100644
index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/smpdb_pathway.qs b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/smpdb_pathway.qs
new file mode 100644
index 0000000000000000000000000000000000000000..0bb5917e6ddd5eaa12154fc2c9904ca8cb3acbd4
Binary files /dev/null and b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/smpdb_pathway.qs differ
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/snp.qs b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/snp.qs
new file mode 100644
index 0000000000000000000000000000000000000000..b1f6df4dfcf147a04b395fba9d862a7b119319fa
Binary files /dev/null and b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/snp.qs differ
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/sub_class.qs b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/sub_class.qs
new file mode 100644
index 0000000000000000000000000000000000000000..84160bba43b8feb5925f8877809e8db002a307b4
Binary files /dev/null and b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/sub_class.qs differ
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/super_class.qs b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/super_class.qs
new file mode 100644
index 0000000000000000000000000000000000000000..84d72bcb268ee96e350b7370d015356102fe223a
Binary files /dev/null and b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/super_class.qs differ
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/urine.qs b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/urine.qs
new file mode 100644
index 0000000000000000000000000000000000000000..17e382d483f3a99940fd3dd0a2b7a8006e8dae1f
Binary files /dev/null and b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/qs/urine.qs differ
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/share_projects.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/share_projects.R
new file mode 100755
index 0000000000000000000000000000000000000000..ca131bfa7d2a505e72af838d484d645bbc5cc5c5
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/share_projects.R
@@ -0,0 +1,9 @@
+PrepareGeneList <- function(path, fileNm="datalist1"){
+ data <- readRDS(file=paste0(path, fileNm));
+ data <- as.data.frame(data$prot.mat);
+ data <- cbind(rownames(data), data)
+ colnames(data) <- c("#Entrez", "logFC")
+ dest.file <- paste0(path, fileNm, ".txt")
+ write.table(data, dest.file, append = FALSE, sep = "\t", row.names = FALSE, col.names = TRUE, quote = FALSE);
+ return(dest.file);
+}
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/spectra_processing.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/spectra_processing.R
new file mode 100644
index 0000000000000000000000000000000000000000..31c0eaa34537db8f2c43f7bf06d1bde2ffa66ae2
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/spectra_processing.R
@@ -0,0 +1,254 @@
+### This is a online script to do some pre-define before job scheduler
+
+#' CreateRawRscript
+#' @description used to create a running for raw spectra processing
+#' this file will be run by spring daemon by using OptiLCMS rather than relay on the local
+#' compiling RC files
+#' @author Guangyan Zhou, Zhiqiang Pang
+CreateRawRscript <- function(guestName, planString, planString2, rawfilenms.vec){
+
+ guestName <- guestName;
+ planString <- planString;
+
+ if(dir.exists("/home/glassfish/payara5/glassfish/domains/")){
+ users.path <-paste0("/data/glassfish/projects/metaboanalyst/", guestName);
+ }else {
+ users.path <-getwd();
+ }
+
+ ## Prepare Configuration script for slurm running
+ conf_inf <- "#!/bin/bash\n#\n#SBATCH --job-name=Spectral_Processing\n#\n#SBATCH --ntasks=1\n#SBATCH --time=360:00\n#SBATCH --mem-per-cpu=5000\n#SBATCH --cpus-per-task=4\n"
+
+
+ ## Prepare R script for running
+ # need to require("OptiLCMS")
+ str <- paste0('library(OptiLCMS)');
+
+ # Set working dir & files included
+ str <- paste0(str, ";\n", "setwd(\'",users.path,"\')");
+ str <- paste0(str, ";\n", "mSet <- InitDataObjects(\'spec\', \'raw\', FALSE)");
+ str <- paste0(str, ";\n", "mSet <- UpdateRawfiles(mSet,", rawfilenms.vec, ")");
+
+ ## Construct the opt pipeline
+ if(planString2 == "opt"){
+ str <- paste0(str, ';\n', 'plan <- InitializaPlan(\'raw_opt\')')
+ str <- paste0(str, ';\n', planString)
+ str <- paste0(str, ';\n', "res <- ExecutePlan(plan)")
+ }
+
+ ## Construct the default pipeline
+ if(planString2 == "default"){
+ str <- paste0(str, ';\n', 'plan <- InitializaPlan(\'raw_ms\')')
+ str <- paste0(str, ';\n', planString)
+ str <- paste0(str, ';\n', "res <- ExecutePlan(plan)")
+ }
+
+ str <- paste0(str, ';\n', "Export.Annotation(res[['mSet']])")
+ str <- paste0(str, ';\n', "Export.PeakTable(res[['mSet']])")
+ str <- paste0(str, ';\n', "Export.PeakSummary(res[['mSet']])")
+
+ # sink command for running
+ sink("ExecuteRawSpec.sh");
+
+ cat(conf_inf);
+ cat(paste0("\nsrun R -e \"\n", str, "\n\""));
+
+ sink();
+ return(as.integer(1))
+}
+
+#' SetRawFileNames
+#' @description #TODO: SetRawFileNames
+#' @author Guangyan Zhou, Zhiqiang Pang
+SetRawFileNames <- function(filenms){
+ print(filenms)
+ rawfilenms.vec <<- filenms
+ return(1);
+}
+
+#' #Raw Spectra Upload
+#' @description function used to process during uploading stage
+#' @author Guangyan Zhou, Zhiqiang Pang
+ReadRawMeta<-function(fileName){
+ if(grepl(".txt", fileName, fixed=T)){
+ tbl=read.table(fileName,header=TRUE, stringsAsFactors = F);
+ }else if(grepl(".csv", fileName, fixed=T)){
+ tbl = read.csv(fileName,header=TRUE, stringsAsFactors = F);
+ }else{
+ print("wrongfiletype")
+ }
+
+ rawFileNms <-as.vector(tbl[,1])
+ rawClassNms <-as.vector(tbl[,2])
+ rawFileNms <- sapply(strsplit(rawFileNms, "\\."), function(x) paste0(head(x,-1), collapse="."));
+ clsTable = table(rawClassNms)
+ #check replicate number
+ clsTypes = names(table(rawClassNms))
+ for(name in clsTypes){
+ if(toupper(name) !="QC"){
+ replicateNum = clsTable[[name]]
+ }
+ }
+
+ rawFileNms<<-rawFileNms
+ rawClassNms<<-rawClassNms
+ return(1);
+}
+
+GetRawFileNms <- function(){
+ return(rawFileNms)
+}
+
+GetRawClassNms <- function(){
+ return(rawClassNms)
+}
+
+#' Set User Path
+#' @description play roles at the first uploading and login stage
+#' @author Guangyan Zhou, Zhiqiang Pang
+#' TODO: can be delete in the future
+SetUserPath<-function(path){
+ fullUserPath <<- path;
+}
+.getDataPath<- function() {
+ if(file.exists("/home/zgy/scheduler/MetaboAnalyst.so")){
+ path = "/home/glassfish/payara5/glassfish/domains/domain1/applications/MetaboAnalyst/resources/data/"
+ }else if(dir.exists("/media/zzggyy/disk/")){
+ path <- "/media/zzggyy/disk/MetaboAnalyst/target/MetaboAnalyst-5.18/resources/data/"
+ }else if(.on.public.web){
+ path = "../../data/";
+ }
+ return(path)
+}
+
+#' verifyParam
+#' @description Verify the example params has changed or not
+#' @author Guangyan Zhou, Zhiqiang Pang
+verifyParam <- function(param0_path, users.path) {
+
+ load(paste0(users.path, "/params.rda"));
+
+ load(param0_path);
+
+ verify.vec <- NULL
+
+ for (i in 1:length(peakParams)) {
+ for (j in 1:length(peakParams0)) {
+ if (names(peakParams[i]) == names(peakParams0[j])) {
+ verify.vec_tmp <- peakParams[[i]] == peakParams0[[j]]
+ verify.vec <- c(verify.vec, verify.vec_tmp)
+ }
+ }
+ }
+
+ if (all(verify.vec)) {
+ print("Examples' param not changed !")
+ return(1)
+
+ } else{
+ print("Examples' param changed !")
+ return(0)
+ }
+
+}
+
+################## ------------- Shell function here below ------------- ######################
+
+#' InitializePlan
+#' @description this function is used to initialize a plan before submit job to spring daemon
+#' @author Zhiqiang Pang
+InitializaPlan <- function(){
+ plan <- OptiLCMS::InitializaPlan();
+ # Nothing to return
+}
+
+#' CentroidCheck
+#' @description CentroidCheck function used to check centroid or not
+#' @author Zhiqiang Pang
+CentroidCheck <- function(filename){
+ return(OptiLCMS::CentroidCheck(filename));
+}
+
+#' SetPeakParam
+#' @description SetPeakParam, used to set the peak param
+#' @author Zhiqiang Pang
+SetPeakParam <- function(platform = "general", Peak_method = "centWave", RT_method = "loess",
+ mzdiff, snthresh, bw, # used for both "centwave" and "matchedFilter"
+ ppm, min_peakwidth, max_peakwidth, noise, prefilter, value_of_prefilter, # used for "centwave"
+ fwhm, steps, sigma, peakBinSize, max, # used for "matchedFilter"
+ criticalValue, consecMissedLimit, unions, checkBack, withWave, # used for "massifquant"
+ profStep, # used for "obiwarp"
+ minFraction, minSamples, maxFeatures, mzCenterFun, integrate,# used for grouping
+ extra, span, smooth, family, fitgauss, # used for RT correction with peakgroup "loess"
+ polarity, perc_fwhm, mz_abs_iso, max_charge, max_iso, corr_eic_th, mz_abs_add, #used for annotation
+ rmConts #used to control remove contamination or not
+ ){
+ OptiLCMS::SetPeakParam(platform = "general", Peak_method = "centWave", RT_method = "loess",
+ mzdiff, snthresh, bw, # used for both "centwave" and "matchedFilter"
+ ppm, min_peakwidth, max_peakwidth, noise, prefilter, value_of_prefilter, # used for "centwave"
+ fwhm, steps, sigma, peakBinSize, max, # used for "matchedFilter"
+ criticalValue, consecMissedLimit, unions, checkBack, withWave, # used for "massifquant"
+ profStep, # used for "obiwarp"
+ minFraction, minSamples, maxFeatures, mzCenterFun, integrate,# used for grouping
+ extra, span, smooth, family, fitgauss, # used for RT correction with peakgroup "loess"
+ polarity, perc_fwhm, mz_abs_iso, max_charge, max_iso, corr_eic_th, mz_abs_add, #used for annotation
+ rmConts #used to control remove contamination or not
+ )
+ #return nothing
+}
+
+#' GeneratePeakList
+#' @description GeneratePeakList is used to generate the peak summary list for result page
+#' @author Zhiqiang Pang
+GeneratePeakList <- function(userPath){
+ return(OptiLCMS:::GeneratePeakList(userPath))
+}
+
+#' plotSingleTIC
+#' @description plotSingleTIC is used to plot single TIC
+#' @author Zhiqiang Pang
+plotSingleTIC <- function(filename, imagename){
+ OptiLCMS::plotSingleTIC(NULL, filename, imagename)
+}
+
+#' plotMSfeature
+#' @description plotMSfeature is used to plot MS feature stats for different groups
+#' @author Zhiqiang Pang
+plotMSfeature <- function(FeatureNM){
+ OptiLCMS::plotMSfeature(NULL, FeatureNM)
+}
+
+#' PlotXIC
+#' @description PlotXIC is used to plot both MS XIC/EIC features of different group and samples
+#' @author Zhiqiang Pang
+PlotXIC <- function(featureNum){
+ OptiLCMS::PlotXIC(NULL, featureNum)
+}
+
+#' PerformDataInspect
+#' @description PerformDataInspect is used to plot 2D/3D structure of the MS data
+#' @author Zhiqiang Pang
+PerformDataInspect <- function(datapath = NULL,
+ rt.range = c(0,0),
+ mz.range = c(0,0),
+ dimension = "3D",
+ res = 100){
+ OptiLCMS::PerformDataInspect(datapath, rt.range,
+ mz.range, dimension,
+ res)
+}
+
+#' FastRunningShow_customized
+#' @description FastRunningShow_customized is used to showcase the customized running pipeline
+#' @author Zhiqiang Pang
+FastRunningShow_customized <- function(fullUserPath){
+ OptiLCMS:::FastRunningShow_customized(fullUserPath)
+}
+
+#' FastRunningShow_auto
+#' @description FastRunningShow_auto is used to showcase the AUTO running pipeline
+#' @author Zhiqiang Pang
+FastRunningShow_auto <- function(fullUserPath){
+ OptiLCMS:::FastRunningShow_auto(fullUserPath)
+}
+
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/spectra_utils.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/spectra_utils.R
new file mode 100755
index 0000000000000000000000000000000000000000..9fcf384679b79e800376e2e833ee76395a663a5f
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/spectra_utils.R
@@ -0,0 +1,5513 @@
+# Content of this script
+
+# 1. raw data function - xcms
+# 2. Peaks Peaking Function - parameters optimization
+# 3. MS/MS processing - (moved from preproc_utils)
+# 4. Peak Annotation - CAMERA
+# 5. MS File Reading - MSnbase
+
+# --------------------1. Raw spectra processing_Section using the xcms way---------------------------------------------
+
+#'PerformPeakPicking
+#'@description PerformPeakPicking
+#'@param object the raw data object read by ImportRawMSData function.
+#'@param param param list generated by updateRawSpectraParam function.
+#'@param BPPARAM parallel method used for data processing. Default is bpparam().
+#'@author Zhiqiang Pang, Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'@ref Smith, C.A. et al. 2006. Analytical Chemistry, 78, 779-787
+#'
+PerformPeakPicking<-function(object,param,BPPARAM = bpparam()){
+
+ object_mslevel <- MSnbase::filterMsLevel(
+ MSnbase::selectFeatureData(object,
+ fcol = c(MSnbase:::.MSnExpReqFvarLabels,
+ "centroided")), msLevel. = 1)
+
+ if (length(object_mslevel) == 0)
+ AddErrMsg("Empty spectra present to perform !")
+
+ # Splite the MS data
+ object_mslevel <- lapply(1:length(fileNames(object_mslevel)),
+ FUN = filterFile,
+ object = object_mslevel)
+
+ # Peak picking runnning - centWave mode
+ if (param$Peak_method == "centWave")
+ resList <- bplapply(object_mslevel,
+ FUN = PeakPicking_centWave_slave, # slave Function of centWave
+ param = param, BPPARAM = BPPARAM)
+
+ # Peak picking runnning - MatchedFilter mode
+ if (param$Peak_method == "matchedFilter")
+ resList <- bplapply(object_mslevel,
+ FUN = PeakPicking_MatchedFilter_slave, # slave Function of MatchedFilter
+ param = param, BPPARAM = BPPARAM)
+
+
+
+ if (param$Peak_method != "matchedFilter" && param$Peak_method != "centWave"){
+ stop("Only 'centWave' and 'MatchedFilter' are suppoted now !")
+ }
+
+ # Picking Cluster
+
+ ##### PEAK SUMMARY------------
+
+ pks <- vector("list", length(resList))
+ for (i in 1:length(resList)) {
+ n_pks <- nrow(resList[[i]])
+ if (is.null(n_pks))
+ n_pks <- 0
+ if (n_pks == 0) {
+ pks[[i]] <- NULL
+ warning("No peaks found in sample number ", i, ".")
+ } else {
+ pks[[i]] <- cbind(resList[[i]], sample = rep.int(i, n_pks))
+ }
+
+ }
+ pks <- do.call(rbind, pks)
+
+ # Make the chrompeaks embeded
+ newFd <- list()
+ #newFd@.xData <- as.environment(as.list(object@msFeatureData, all.names = TRUE))
+ rownames(pks) <- sprintf(paste0("CP", "%0", ceiling(log10(nrow(pks) + 1L)), "d"),
+ seq(from = 1, length.out = nrow(pks)))
+
+ newFd$chromPeaks <- pks
+ newFd$chromPeakData <- S4Vectors::DataFrame(ms_level = rep(1L, nrow(pks)), is_filled = rep(FALSE, nrow(pks)),
+ row.names = rownames(pks))
+
+ ## mSet Generation
+ mSet<-list()
+ mSet$msFeatureData <- newFd
+ mSet$onDiskData <- object
+
+ return(mSet)
+
+}
+
+#'PeakPicking_centWave_slave
+#'@description PeakPicking_centWave_slave
+#'@author Zhiqiang Pang, Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@ref Smith, C.A. et al. 2006. Analytical Chemistry, 78, 779-787
+#'
+PeakPicking_centWave_slave <- function(x,param){
+
+ if (class(x)=="OnDiskMSnExp"){ # for raw data processing
+
+ scan.set <- MSnbase::spectra(x, BPPARAM = SerialParam());
+ rt <- MSnbase::rtime(x);
+
+ } else if (class(x) == "list") { # for parameters optimization
+
+ scan.set <- x;
+ rt <- unlist(lapply(x, MSnbase::rtime), use.names = FALSE);
+
+ }
+
+
+ mzs <- lapply(scan.set, MSnbase::mz)
+
+ vals_per_spect <- lengths(mzs, FALSE)
+
+
+ #if (any(vals_per_spect == 0))
+ # mzs <- mzs[-which(vals_per_spect == 0)];
+ # x <- x[-which(vals_per_spect == 0)]; # Cannot be so easy !
+ # warning("Found empty spectra Scan. Filtered Automatically !")
+
+ mz = unlist(mzs, use.names = FALSE);
+ int = unlist(lapply(scan.set, MSnbase::intensity), use.names = FALSE);
+ valsPerSpect = vals_per_spect;
+ scantime = rt;
+
+ ###### centWaveCore Function
+
+ valCount <- cumsum(valsPerSpect)
+ scanindex <- as.integer(c(0, valCount[-length(valCount)])) ## Get index vector for C calls
+
+ if (!is.double(mz))
+ mz <- as.double(mz)
+ if (!is.double(int))
+ int <- as.double(int)
+ ## Fix the mzCenterFun
+ #mzCenterFun <- paste("mzCenter",
+ # gsub(mzCenterFun, pattern = "mzCenter.",
+ # replacement = "", fixed = TRUE), sep=".")
+
+ basenames <- c("mz", "mzmin", "mzmax", "rt", "rtmin", "rtmax",
+ "into", "intb", "maxo", "sn")
+ verbosenames <- c("egauss", "mu", "sigma", "h", "f", "dppm", "scale",
+ "scpos", "scmin", "scmax", "lmin", "lmax")
+
+ ## Peak width: seconds to scales
+ peakwidth <- param$peakwidth
+ scalerange <- round((peakwidth / mean(diff(scantime))) / 2)
+
+ if (length(z <- which(scalerange == 0)))
+ scalerange <- scalerange[-z]
+ if (length(scalerange) < 1) {
+ warning("No scales? Please check peak width!")
+ if (param$verboseColumns) {
+ nopeaks <- matrix(nrow = 0, ncol = length(basenames) +
+ length(verbosenames))
+ colnames(nopeaks) <- c(basenames, verbosenames)
+ } else {
+ nopeaks <- matrix(nrow = 0, ncol = length(basenames))
+ colnames(nopeaks) <- c(basenames)
+ }
+ return(invisible(nopeaks))
+ }
+
+ if (length(scalerange) > 1){
+ scales <- seq(from = scalerange[1], to = scalerange[2], by = 2)
+ } else{
+ scales <- scalerange
+ }
+
+
+ minPeakWidth <- scales[1]
+ noiserange <- c(minPeakWidth * 3, max(scales) * 3)
+ maxGaussOverlap <- 0.5
+ minPtsAboveBaseLine <- max(4, minPeakWidth - 2)
+ minCentroids <- minPtsAboveBaseLine
+ scRangeTol <- maxDescOutlier <- floor(minPeakWidth / 2)
+ scanrange <- c(1, length(scantime))
+
+
+ ## If no ROIs are supplied then search for them.
+ roiList<-list()
+ if (length(roiList) == 0) {
+ message("ROI searching under ", param$ppm, " ppm ... ", appendLF = FALSE)
+
+ withRestarts(
+ tryCatch({
+
+ tmp <- capture.output(
+ roiList <- .Call(C_findmzROI,
+ mz, int, scanindex,
+ as.double(c(0.0, 0.0)),
+ as.integer(scanrange),
+ as.integer(length(scantime)),
+ as.double(param$ppm * 1e-6),
+ as.integer(minCentroids),
+ as.integer(param$prefilter),
+ as.integer(param$noise),PACKAGE = "MetaboAnalystR")
+
+ #roiList <- findmzROI (mz, int, scanindex,scanrange,scantime,param$ppm,
+ # minCentroids,param$prefilter,param$noise)
+
+ )
+
+ },
+ error = function(e){
+ if (grepl("m/z sort assumption violated !", e$message)) {
+ invokeRestart("fixSort")
+ } else {
+ simpleError(e)
+ }
+ }),
+ fixSort = function() {
+ ## Force ordering of values within spectrum by mz:
+ ## o split values into a list -> mz per spectrum, intensity per
+ ## spectrum.
+ ## o define the ordering.
+ ## o re-order the mz and intensity and unlist again.
+ ## Note: the Rle split is faster than the "conventional" factor split.
+ splitF <- Rle(1:length(valsPerSpect), valsPerSpect)
+ mzl <- as.list(S4Vectors::split(mz, f = splitF))
+ oidx <- lapply(mzl, order)
+ mz <<- unlist(mapply(mzl, oidx, FUN = function(y, z) {
+ return(y[z])
+ }, SIMPLIFY = FALSE, USE.NAMES = FALSE), use.names = FALSE)
+ int <<- unlist(mapply(as.list(split(int, f = splitF)), oidx,
+ FUN=function(y, z) {
+ return(y[z])
+ }, SIMPLIFY = FALSE, USE.NAMES = FALSE),
+ use.names = FALSE)
+ rm(mzl)
+ rm(splitF)
+ tmp <- capture.output(
+ roiList <<- .Call(C_findmzROI,
+ mz, int, scanindex,
+ as.double(c(0.0, 0.0)),
+ as.integer(scanrange),
+ as.integer(length(scantime)),
+ as.double(param$ppm * 1e-6),
+ as.integer(minCentroids),
+ as.integer(param$prefilter),
+ as.integer(param$noise),PACKAGE = "MetaboAnalystR")
+ )
+ }
+ )
+ }
+
+ ## Second stage: process the ROIs
+ peaklist <- list();
+ Nscantime <- length(scantime)
+ lf <- length(roiList)
+
+ ## print('\n Detecting chromatographic peaks ... \n % finished: ')
+ ## lp <- -1
+ message("Detecting chromatographic peaks in ", length(roiList),
+ " regions of interest ...", appendLF = FALSE)
+
+ roiScales = NULL
+
+ for (f in 1:lf) {
+
+
+ feat <- roiList[[f]]
+ N <- feat$scmax - feat$scmin + 1
+ peaks <- peakinfo <- NULL
+ mzrange <- c(feat$mzmin, feat$mzmax)
+ sccenter <- feat$scmin[1] + floor(N/2) - 1
+ scrange <- c(feat$scmin, feat$scmax)
+ ## scrange + noiserange, used for baseline detection and wavelet analysis
+ sr <- c(max(scanrange[1], scrange[1] - max(noiserange)),
+ min(scanrange[2], scrange[2] + max(noiserange)))
+ eic <- .Call(C_getEIC, mz, int, scanindex, as.double(mzrange),
+ as.integer(sr), as.integer(length(scanindex)),PACKAGE = "MetaboAnalystR")
+
+
+ ## eic <- rawEIC(object,mzrange=mzrange,scanrange=sr)
+ d <- eic$intensity
+ td <- sr[1]:sr[2]
+ scan.range <- c(sr[1], sr[2])
+ ## original mzROI range
+ idxs <- which(eic$scan %in% seq(scrange[1], scrange[2]))
+ mzROI.EIC <- list(scan=eic$scan[idxs], intensity=eic$intensity[idxs])
+ ## mzROI.EIC <- rawEIC(object,mzrange=mzrange,scanrange=scrange)
+ omz <- .Call(C_getMZ, mz, int, scanindex, as.double(mzrange),
+ as.integer(scrange), as.integer(length(scantime)))
+
+
+ ## omz <- rawMZ(object,mzrange=mzrange,scanrange=scrange)
+ if (all(omz == 0)) {
+ warning("centWave: no peaks found in ROI.")
+ next
+ }
+ od <- mzROI.EIC$intensity
+ otd <- mzROI.EIC$scan
+ if (all(od == 0)) {
+ warning("centWave: no peaks found in ROI.")
+ next
+ }
+
+ ## scrange + scRangeTol, used for gauss fitting and continuous
+ ## data above 1st baseline detection
+ ftd <- max(td[1], scrange[1] - scRangeTol) : min(td[length(td)],
+ scrange[2] + scRangeTol)
+ fd <- d[match(ftd, td)]
+
+ ## 1st type of baseline: statistic approach
+ if (N >= 10*minPeakWidth) {
+ ## in case of very long mass trace use full scan range
+ ## for baseline detection
+ noised <- .Call(C_getEIC, mz, int, scanindex, as.double(mzrange),
+ as.integer(scanrange), as.integer(length(scanindex)))$intensity
+ ## noised <- rawEIC(object,mzrange=mzrange,scanrange=scanrange)$intensity
+ } else {
+ noised <- d
+ }
+ ## 90% trimmed mean as first baseline guess
+
+
+ gz <- which(noised > 0);
+
+ if (length(gz) < 3*minPeakWidth){
+ noise <- mean(noised)
+ } else {
+ noise <- mean(noised[gz], trim=0.05)
+ }
+
+ firstBaselineCheck = TRUE
+ ## any continuous data above 1st baseline ?
+ if (firstBaselineCheck &
+ !continuousPtsAboveThreshold(fd, threshold = noise,
+ num = minPtsAboveBaseLine))
+ next
+ ## 2nd baseline estimate using not-peak-range
+ lnoise <- getLocalNoiseEstimate(d, td, ftd, noiserange, Nscantime,
+ threshold = noise,
+ num = minPtsAboveBaseLine)
+ ## Final baseline & Noise estimate
+ baseline <- max(1, min(lnoise[1], noise))
+ sdnoise <- max(1, lnoise[2])
+ sdthr <- sdnoise * param$snthresh
+ ## is there any data above S/N * threshold ?
+ if (!(any(fd - baseline >= sdthr)))
+ next
+ wCoefs <- MSW.cwt(d, scales = scales, wavelet = 'mexh')
+ if (!(!is.null(dim(wCoefs)) && any(wCoefs- baseline >= sdthr)))
+ next
+ if (td[length(td)] == Nscantime) ## workaround, localMax fails otherwise
+ wCoefs[nrow(wCoefs),] <- wCoefs[nrow(wCoefs) - 1, ] * 0.99
+ localMax <- MSW.getLocalMaximumCWT(wCoefs)
+ rL <- MSW.getRidge(localMax)
+ wpeaks <- sapply(rL,
+ function(x) {
+ w <- min(1:length(x),ncol(wCoefs))
+ any(wCoefs[x,w]- baseline >= sdthr)
+ })
+ if (any(wpeaks)) {
+ wpeaksidx <- which(wpeaks)
+ ## check each peak in ridgeList
+ for (p in 1:length(wpeaksidx)) {
+ opp <- rL[[wpeaksidx[p]]]
+ pp <- unique(opp)
+ if (length(pp) >= 1) {
+ dv <- td[pp] %in% ftd
+ if (any(dv)) { ## peaks in orig. data range
+ ## Final S/N check
+ if (any(d[pp[dv]]- baseline >= sdthr)) {
+ ## if(!is.null(roiScales)) {
+ ## allow roiScales to be a numeric of length 0
+ if(length(roiScales) > 0) {
+ ## use given scale
+ best.scale.nr <- which(scales == roiScales[[f]])
+ if(best.scale.nr > length(opp))
+ best.scale.nr <- length(opp)
+ } else {
+ ## try to decide which scale describes the peak best
+ inti <- numeric(length(opp))
+ irange <- rep(ceiling(scales[1]/2), length(opp))
+ for (k in 1:length(opp)) {
+ kpos <- opp[k]
+ r1 <- ifelse(kpos - irange[k] > 1,
+ kpos-irange[k], 1)
+ r2 <- ifelse(kpos + irange[k] < length(d),
+ kpos + irange[k], length(d))
+ inti[k] <- sum(d[r1:r2])
+ }
+ maxpi <- which.max(inti)
+ if (length(maxpi) > 1) {
+ m <- wCoefs[opp[maxpi], maxpi]
+ bestcol <- which(m == max(m),
+ arr.ind = TRUE)[2]
+ best.scale.nr <- maxpi[bestcol]
+ } else best.scale.nr <- maxpi
+ }
+
+ best.scale <- scales[best.scale.nr]
+ best.scale.pos <- opp[best.scale.nr]
+
+ pprange <- min(pp):max(pp)
+ ## maxint <- max(d[pprange])
+ lwpos <- max(1,best.scale.pos - best.scale)
+ rwpos <- min(best.scale.pos + best.scale, length(td))
+ p1 <- match(td[lwpos], otd)[1]
+ p2 <- match(td[rwpos], otd)
+ p2 <- p2[length(p2)]
+ if (is.na(p1)) p1 <- 1
+ if (is.na(p2)) p2 <- N
+ mz.value <- omz[p1:p2]
+ mz.int <- od[p1:p2]
+ maxint <- max(mz.int)
+
+ ## re-calculate m/z value for peak range
+ mzrange <- range(mz.value)
+ #mzmean <- do.call(mzCenterFun,
+ # list(mz = mz.value,
+ # intensity = mz.int))
+ mzmean <- weighted.mean(mz.value, mz.int)
+ ## Compute dppm only if needed
+ dppm <- NA
+ if (param$verboseColumns) {
+ if (length(mz.value) >= (minCentroids + 1)) {
+ dppm <- round(min(running(abs(diff(mz.value)) /
+ (mzrange[2] * 1e-6),
+ fun = max,
+ width = minCentroids)))
+ } else {
+ dppm <- round((mzrange[2] - mzrange[1]) /
+ (mzrange[2] * 1e-6))
+ }
+ }
+ peaks <- rbind(peaks,
+ c(mzmean,mzrange, ## mz
+ NA, NA, NA, ## rt, rtmin, rtmax,
+ NA, ## intensity (sum)
+ NA, ## intensity (-bl)
+ maxint, ## max intensity
+ round((maxint - baseline) / sdnoise), ## S/N Ratio
+ NA, ## Gaussian RMSE
+ NA,NA,NA, ## Gaussian Parameters
+ f, ## ROI Position
+ dppm, ## max. difference between the [minCentroids] peaks in ppm
+ best.scale, ## Scale
+ td[best.scale.pos],
+ td[lwpos],
+ td[rwpos], ## Peak positions guessed from the wavelet's (scan nr)
+ NA, NA)) ## Peak limits (scan nr)
+ peakinfo <- rbind(peakinfo,
+ c(best.scale, best.scale.nr,
+ best.scale.pos, lwpos, rwpos))
+ ## Peak positions guessed from the wavelet's
+ }
+ }
+ }
+ } ##for
+ } ## if
+
+ ## postprocessing
+ if (!is.null(peaks)) {
+ colnames(peaks) <- c(basenames, verbosenames)
+ colnames(peakinfo) <- c("scale", "scaleNr", "scpos",
+ "scmin", "scmax")
+ for (p in 1:dim(peaks)[1]) {
+ ## find minima (peak boundaries), assign rt and intensity values
+ if (param$integrate == 1) {
+ lm <- descendMin(wCoefs[, peakinfo[p, "scaleNr"]],
+ istart = peakinfo[p, "scpos"])
+ gap <- all(d[lm[1]:lm[2]] == 0) # looks like we got stuck in a gap right in the middle of the peak
+ if ((lm[1] == lm[2]) || gap) # fall-back
+ lm <- descendMinTol(
+ d, startpos = c(peakinfo[p, "scmin"],
+ peakinfo[p, "scmax"]),
+ maxDescOutlier)
+ } else {
+ lm <- descendMinTol(d, startpos = c(peakinfo[p, "scmin"],
+ peakinfo[p, "scmax"]),
+ maxDescOutlier)
+ }
+ ## Narrow peak rt boundaries by removing values below threshold
+ lm <- .narrow_rt_boundaries(lm, d)
+ lm_seq <- lm[1]:lm[2]
+ pd <- d[lm_seq]
+
+ peakrange <- td[lm]
+ peaks[p, "rtmin"] <- scantime[peakrange[1]]
+ peaks[p, "rtmax"] <- scantime[peakrange[2]]
+ peaks[p, "maxo"] <- max(pd)
+ pwid <- (scantime[peakrange[2]] - scantime[peakrange[1]]) /
+ (peakrange[2] - peakrange[1])
+ if (is.na(pwid))
+ pwid <- 1
+ peaks[p, "into"] <- pwid * sum(pd)
+ db <- pd - baseline
+ peaks[p, "intb"] <- pwid * sum(db[db > 0])
+ peaks[p, "lmin"] <- lm[1]
+ peaks[p, "lmax"] <- lm[2]
+
+ if (param$fitgauss) {
+ ## perform gaussian fits, use wavelets for inital parameters
+ td_lm <- td[lm_seq]
+ md <- max(pd)
+ d1 <- pd / md ## normalize data for gaussian error calc.
+ pgauss <- fitGauss(td_lm, pd,
+ pgauss = list(mu = peaks[p, "scpos"],
+ sigma = peaks[p, "scmax"] -
+ peaks[p, "scmin"],
+ h = peaks[p, "maxo"]))
+
+
+ rtime <- peaks[p, "scpos"]
+ if (!any(is.na(pgauss)) && all(pgauss > 0)) {
+ gtime <- td[match(round(pgauss$mu), td)]
+ if (!is.na(gtime)) {
+ rtime <- gtime
+ peaks[p, "mu"] <- pgauss$mu
+ peaks[p, "sigma"] <- pgauss$sigma
+ peaks[p, "h"] <- pgauss$h
+ peaks[p,"egauss"] <- sqrt(
+ (1 / length(td_lm)) *
+ sum(((d1 - gauss(td_lm, pgauss$h / md,
+ pgauss$mu, pgauss$sigma))^2)))
+ }
+ }
+ peaks[p, "rt"] <- scantime[rtime]
+ ## avoid fitting side effects
+ if (peaks[p, "rt"] < peaks[p, "rtmin"])
+ peaks[p, "rt"] <- scantime[peaks[p, "scpos"]]
+ } else
+ peaks[p, "rt"] <- scantime[peaks[p, "scpos"]]
+ }
+ peaks <- joinOverlappingPeaks(td, d, otd, omz, od, scantime,
+ scan.range, peaks, maxGaussOverlap)
+ }
+ if (!is.null(peaks)) {
+ peaklist[[length(peaklist) + 1]] <- peaks
+ }
+ } ## f
+
+
+ if (length(peaklist) == 0) {
+ warning("No peaks found!")
+
+ if (param$verboseColumns) {
+ nopeaks <- matrix(nrow = 0, ncol = length(basenames) +
+ length(verbosenames))
+ colnames(nopeaks) <- c(basenames, verbosenames)
+ } else {
+ nopeaks <- matrix(nrow = 0, ncol = length(basenames))
+ colnames(nopeaks) <- c(basenames)
+ }
+ message(" FAIL: none found!")
+ return(nopeaks)
+ }
+
+ p <- do.call(rbind, peaklist)
+
+
+ if (!param$verboseColumns)
+ p <- p[, basenames, drop = FALSE]
+
+ uorder <- order(p[, "into"], decreasing = TRUE)
+ pm <- as.matrix(p[,c("mzmin", "mzmax", "rtmin", "rtmax"), drop = FALSE])
+ uindex <- rectUnique(pm, uorder, param$mzdiff, ydiff = -0.00001) ## allow adjacent peaks
+ pr <- p[uindex, , drop = FALSE]
+ message(" OK: ", nrow(pr), " found.")
+
+ return(pr)
+
+}
+
+#'PeakPicking_MatchedFilter_slave
+#'@description PeakPicking_MatchedFilter_slave
+#'@author Zhiqiang Pang, Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@ref Smith, C.A. et al. 2006. Analytical Chemistry, 78, 779-787
+#'
+PeakPicking_MatchedFilter_slave <- function(x,param){
+
+ if (class(x)=="OnDiskMSnExp"){ # for raw data processing
+
+ scan.set <- MSnbase::spectra(x, BPPARAM = SerialParam());
+ rt <- MSnbase::rtime(x);
+
+ } else if (class(x) == "list") { # for parameters optimization
+
+ scan.set <- x;
+ rt <- unlist(lapply(x, MSnbase::rtime), use.names = FALSE);
+
+ }
+
+ ## 1. data & Param preparation
+ mzs <- lapply(scan.set, MSnbase::mz)
+ valsPerSpect <- lengths(mzs, FALSE)
+ mz = unlist(mzs, use.names = FALSE);
+ int = unlist(lapply(scan.set, MSnbase::intensity), use.names = FALSE);
+ scantime = rt;
+ mrange <- range(mz[mz > 0])
+ mass <- seq(floor(mrange[1] / param$binSize) * param$binSize,
+ ceiling(mrange[2] / param$binSize) * param$binSize,
+ by = param$binSize)
+ impute <- param$impute;
+ baseValue <- param$baseValue;
+ distance <- param$distance;
+ steps <- param$steps;
+ sigma <- param$sigma;
+ snthresh <-param$snthresh;
+ max <- param$max;
+ mzdiff <- param$mzdiff;
+ binSize <- param$binSize;
+ index <- param$index;
+
+
+ ## 2. Binning the data.
+ ## Create and translate settings for binYonX
+ toIdx <- cumsum(valsPerSpect)
+ fromIdx <- c(1L, toIdx[-length(toIdx)] + 1L)
+ shiftBy = TRUE
+ binFromX <- min(mass)
+ binToX <- max(mass)
+ ## binSize <- (binToX - binFromX) / (length(mass) - 1)
+ ## brks <- seq(binFromX - binSize/2, binToX + binSize/2, by = binSize)
+ brks <- breaks_on_nBins(fromX = binFromX, toX = binToX,
+ nBins = length(mass), shiftByHalfBinSize = TRUE)
+ binRes <- binYonX(mz, int,
+ breaks = brks,
+ fromIdx = fromIdx,
+ toIdx = toIdx,
+ baseValue = ifelse(impute == "none", yes = 0, no = NA),
+ sortedX = TRUE,
+ returnIndex = TRUE
+ )
+
+
+ if (length(toIdx) == 1)
+ binRes <- list(binRes)
+ bufMax <- do.call(cbind, lapply(binRes, function(z) return(z$index)))
+ bin_size <- binRes[[1]]$x[2] - binRes[[1]]$x[1]
+ ## Missing value imputation
+ if (missing(baseValue))
+ baseValue <- numeric()
+ if (length(baseValue) == 0)
+ baseValue <- min(int, na.rm = TRUE) / 2
+ if (missing(distance))
+ distance <- numeric()
+ if (length(distance) == 0)
+ distance <- floor(0.075 / bin_size)
+
+ binVals <- lapply(binRes, function(z) {
+ return(imputeLinInterpol(z$y, method = impute, distance = distance,
+ noInterpolAtEnds = TRUE,
+ baseValue = baseValue))
+ })
+
+ buf <- do.call(cbind, binVals)
+
+
+
+ bufidx <- 1L:length(mass)
+ lookahead <- steps-1
+ lookbehind <- 1
+
+ N <- nextn(length(scantime))
+ xrange <- range(scantime)
+ x <- c(0:(N/2), -(ceiling(N/2-1)):-1) *
+ (xrange[2]-xrange[1])/(length(scantime)-1)
+
+ filt <- -attr(eval(deriv3(~ 1/(sigma*sqrt(2*pi)) *
+ exp(-x^2/(2*sigma^2)), "x")), "hessian")
+ filt <- filt/sqrt(sum(filt^2))
+ filt <- fft(filt, inverse = TRUE)/length(filt)
+
+ cnames <- c("mz", "mzmin", "mzmax", "rt", "rtmin", "rtmax", "into", "intf",
+ "maxo", "maxf", "i", "sn")
+ num <- 0
+ ResList <- list()
+
+ ## Can not do much here, lapply/apply won't work because of the 'steps' parameter.
+ ## That's looping through the masses, i.e. rows of the profile matrix.
+ for (i in seq(length = length(mass)-steps+1)) {
+ ymat <- buf[bufidx[i:(i+steps-1)], , drop = FALSE]
+ ysums <- colMax(ymat)
+ yfilt <- filtfft(ysums, filt)
+ gmax <- max(yfilt)
+ for (j in seq(length = max)) {
+ maxy <- which.max(yfilt)
+ noise <- mean(ysums[ysums > 0])
+ ##noise <- mean(yfilt[yfilt >= 0])
+ sn <- yfilt[maxy]/noise
+ if (yfilt[maxy] > 0 && yfilt[maxy] > snthresh*noise && ysums[maxy] > 0) {
+ peakrange <- descendZero(yfilt, maxy)
+ intmat <- ymat[, peakrange[1]:peakrange[2], drop = FALSE]
+ mzmat <- matrix(mz[bufMax[bufidx[i:(i+steps-1)],
+ peakrange[1]:peakrange[2]]],
+ nrow = steps)
+ which.intMax <- which.colMax(intmat)
+ mzmat <- mzmat[which.intMax]
+ if (all(is.na(mzmat))) {
+ yfilt[peakrange[1]:peakrange[2]] <- 0
+ next
+ }
+ mzrange <- range(mzmat, na.rm = TRUE)
+ massmean <- weighted.mean(mzmat, intmat[which.intMax],
+ na.rm = TRUE)
+ ## This case (the only non-na m/z had intensity 0) was reported
+ ## by Gregory Alan Barding "binlin processing"
+ if(any(is.na(massmean))) {
+ massmean <- mean(mzmat, na.rm = TRUE)
+ }
+ pwid <- (scantime[peakrange[2]] - scantime[peakrange[1]]) /
+ (peakrange[2] - peakrange[1])
+ into <- pwid*sum(ysums[peakrange[1]:peakrange[2]])
+ intf <- pwid*sum(yfilt[peakrange[1]:peakrange[2]])
+ maxo <- max(ysums[peakrange[1]:peakrange[2]])
+ maxf <- yfilt[maxy]
+
+ yfilt[peakrange[1]:peakrange[2]] <- 0
+ num <- num + 1
+ ResList[[num]] <- c(massmean, mzrange[1], mzrange[2], maxy,
+ peakrange, into, intf, maxo, maxf, j, sn)
+ } else
+ break
+ }
+ }
+ if (length(ResList) == 0) {
+ rmat <- matrix(nrow = 0, ncol = length(cnames))
+ colnames(rmat) <- cnames
+ return(rmat)
+ }
+ rmat <- do.call(rbind, ResList)
+ if (is.null(dim(rmat))) {
+ rmat <- matrix(rmat, nrow = 1)
+ }
+ colnames(rmat) <- cnames
+ max <- max-1 + max*(steps-1) + max*ceiling(mzdiff/binSize)
+ if (index){
+ mzdiff <- mzdiff/binSize
+ } else {
+ rmat[, "rt"] <- scantime[rmat[, "rt"]]
+ rmat[, "rtmin"] <- scantime[rmat[, "rtmin"]]
+ rmat[, "rtmax"] <- scantime[rmat[, "rtmax"]]
+ }
+ ## Select for each unique mzmin, mzmax, rtmin, rtmax the largest peak
+ ## and report that.
+ uorder <- order(rmat[, "into"], decreasing = TRUE)
+ uindex <- rectUnique(rmat[, c("mzmin", "mzmax", "rtmin", "rtmax"),
+ drop = FALSE],
+ uorder, mzdiff)
+ rmat <- rmat[uindex,,drop = FALSE]
+
+ return(rmat)
+
+}
+
+#'PerformPeakGrouping
+#'@description PerformPeakGrouping
+#'@author Zhiqiang Pang, Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@ref Smith, C.A. et al. 2006. Analytical Chemistry, 78, 779-787
+#'
+PerformPeakGrouping<-function(mSet,param){
+
+ ## 1. Extract Information-------
+ peaks_0 <- mSet[["msFeatureData"]][["chromPeaks"]]
+
+ peaks <- cbind(peaks_0[, c("mz", "rt", "sample", "into"), drop = FALSE],
+ index = seq_len(nrow(peaks_0)))
+
+ if (!is.null(mSet[["onDiskData"]])){
+ sample_group<-as.character(mSet[["onDiskData"]]@phenoData@data[["sample_group"]]);
+
+ if (identical(sample_group,character(0))){
+ sample_group<-as.character(mSet[["onDiskData"]]@phenoData@data[["sample_name"]]);
+ }
+
+ } else {
+ sample_group<-as.character(mSet[["inMemoryData"]]@phenoData@data[["sample_group"]]);
+
+ if (identical(sample_group,character(0))){
+ sample_group<-as.character(mSet[["inMemoryData"]]@phenoData@data[["sample_name"]]);
+ }
+ }
+
+
+ sampleGroupNames <- unique(sample_group)
+ sampleGroupTable <- table(sample_group)
+ nSampleGroups <- length(sampleGroupTable)
+
+ ## 2. Order peaks matrix by mz-------
+ peaks <- peaks[order(peaks[, "mz"]), , drop = FALSE]
+ rownames(peaks) <- NULL
+ rtRange <- range(peaks[, "rt"])
+
+ ## 3. Define the mass slices and the index in the peaks matrix with an mz-------
+ mass <- seq(peaks[1, "mz"], peaks[nrow(peaks), "mz"] + param$binSize,
+ by = param$binSize / 2)
+ masspos <- findEqualGreaterM(peaks[, "mz"], mass)
+
+ densFrom <- rtRange[1] - 3 * param$bw
+ densTo <- rtRange[2] + 3 * param$bw
+
+
+ ## 4. Increase the number of sampling points for the density distribution.-------
+ densN <- max(512, 2 * 2^(ceiling(log2(diff(rtRange) / (param$bw / 2)))))
+ endIdx <- 0
+ message("Total of ", length(mass) - 1, " slices detected for processing... ",
+ appendLF = FALSE)
+ resL <- vector("list", (length(mass) - 2))
+
+ for (i in seq_len(length(mass)-2)) {
+ ## That's identifying overlapping mz slices.
+ startIdx <- masspos[i]
+ endIdx <- masspos[i + 2] - 1
+ if (endIdx - startIdx < 0)
+ next
+ resL[[i]] <- Densitygrouping_slave(peaks[startIdx:endIdx, , drop = FALSE],
+ bw = param$bw, densFrom = densFrom,
+ densTo = densTo, densN = densN,
+ sampleGroups = sample_group,
+ sampleGroupTable = sampleGroupTable,
+ minFraction = param$minFraction,
+ minSamples = param$minSamples,
+ maxFeatures = param$maxFeatures)
+ }
+
+ message("Done !")
+ res <- do.call(rbind, resL)
+
+ if (nrow(res)) {
+ ## Remove groups that overlap with more "well-behaved" groups
+ numsamp <- rowSums(
+ as.matrix(res[, (match("npeaks", colnames(res)) +1):(ncol(res) -1),
+ drop = FALSE]))
+ uorder <- order(-numsamp, res[, "npeaks"])
+
+ uindex <- rectUnique(
+ as.matrix(res[, c("mzmin", "mzmax", "rtmin", "rtmax"),
+ drop = FALSE]), uorder)
+ res <- res[uindex, , drop = FALSE]
+ rownames(res) <- NULL
+ }
+
+ df <- S4Vectors::DataFrame(res)
+ rownames(df) <- sprintf(paste0("FT", "%0", ceiling(log10(nrow(df) + 1L)), "d"),
+ seq(from = 1, length.out = nrow(df)))
+
+
+ mSet$FeatureGroupTable <- df
+
+ mSet
+}
+
+#'Densitygrouping_slave
+#'@description Densitygrouping_slave
+#'@author Zhiqiang Pang, Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@ref Smith, C.A. et al. 2006. Analytical Chemistry, 78, 779-787
+#'
+Densitygrouping_slave <- function(x, bw, densFrom, densTo, densN, sampleGroups,
+ sampleGroupTable, minFraction,
+ minSamples, maxFeatures) {
+ den <- density(x[, "rt"], bw = bw, from = densFrom, to = densTo,
+ n = densN)
+ maxden <- max(den$y)
+ deny <- den$y
+ sampleGroupNames <- names(sampleGroupTable)
+ nSampleGroups <- length(sampleGroupNames)
+ col_nms <- c("mzmed", "mzmin", "mzmax", "rtmed", "rtmin", "rtmax",
+ "npeaks", sampleGroupNames)
+ res_mat <- matrix(nrow = 0, ncol = length(col_nms),
+ dimnames = list(character(), col_nms))
+ res_idx <- list()
+ while (deny[maxy <- which.max(deny)] > maxden / 20 && nrow(res_mat) <
+ maxFeatures) {
+ grange <- descendMin(deny, maxy)
+ deny[grange[1]:grange[2]] <- 0
+ gidx <- which(x[,"rt"] >= den$x[grange[1]] &
+ x[,"rt"] <= den$x[grange[2]])
+ ## Determine the sample group of the samples in which the peaks
+ ## were detected and check if they correspond to the required limits.
+ tt <- table(sampleGroups[unique(x[gidx, "sample"])])
+ if (!any(tt / sampleGroupTable[names(tt)] >= minFraction &
+ tt >= minSamples))
+ next
+ gcount <- rep(0, length(sampleGroupNames))
+ names(gcount) <- sampleGroupNames
+ gcount[names(tt)] <- as.numeric(tt)
+ res_mat <- rbind(res_mat,
+ c(median(x[gidx, "mz"]),
+ range(x[gidx, "mz"]),
+ median(x[gidx, "rt"]),
+ range(x[gidx, "rt"]),
+ length(gidx),
+ gcount)
+ )
+ res_idx <- c(res_idx, list(unname(sort(x[gidx, "index"]))))
+ }
+
+ res <- as.data.frame(res_mat)
+ res$peakidx <- res_idx
+ res
+}
+
+#'PerformPeakAlignment
+#'@description PerformPeakAlignment
+#'@param mSet the mSet object generated by PerformPeakPicking function.
+#'@param param param list generated by updateRawSpectraParam function.
+#'@author Zhiqiang Pang, Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'@ref Smith, C.A. et al. 2006. Analytical Chemistry, 78, 779-787
+#'
+PerformPeakAlignment<-function(mSet,param){
+ ## 1~4. Peak Grouping---------
+ mSet<-PerformPeakGrouping(mSet,param)
+ ## 5. Adjust Retention Time-------
+
+ # 1). Group Matrix-------
+ peaks_0 <- mSet[["msFeatureData"]][["chromPeaks"]]
+
+ if (!is.null(mSet[["onDiskData"]])){
+ subs <- seq_along(mSet[["onDiskData"]]@phenoData@data[["sample_name"]]);
+ format <- "onDiskData"
+ } else {
+ subs <- seq_along(mSet[["inMemoryData"]]@phenoData@data[["sample_name"]]);
+ format <- "inMemoryData"
+ }
+ nSamples <- length(subs)
+
+ subset_names <- original_names <- mSet[["msFeatureData"]][["chromPeakData"]]@rownames
+ mSet[["FeatureGroupTable"]]$peakidx <- lapply(mSet[["FeatureGroupTable"]]$peakidx, function(z) {
+ idx <- base::match(original_names[z], subset_names)
+ idx[!is.na(idx)]
+ })
+ peakIndex_0 <- mSet[["FeatureGroupTable"]][lengths(mSet[["FeatureGroupTable"]]$peakidx) > 0, ]
+ peakIndex <- .peakIndex(peakIndex_0)
+
+ pkGrpMat <- .getPeakGroupsRtMatrix(peaks = peaks_0,
+ peakIndex = peakIndex,
+ sampleIndex = subs,
+ missingSample = nSamples - (nSamples * param$minFraction),
+ extraPeaks = param$extraPeaks
+ )
+
+ colnames(pkGrpMat) <- mSet[[format]]@phenoData@data[["sample_name"]][subs]
+
+ # 2). RT adjustment-------
+ rtime_0 <- rtime(mSet[[format]])
+
+ tmp <- split(rtime_0, fromFile(mSet[[format]]))
+ rtime <- vector("list", length(fileNames(mSet[[format]])))
+ names(rtime) <- as.character(1:length(rtime))
+ rtime[as.numeric(names(tmp))] <- tmp
+
+ res <- RT.Adjust_Slave(peaks_0,
+ peakIndex = peakIndex_0$peakidx,
+ rtime = rtime,
+ minFraction = param$minFraction,
+ extraPeaks = param$extraPeaks,
+ smooth = param$smooth,
+ span = param$span,
+ family = param$family,
+ peakGroupsMatrix = pkGrpMat,
+ subsetAdjust = param$subsetAdjust
+ )
+
+ message("Applying retention time adjustment to the identified chromatographic peaks ... ",appendLF = FALSE)
+
+ fts <- .applyRtAdjToChromPeaks(mSet[["msFeatureData"]][["chromPeaks"]],
+ rtraw = rtime,
+ rtadj = res)
+ mSet[["msFeatureData"]][["pkGrpMat_Raw"]] <- pkGrpMat;
+ mSet[["msFeatureData"]][["chromPeaks"]] <- fts;
+ mSet[["msFeatureData"]][["adjustedRT"]] <- res;
+ #
+ message("Done !")
+
+ ## 6~9. Peak Grouping Again---------
+ mSet<-PerformPeakGrouping(mSet,param)
+ ## 10. Return------
+ return(mSet)
+}
+
+#'RT.Adjust_Slave
+#'@description RT.Adjust_Slave
+#'@author Zhiqiang Pang, Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@ref Smith, C.A. et al. 2006. Analytical Chemistry, 78, 779-787
+#'
+RT.Adjust_Slave <-
+ function(peaks, peakIndex, rtime, minFraction = 0.9, extraPeaks = 1,
+ smooth = c("loess", "linear"), span = 0.2,
+ family = c("gaussian", "symmetric"),
+ peakGroupsMatrix = matrix(ncol = 0, nrow = 0),
+ subsetAdjust = c("average", "previous")) {
+ ## minFraction
+ if (any(minFraction > 1) | any(minFraction < 0))
+ stop("'minFraction' has to be between 0 and 1!")
+ ## Check peakIndex:
+ if (any(!(unique(unlist(peakIndex)) %in% seq_len(nrow(peaks)))))
+ stop("Some indices listed in 'peakIndex' are outside of ",
+ "1:nrow(peaks)!")
+ ## Check rtime:
+ if (!is.list(rtime))
+ stop("'rtime' should be a list of numeric vectors with the retention ",
+ "times of the spectra per sample!")
+ if (!all(unlist(lapply(rtime, is.numeric), use.names = FALSE)))
+ stop("'rtime' should be a list of numeric vectors with the retention ",
+ "times of the spectra per sample!")
+ if (length(rtime) != max(peaks[, "sample"]))
+ stop("The length of 'rtime' does not match with the total number of ",
+ "samples according to the 'peaks' matrix!")
+ total_samples <- length(rtime)
+ subset <- seq_len(total_samples)
+ ## Translate minFraction to number of allowed missing samples.
+ nSamples <- length(subset)
+ missingSample <- nSamples - (nSamples * minFraction)
+ ## Remove peaks not present in "subset" from the peakIndex
+ peaks_in_subset <- which(peaks[, "sample"] %in% subset)
+ peakIndex <- lapply(peakIndex, function(z) z[z %in% peaks_in_subset])
+ ## Check if we've got a valid peakGroupsMatrix
+ ## o Same number of samples.
+ ## o range of rt values is within the rtime.
+ if (nrow(peakGroupsMatrix)) {
+ if (ncol(peakGroupsMatrix) != nSamples)
+ stop("'peakGroupsMatrix' has to have the same number of columns ",
+ "as there are samples!")
+ pg_range <- range(peakGroupsMatrix, na.rm = TRUE)
+ rt_range <- range(rtime)
+ if (!(pg_range[1] >= rt_range[1] & pg_range[2] <= rt_range[2]))
+ stop("The retention times in 'peakGroupsMatrix' have to be within",
+ " the retention time range of the experiment!")
+ rt <- peakGroupsMatrix
+ } else
+ rt <- .getPeakGroupsRtMatrix(peaks, peakIndex, subset,
+ missingSample, extraPeaks)
+ if (ncol(rt) != length(subset))
+ stop("Length of 'subset' and number of columns of the peak group ",
+ "matrix do not match.")
+ ## Fix for issue #175
+ if (length(rt) == 0)
+ stop("No peak groups found in the data for the provided settings")
+ message("Performing retention time correction using ", nrow(rt),
+ " peak groups.")
+
+ ## Calculate the deviation of each peak group in each sample from its
+ ## median
+ rtdev <- rt - apply(rt, 1, median, na.rm = TRUE)
+
+ if (smooth == "loess") {
+ mingroups <- min(colSums(!is.na(rt)))
+ if (mingroups < 4) {
+ smooth <- "linear"
+ warning("Too few peak groups for 'loess', reverting to linear",
+ " method")
+ } else if (mingroups * span < 4) {
+ span <- 4 / mingroups
+ warning("Span too small for 'loess' and the available number of ",
+ "peak groups, resetting to ", round(span, 2))
+ }
+ }
+
+ rtdevsmo <- vector("list", nSamples)
+
+ ## Code for checking to see if retention time correction is overcorrecting
+ rtdevrange <- range(rtdev, na.rm = TRUE)
+ warn.overcorrect <- FALSE
+ warn.tweak.rt <- FALSE
+
+ rtime_adj <- rtime
+ ## Adjust samples in subset.
+ for (i in seq_along(subset)) {
+ i_all <- subset[i] # Index of sample in whole dataset.
+ pts <- na.omit(data.frame(rt = rt[, i], rtdev = rtdev[, i]))
+
+ ## order the data.frame such that rt and rtdev are increasingly ordered.
+ pk_idx <- order(pts$rt, pts$rtdev)
+ pts <- pts[pk_idx, ]
+ if (smooth == "loess") {
+ lo <- suppressWarnings(loess(rtdev ~ rt, pts, span = span,
+ degree = 1, family = family))
+
+ rtdevsmo[[i]] <- na.flatfill(
+ predict(lo, data.frame(rt = rtime[[i_all]])))
+ ## Remove singularities from the loess function
+ rtdevsmo[[i]][abs(rtdevsmo[[i]]) >
+ quantile(abs(rtdevsmo[[i]]), 0.9,
+ na.rm = TRUE) * 2] <- NA
+ if (length(naidx <- which(is.na(rtdevsmo[[i]]))))
+ rtdevsmo[[i]][naidx] <- suppressWarnings(
+ approx(na.omit(data.frame(rtime[[i_all]], rtdevsmo[[i]])),
+ xout = rtime[[i_all]][naidx], rule = 2)$y
+ )
+
+ ## Check if there are adjusted retention times that are not ordered
+ ## increasingly. If there are, search for each first unordered rt
+ ## the next rt that is larger and linearly interpolate the values
+ ## in between (see issue #146 for an illustration).
+ while (length(decidx <- which(diff(rtime[[i_all]] - rtdevsmo[[i]]) < 0))) {
+ warn.tweak.rt <- TRUE ## Warn that we had to tweak the rts.
+ rtadj <- rtime[[i_all]] - rtdevsmo[[i]]
+ rtadj_start <- rtadj[decidx[1]] ## start interpolating from here
+ ## Define the
+ next_larger <- which(rtadj > rtadj[decidx[1]])
+ if (length(next_larger) == 0) {
+ ## Fix if there is no larger adjusted rt up to the end.
+ next_larger <- length(rtadj) + 1
+ rtadj_end <- rtadj_start
+ } else {
+ next_larger <- min(next_larger)
+ rtadj_end <- rtadj[next_larger]
+ }
+ ## linearly interpolate the values in between.
+ adj_idxs <- (decidx[1] + 1):(next_larger - 1)
+ incr <- (rtadj_end - rtadj_start) / length(adj_idxs)
+ rtdevsmo[[i]][adj_idxs] <- rtime[[i_all]][adj_idxs] -
+ (rtadj_start + (1:length(adj_idxs)) * incr)
+ }
+
+ rtdevsmorange <- range(rtdevsmo[[i]])
+ if (any(rtdevsmorange / rtdevrange > 2))
+ warn.overcorrect <- TRUE
+ } else {
+ if (nrow(pts) < 2) {
+ stop("Not enough peak groups even for linear smoothing ",
+ "available!")
+ }
+ ## Use lm instead?
+ fit <- lsfit(pts$rt, pts$rtdev)
+ rtdevsmo[[i]] <- rtime[[i_all]] * fit$coef[2] + fit$coef[1]
+ ptsrange <- range(pts$rt)
+ minidx <- rtime[[i_all]] < ptsrange[1]
+ maxidx <- rtime[[i_all]] > ptsrange[2]
+ rtdevsmo[[i]][minidx] <- rtdevsmo[[i]][head(which(!minidx), n = 1)]
+ rtdevsmo[[i]][maxidx] <- rtdevsmo[[i]][tail(which(!maxidx), n = 1)]
+ }
+ ## Finally applying the correction
+ rtime_adj[[i_all]] <- rtime[[i_all]] - rtdevsmo[[i]]
+ }
+
+ if (warn.overcorrect) {
+ warning("Fitted retention time deviation curves exceed points by more",
+ " than 2x. This is dangerous and the algorithm is probably ",
+ "overcorrecting your data. Consider increasing the span ",
+ "parameter or switching to the linear smoothing method.")
+ }
+
+ if (warn.tweak.rt) {
+ warning(call. = FALSE, "Adjusted retention times had to be ",
+ "re-adjusted for some files to ensure them being in the same",
+ " order than the raw retention times. A call to ",
+ "'dropAdjustedRtime' might thus fail to restore retention ",
+ "times of chromatographic peaks to their original values. ",
+ "Eventually consider to increase the value of the 'span' ",
+ "parameter.")
+ }
+ rtime_adj
+ }
+
+#'PerformPeakFiling
+#'@description PerformPeakFiling
+#'@param mSet the mSet object generated by PerformPeakPicking function.
+#'@param param param list generated by updateRawSpectraParam function.
+#'@param BPPARAM parallel method used for data processing. Default is bpparam().
+#'@author Zhiqiang Pang, Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'@ref Smith, C.A. et al. 2006. Analytical Chemistry, 78, 779-787
+#'
+PerformPeakFiling<-function(mSet,param,BPPARAM=bpparam()){
+
+ ## Preparing Something
+ print("Starting peak filling!")
+ fixedRt <- fixedMz <- expandRt <- expandMz <- 0
+
+ if (is.null(param$ppm)){
+ ppm <-10
+ } else {
+ ppm <- param$ppm;
+ }
+
+ message("Defining peak areas for filling-in...",
+ appendLF = FALSE)
+
+ aggFunLow <- median
+ aggFunHigh <- median
+
+ tmp_pks <- mSet$msFeatureData$chromPeaks[, c("rtmin", "rtmax", "mzmin", "mzmax")]
+ fdef <- mSet$FeatureGroupTable
+
+ pkArea <- do.call(rbind,lapply(fdef$peakidx, function(z) {
+ pa <- c(aggFunLow(tmp_pks[z, 1]),
+ aggFunHigh(tmp_pks[z, 2]),
+ aggFunLow(tmp_pks[z, 3]),
+ aggFunHigh(tmp_pks[z, 4]))
+ ## Check if we have to apply ppm replacement:
+ if (ppm != 0) {
+ mzmean <- mean(pa[3:4])
+ tittle <- mzmean * (ppm / 2) / 1E6
+ if ((pa[4] - pa[3]) < (tittle * 2)) {
+ pa[3] <- mzmean - tittle
+ pa[4] <- mzmean + tittle
+ }
+ }
+ ## Expand it.
+ if (expandRt != 0) {
+ diffRt <- (pa[2] - pa[1]) * expandRt / 2
+ pa[1] <- pa[1] - diffRt
+ pa[2] <- pa[2] + diffRt
+ }
+ if (expandMz != 0) {
+ diffMz <- (pa[4] - pa[3]) * expandMz / 2
+ pa[3] <- pa[3] - diffMz
+ pa[4] <- pa[4] + diffMz
+ }
+ if (fixedMz != 0) {
+ pa[3] <- pa[3] - fixedMz
+ pa[4] <- pa[4] + fixedMz
+ }
+ if (fixedRt != 0) {
+ pa[1] <- pa[1] - fixedRt
+ pa[2] <- pa[2] + fixedRt
+ }
+ pa
+ }))
+
+ rm(tmp_pks)
+ message(".", appendLF = FALSE)
+ colnames(pkArea) <- c("rtmin", "rtmax", "mzmin", "mzmax")
+ ## Add mzmed column - needed for MSW peak filling.
+ pkArea <- cbind(group_idx = 1:nrow(pkArea), pkArea,
+ mzmed = as.numeric(fdef$mzmed))
+
+ if (class(mSet[[2]]) == "OnDiskMSnExp"){
+ format <- "onDiskData"
+ } else {
+ format <- "inMemoryData"
+ }
+
+ fNames <- mSet[[format]]@phenoData@data[["sample_name"]]
+ pks <- mSet$msFeatureData$chromPeaks
+
+ pkGrpVal <-
+ .feature_values(pks = pks, fts = mSet$FeatureGroupTable,
+ method = "medret", value = "into",
+ intensity = "into", colnames = fNames,
+ missing = NA)
+
+ message(".", appendLF = FALSE)
+ ## Check if there is anything to fill...
+ if (!any(is.na(rowSums(pkGrpVal)))) {
+ message("No missing peaks present.")
+ return(mSet)
+ }
+ message(".", appendLF = FALSE)
+ ## Split the object by file and define the peaks for which
+ pkAreaL <- objectL <- vector("list", length(fNames))
+
+
+ ## We need "only" a list of OnDiskMSnExp, one for each file but
+ ## instead of filtering by file we create small objects to keep
+ ## memory requirement to a minimum.
+ if (format == "onDiskData"){
+
+ req_fcol <- requiredFvarLabels("OnDiskMSnExp")
+ min_fdata <- mSet[[format]]@featureData@data[, req_fcol]
+
+ ###
+ res <- mSet[["msFeatureData"]][["adjustedRT"]]
+ res <- unlist(res, use.names = FALSE)
+
+ fidx <- fData(mSet[[format]])$fileIdx # a issue for inmemory data
+ names(fidx) <- featureNames(mSet[[format]])
+ sNames <- unlist(split(featureNames(mSet[[format]]), fidx),
+ use.names = FALSE)
+
+ names(res) <- sNames
+ res <- res[featureNames(mSet[[format]])]
+
+ min_fdata$retentionTime <- res
+
+ for (i in 1:length(mSet[[format]]@phenoData@data[["sample_name"]])) {
+
+ fd <- min_fdata[min_fdata$fileIdx == i, ]
+ fd$fileIdx <- 1
+
+ objectL[[i]] <- new(
+ "OnDiskMSnExp",
+ processingData = new("MSnProcess",
+ files = mSet[[format]]@processingData@files[i]),
+ featureData = new("AnnotatedDataFrame", fd),
+ phenoData = new("NAnnotatedDataFrame",
+ data.frame(sampleNames = "1")),
+ experimentData = new("MIAPE",
+ instrumentManufacturer = "a",
+ instrumentModel = "a",
+ ionSource = "a",
+ analyser = "a",
+ detectorType = "a"))
+
+ ## Want to extract intensities only for peaks that were not
+ ## found in a sample.
+
+ pkAreaL[[i]] <- pkArea[is.na(pkGrpVal[, i]), , drop = FALSE]
+ }
+
+ message(" OK\nStart integrating peak areas from original files")
+
+ cp_colnames <- colnames(mSet[["msFeatureData"]][["chromPeaks"]])
+
+ ## Extraction designed for centWave
+ res <- bpmapply(FUN = .getChromPeakData,
+ objectL,
+ pkAreaL,
+ as.list(1:length(objectL)),
+ MoreArgs = list(cn = cp_colnames,
+ mzCenterFun = "weighted.mean"),
+ BPPARAM = BPPARAM,
+ SIMPLIFY = FALSE)
+
+
+ } else {
+
+ message(" OK\nStart integrating peak areas from original files")
+
+ mzCenterFun = "weighted.mean"
+
+ scan_set<-names(mSet[[format]]@assayData);
+ scan_set_ordered <- sort(scan_set);
+
+ assayData <- sapply(scan_set_ordered, FUN = function(x){mSet[[format]]@assayData[[x]]})
+
+ #assayData <- lapply(scan_set,FUN=function(x){mSet[[format]]@assayData[[x]]});
+ assayData <- split(assayData,fromFile(mSet[[format]]));
+
+
+ rtim_all <- split(rtime(mSet[[format]]),fromFile(mSet[[format]]))
+ filesname <- basename(MSnbase::fileNames(mSet[[format]]))
+ res_new <-list()
+
+ for (ii in 1:length(mSet[[format]]@phenoData@data[["sample_name"]])){
+
+ cn <-colnames(mSet[["msFeatureData"]][["chromPeaks"]])
+ peakArea <- pkArea[is.na(pkGrpVal[, ii]), , drop = FALSE];
+
+ ncols <- length(cn)
+ res <- matrix(ncol = ncols, nrow = nrow(peakArea))
+ colnames(res) <- cn
+
+ res[, "sample"] <- ii
+ res[, c("mzmin", "mzmax")] <- peakArea[, c("mzmin", "mzmax")]
+ ## Load the data
+ message("Requesting ", nrow(res), " peaks from ",
+ filesname[ii], " ... ", appendLF = FALSE)
+
+ spctr <- assayData[[ii]]
+
+ mzs <- lapply(spctr, mz)
+ valsPerSpect <- lengths(mzs)
+ ints <- unlist(lapply(spctr, intensity), use.names = FALSE)
+ rm(spctr)
+
+ mzs <- unlist(mzs, use.names = FALSE)
+ mzs_range <- range(mzs)
+ rtim <- rtim_all[[ii]]
+ rtim_range <- range(rtim)
+
+ for (i in seq_len(nrow(res))) {
+ rtr <- peakArea[i, c("rtmin", "rtmax")]
+ mzr <- peakArea[i, c("mzmin", "mzmax")]
+ ## If the rt range is completely out; additional fix for #267
+ if (rtr[2] < rtim_range[1] | rtr[1] > rtim_range[2] |
+ mzr[2] < mzs_range[1] | mzr[1] > mzs_range[2]) {
+ res[i, ] <- rep(NA_real_, ncols)
+ next
+ }
+ ## Ensure that the mz and rt region is within the range of the data.
+ rtr[1] <- max(rtr[1], rtim_range[1])
+ rtr[2] <- min(rtr[2], rtim_range[2])
+ mzr[1] <- max(mzr[1], mzs_range[1])
+ mzr[2] <- min(mzr[2], mzs_range[2])
+ mtx <- .rawMat(mz = mzs, int = ints, scantime = rtim,
+ valsPerSpect = valsPerSpect, rtrange = rtr,
+ mzrange = mzr)
+ if (length(mtx)) {
+ if (any(!is.na(mtx[, 3]))) {
+
+ res[i, "into"] <- sum(mtx[, 3], na.rm = TRUE) *
+ ((rtr[2] - rtr[1]) /
+ max(1, (sum(rtim >= rtr[1] & rtim <= rtr[2]) - 1)))
+ maxi <- which.max(mtx[, 3])
+ res[i, c("rt", "maxo")] <- mtx[maxi[1], c(1, 3)]
+ res[i, c("rtmin", "rtmax")] <- rtr
+ ## Calculate the intensity weighted mean mz
+ meanMz <- do.call(mzCenterFun, list(mtx[, 2], mtx[, 3]))
+ if (is.na(meanMz)) meanMz <- mtx[maxi[1], 2]
+ res[i, "mz"] <- meanMz
+ } else {
+ res[i, ] <- rep(NA_real_, ncols)
+ }
+ } else {
+ res[i, ] <- rep(NA_real_, ncols)
+ }
+ }
+
+
+ message("got ", sum(!is.na(res[, "into"])), ".")
+
+ res_new[[ii]] <- res
+ pkAreaL[[ii]] <- pkArea[is.na(pkGrpVal[, ii]), , drop = FALSE]
+
+ }
+
+ res <-res_new
+
+
+}
+
+
+ res <- do.call(rbind, res)
+ ## cbind the group_idx column to track the feature/peak group.
+ res <- cbind(res, group_idx = do.call(rbind, pkAreaL)[, "group_idx"])
+ ## Remove those without a signal
+ res <- res[!is.na(res[, "into"]), , drop = FALSE]
+
+
+
+ if (nrow(res) == 0) {
+ warning("Could not integrate any signal for the missing ",
+ "peaks! Consider increasing 'expandMz' and 'expandRt'.")
+ return(mSet)
+ }
+
+ ## Get the msFeatureData:
+ newFd <- mSet$msFeatureData
+
+ incr <- nrow(mSet$msFeatureData$chromPeaks)
+ for (i in unique(res[, "group_idx"])) {
+ fdef$peakidx[[i]] <- c(fdef$peakidx[[i]],
+ (which(res[, "group_idx"] == i) + incr))
+ }
+ ## Define IDs for the new peaks; include fix for issue #347
+ maxId <- max(as.numeric(sub("^CP", "",
+ rownames(mSet[["msFeatureData"]][["chromPeaks"]]))))
+ if (maxId < 1)
+ stop("chromPeaks matrix lacks rownames; please update ",
+ "'object' with the 'updateObject' function.")
+ toId <- maxId + nrow(res)
+
+ rownames(res) <- sprintf(
+ paste0("CP", "%0", ceiling(log10(toId + 1L)), "d"),
+ (maxId + 1L):toId)
+
+ newFd[["chromPeaks"]] <- rbind(mSet[["msFeatureData"]][["chromPeaks"]],
+ res[, -ncol(res)])
+
+ cpd <- newFd$chromPeakData[rep(1L, nrow(res)), , drop = FALSE]
+ cpd[,] <- NA
+ cpd$ms_level <- as.integer(1)
+ cpd$is_filled <- TRUE
+
+ newFd$chromPeakData <- rbind(newFd$chromPeakData, cpd)
+ rownames(newFd$chromPeakData) <- rownames(newFd$chromPeaks)
+
+ mSet$msFeatureData <- newFd
+ mSet$FeatureGroupTable <- fdef
+
+ mSet$xcmsSet <- mSet2xcmsSet(mSet)
+
+ return(mSet)
+
+}
+
+#'mSet2xcmsSet
+#'@description mSet2xcmsSet
+#'@author Zhiqiang Pang, Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@ref Smith, C.A. et al. 2006. Analytical Chemistry, 78, 779-787
+#'
+mSet2xcmsSet <- function(mSet) {
+ xs <- new("xcmsSet")
+
+ xs@peaks <- mSet[["msFeatureData"]][["chromPeaks"]]
+
+ fgs <- mSet$FeatureGroupTable
+
+ xs@groups <- S4Vectors::as.matrix(fgs[, -ncol(fgs)])
+ rownames(xs@groups) <- NULL
+ xs@groupidx <- fgs$peakidx
+
+ rts <- list()
+
+ if (class(mSet[[2]]) == "OnDiskMSnExp"){
+ format <- "onDiskData"
+ } else {
+ format <- "inMemoryData"
+ }
+
+
+ ## Ensure we're getting the raw rt
+ rts$raw <- rtime(mSet[[format]])
+ rts$corrected <- mSet[["msFeatureData"]][["adjustedRT"]]
+
+ xs@rt <- rts
+
+ ## @phenoData
+ xs@phenoData <- pData(mSet[[format]])
+ ## @filepaths
+ xs@filepaths <- fileNames(mSet[[format]])
+
+ ## @profinfo (list)
+ profMethod <- NA
+ profStep <- NA
+ profParam <- list()
+ ## If we've got any MatchedFilterParam we can take the values from there
+
+ ## @mslevel <- msLevel?
+ xs@mslevel <- 1
+
+ ## @scanrange
+ xs@scanrange <- range(scanIndex(mSet[[format]]))
+
+ ## @filled ... not yet.
+ if (any(mSet$msFeatureData$chromPeakData$is_filled)) {
+ fld <- which(mSet$msFeatureData$chromPeakData$is_filled)
+ xs@filled <- as.integer(fld)
+ }
+
+ return(xs)
+}
+
+#'updateRawSpectraParam
+#'@description updateRawSpectraParam
+#'@param Params object generated by SetPeakParams function.
+#'@author Zhiqiang Pang, Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'@export
+#'@ref Smith, C.A. et al. 2006. Analytical Chemistry, 78, 779-787
+#' Mcgill University
+#' License: GNU GPL (>= 2)
+updateRawSpectraParam <- function (Params){
+
+ param <- list();
+
+ # 0. Method Define
+ param$Peak_method <- Params$Peak_method
+ param$RT_method <- Params$RT_method
+
+ # 1.1 update peak picking params - centWave
+ if (param$Peak_method == "centWave"){
+
+ param$ppm <- as.numeric(Params[["ppm"]]);
+ param$peakwidth <- c(as.numeric(Params[["min_peakwidth"]]),
+ as.numeric(Params[["max_peakwidth"]]));
+ param$snthresh <- as.numeric(Params[["snthresh"]]);
+ param$prefilter <- c(as.numeric(Params[["prefilter"]]),
+ as.numeric(Params[["value_of_prefilter"]]));
+ param$roiList <- list();
+ param$firstBaselineCheck <- T;
+ param$roiScales <- numeric(0);
+
+ param$mzCenterFun <- Params[["mzCenterFun"]];
+ param$integrate <- Params[["integrate"]];
+ param$mzdiff <- as.numeric(Params[["mzdiff"]]);
+ param$fitgauss <- as.logical(Params[["fitgauss"]]);
+ param$noise <- as.numeric(Params[["noise"]]);
+ param$verboseColumns <- as.logical(Params[["verbose.columns"]]);
+
+ param$binSize <-0.25; # density Param
+
+ } else if (param$Peak_method == "matchedFilter") {
+
+ param$fwhm <- as.numeric(Params$fwhm);
+ param$sigma <- as.numeric(Params$sigma)
+ param$steps <- as.numeric(Params$steps)
+ param$snthresh <- as.numeric(Params$snthresh)
+
+ param$mzdiff <- as.numeric(Params$mzdiff)
+ param$bw <- as.numeric(Params$bw)
+ param$max <- as.numeric(Params$max)
+
+ param$impute <- "none";
+ param$baseValue<- numeric(0);
+ param$distance<- numeric(0);
+ param$index<- F;
+
+ param$binSize <- 0.1;
+ }
+ # 2.1 update grouping params - density
+
+ param$bw<-as.numeric(Params[["bw"]]);
+ param$minFraction <- as.numeric(Params[["minFraction"]]);
+ param$minSamples <- as.numeric(Params[["minSamples"]]);
+ param$maxFeatures <- as.numeric(Params[["maxFeatures"]]);
+
+ # 3.1 update RT correction params - peakgroup
+
+ param$extraPeaks <- as.numeric(Params[["extra"]]);
+
+ param$smooth <- Params[["smooth"]];
+ param$span <- as.numeric(Params[["span"]]);
+ param$family <- Params[["family"]];
+
+ param$subsetAdjust <- "average";
+
+ # Finished !
+ print(paste("Parameters for",param$Peak_method, "have been successfully parsed!"))
+
+ return(param)
+
+}
+
+#'creatPeakTable
+#'@description creatPeakTable
+#'@author Zhiqiang Pang, Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'
+creatPeakTable <- function(xset){
+
+ if (length(xset@phenoData[["sample_name"]]) == 1) {
+ return(xset@peaks)
+ }
+
+ groupmat <- xset@groups
+
+ ts <- data.frame(cbind(groupmat,.groupval(xset, value="into")), row.names = NULL)
+
+ cnames <- colnames(ts)
+
+ if (cnames[1] == 'mzmed') {
+ cnames[1] <- 'mz'
+ } else {
+ stop ('mzmed column missing')
+ }
+ if (cnames[4] == 'rtmed') {
+ cnames[4] <- 'rt'
+ } else {
+ stop ('mzmed column missing')
+ }
+
+ colnames(ts) <- cnames
+
+ return(ts)
+
+}
+
+
+######## -----------=========== Internal Functions From XCMS ===========------------- #
+#
+#' @references Smith, C.A., Want, E.J., O'Maille, G., Abagyan,R., Siuzdak, G. (2006).
+# "XCMS: Processing mass spectrometry data for metabolite profiling using nonlinear
+# peak alignment, matching and identification." Analytical Chemistry, 78, 779-787.
+
+continuousPtsAboveThreshold <- function(y, threshold, num, istart = 1) {
+ if (!is.double(y)) y <- as.double(y)
+ if (.C(C_continuousPtsAboveThreshold,
+ y,
+ as.integer(istart-1),
+ length(y),
+ threshold = as.double(threshold),
+ num = as.integer(num),
+ n = integer(1))$n > 0) TRUE else FALSE
+}
+getLocalNoiseEstimate <- function(d, td, ftd, noiserange, Nscantime, threshold, num) {
+
+ if (length(d) < Nscantime) {
+
+ ## noiserange[2] is full d-range
+ drange <- which(td %in% ftd)
+ n1 <- d[-drange] ## region outside the detected ROI (wide)
+ n1.cp <- continuousPtsAboveThresholdIdx(n1, threshold=threshold,num=num) ## continousPtsAboveThreshold (probably peak) are subtracted from data for local noise estimation
+ n1 <- n1[!n1.cp]
+ if (length(n1) > 1) {
+ baseline1 <- mean(n1)
+ sdnoise1 <- sd(n1)
+ } else
+ baseline1 <- sdnoise1 <- 1
+
+ ## noiserange[1]
+ d1 <- drange[1]
+ d2 <- drange[length(drange)]
+ nrange2 <- c(max(1,d1 - noiserange[1]) : d1, d2 : min(length(d),d2 + noiserange[1]))
+ n2 <- d[nrange2] ## region outside the detected ROI (narrow)
+ n2.cp <- continuousPtsAboveThresholdIdx(n2, threshold=threshold,num=num) ## continousPtsAboveThreshold (probably peak) are subtracted from data for local noise estimation
+ n2 <- n2[!n2.cp]
+ if (length(n2) > 1) {
+ baseline2 <- mean(n2)
+ sdnoise2 <- sd(n2)
+ } else
+ baseline2 <- sdnoise2 <- 1
+
+ } else {
+ trimmed <- trimm(d,c(0.05,0.95))
+ baseline1 <- baseline2 <- mean(trimmed)
+ sdnoise1 <- sdnoise2 <- sd(trimmed)
+ }
+
+ c(min(baseline1,baseline2),min(sdnoise1,sdnoise2))
+}
+continuousPtsAboveThresholdIdx <- function(y, threshold, num, istart = 1) {
+ if (!is.double(y)) y <- as.double(y)
+ as.logical(.C(C_continuousPtsAboveThresholdIdx,
+ y,
+ as.integer(istart-1),
+ length(y),
+ threshold = as.double(threshold),
+ num = as.integer(num),
+ n = integer(length(y)))$n)
+}
+MSW.cwt <- function (ms, scales = 1, wavelet = "mexh") { ## modified from package MassSpecWavelet
+ if (wavelet == "mexh") {
+ psi_xval <- seq(-6, 6, length = 256)
+ psi <- (2/sqrt(3) * pi^(-0.25)) * (1 - psi_xval^2) *
+ exp(-psi_xval^2/2)
+ }
+ else if (is.matrix(wavelet)) {
+ if (nrow(wavelet) == 2) {
+ psi_xval <- wavelet[1, ]
+ psi <- wavelet[2, ]
+ }
+ else if (ncol(wavelet) == 2) {
+ psi_xval <- wavelet[, 1]
+ psi <- wavelet[, 2]
+ }
+ else {
+ stop("Unsupported wavelet format!")
+ }
+ }
+ else {
+ stop("Unsupported wavelet!")
+ }
+ oldLen <- length(ms)
+ ms <- MSW.extendNBase(ms, nLevel = NULL, base = 2)
+ len <- length(ms)
+ nbscales <- length(scales)
+ wCoefs <- NULL
+ psi_xval <- psi_xval - psi_xval[1]
+ dxval <- psi_xval[2]
+ xmax <- psi_xval[length(psi_xval)]
+ for (i in 1:length(scales)) {
+ scale.i <- scales[i]
+ f <- rep(0, len)
+ j <- 1 + floor((0:(scale.i * xmax))/(scale.i * dxval))
+ if (length(j) == 1)
+ j <- c(1, 1)
+ lenWave <- length(j)
+ f[1:lenWave] <- rev(psi[j]) - mean(psi[j])
+ if (length(f) > len)
+ {i<-i-1;break;} ## stop(paste("scale", scale.i, "is too large!"))
+ wCoefs.i <- 1/sqrt(scale.i) * convolve(ms, f)
+ wCoefs.i <- c(wCoefs.i[(len - floor(lenWave/2) + 1):len],
+ wCoefs.i[1:(len - floor(lenWave/2))])
+ wCoefs <- cbind(wCoefs, wCoefs.i)
+ }
+ if (i < 1) return(NA)
+ scales <- scales[1:i]
+ if (length(scales) == 1)
+ wCoefs <- matrix(wCoefs, ncol = 1)
+ colnames(wCoefs) <- scales
+ wCoefs <- wCoefs[1:oldLen, , drop = FALSE]
+ wCoefs
+}
+MSW.extendNBase <- function(x, nLevel=1, base=2, ...) { ## from package MassSpecWavelet
+ if (!is.matrix(x)) x <- matrix(x, ncol=1)
+
+ nR <- nrow(x)
+ if (is.null(nLevel)) {
+ nR1 <- nextn(nR, base)
+ } else {
+ nR1 <- ceiling(nR / base^nLevel) * base^nLevel
+ }
+ if (nR != nR1) {
+ x <- MSW.extendLength(x, addLength=nR1-nR, ...)
+ }
+ x
+}
+MSW.extendLength <- function(x, addLength=NULL, method=c('reflection', 'open', 'circular'), direction=c('right', 'left', 'both')) { ## from package MassSpecWavelet
+ if (is.null(addLength)) stop('Please provide the length to be added!')
+ if (!is.matrix(x)) x <- matrix(x, ncol=1)
+ method <- match.arg(method)
+ direction <- match.arg(direction)
+
+ nR <- nrow(x)
+ nR1 <- nR + addLength
+ if (direction == 'both') {
+ left <- right <- addLength
+ } else if (direction == 'right') {
+ left <- 0
+ right <- addLength
+ } else if (direction == 'left') {
+ left <- addLength
+ right <- 0
+ }
+
+ if (right > 0) {
+ x <- switch(method,
+ reflection =rbind(x, x[nR:(2 * nR - nR1 + 1), , drop=FALSE]),
+ open = rbind(x, matrix(rep(x[nR,], addLength), ncol=ncol(x), byrow=TRUE)),
+ circular = rbind(x, x[1:(nR1 - nR),, drop=FALSE]))
+ }
+
+ if (left > 0) {
+ x <- switch(method,
+ reflection =rbind(x[addLength:1, , drop=FALSE], x),
+ open = rbind(matrix(rep(x[1,], addLength), ncol=ncol(x), byrow=TRUE), x),
+ circular = rbind(x[(2 * nR - nR1 + 1):nR,, drop=FALSE], x))
+ }
+ if (ncol(x) == 1) x <- as.vector(x)
+
+ x
+}
+MSW.getLocalMaximumCWT <- function(wCoefs, minWinSize=5, amp.Th=0) { ## from package MassSpecWavelet
+ localMax <- NULL
+ scales <- as.numeric(colnames(wCoefs))
+
+ for (i in 1:length(scales)) {
+ scale.i <- scales[i]
+ winSize.i <- scale.i * 2 + 1
+ if (winSize.i < minWinSize) {
+ winSize.i <- minWinSize
+ }
+ temp <- MSW.localMaximum(wCoefs[,i], winSize.i)
+ localMax <- cbind(localMax, temp)
+ }
+ ## Set the values less than peak threshold as 0
+ localMax[wCoefs < amp.Th] <- 0
+ colnames(localMax) <- colnames(wCoefs)
+ rownames(localMax) <- rownames(wCoefs)
+ localMax
+}
+MSW.localMaximum <- function (x, winSize = 5) { ## from package MassSpecWavelet
+ len <- length(x)
+ rNum <- ceiling(len/winSize)
+
+ ## Transform the vector as a matrix with column length equals winSize
+ ## and find the maximum position at each row.
+ y <- matrix(c(x, rep(x[len], rNum * winSize - len)), nrow=winSize)
+ y.maxInd <- apply(y, 2, which.max)
+ ## Only keep the maximum value larger than the boundary values
+ selInd <- which(apply(y, 2, function(x) max(x) > x[1] & max(x) > x[winSize]))
+
+ ## keep the result
+ localMax <- rep(0, len)
+ localMax[(selInd-1) * winSize + y.maxInd[selInd]] <- 1
+
+ ## Shift the vector with winSize/2 and do the same operation
+ shift <- floor(winSize/2)
+ rNum <- ceiling((len + shift)/winSize)
+ y <- matrix(c(rep(x[1], shift), x, rep(x[len], rNum * winSize - len - shift)), nrow=winSize)
+ y.maxInd <- apply(y, 2, which.max)
+ ## Only keep the maximum value larger than the boundary values
+ selInd <- which(apply(y, 2, function(x) max(x) > x[1] & max(x) > x[winSize]))
+ localMax[(selInd-1) * winSize + y.maxInd[selInd] - shift] <- 1
+
+ ## Check whether there is some local maxima have in between distance less than winSize
+ maxInd <- which(localMax > 0)
+ selInd <- which(diff(maxInd) < winSize)
+ if (length(selInd) > 0) {
+ selMaxInd1 <- maxInd[selInd]
+ selMaxInd2 <- maxInd[selInd + 1]
+ temp <- x[selMaxInd1] - x[selMaxInd2]
+ localMax[selMaxInd1[temp <= 0]] <- 0
+ localMax[selMaxInd2[temp > 0]] <- 0
+ }
+
+ localMax
+}
+MSW.getRidge <- function(localMax, iInit=ncol(localMax), step=-1, iFinal=1, minWinSize=3, gapTh=3, skip=NULL) { ## modified from package MassSpecWavelet
+
+ scales <- as.numeric(colnames(localMax))
+ if (is.null(scales)) scales <- 1:ncol(localMax)
+
+ maxInd_curr <- which(localMax[, iInit] > 0)
+ nMz <- nrow(localMax)
+
+ if (is.null(skip)) {
+ skip <- iInit + 1
+ }
+
+ ## Identify all the peak pathes from the coarse level to detail levels (high column to low column)
+ ## Only consider the shortest path
+ if ( ncol(localMax) > 1 ) colInd <- seq(iInit+step, iFinal, step)
+ else colInd <- 1
+ ridgeList <- as.list(maxInd_curr)
+ names(ridgeList) <- maxInd_curr
+ peakStatus <- as.list(rep(0, length(maxInd_curr)))
+ names(peakStatus) <- maxInd_curr
+
+ ## orphanRidgeList keep the ridges disconnected at certain scale level
+ ## Changed by Pan Du 05/11/06
+ orphanRidgeList <- NULL
+ orphanRidgeName <- NULL
+ nLevel <- length(colInd)
+
+ for (j in 1:nLevel) {
+ col.j <- colInd[j]
+ scale.j <- scales[col.j]
+
+ if (colInd[j] == skip) {
+ oldname <- names(ridgeList)
+ ridgeList <- lapply(ridgeList, function(x) c(x, x[length(x)]))
+ ##peakStatus <- lapply(peakStatus, function(x) c(x, x[length(x)]))
+ names(ridgeList) <- oldname
+ ##names(peakStatus) <- oldname
+ next
+ }
+
+ if (length(maxInd_curr) == 0) {
+ maxInd_curr <- which(localMax[, col.j] > 0)
+ next
+ }
+
+ ## The slide window size is proportional to the CWT scale
+ ## winSize.j <- scale.j / 2 + 1
+ winSize.j <- floor(scale.j/2)
+ if (winSize.j < minWinSize) {
+ winSize.j <- minWinSize
+ }
+
+ selPeak.j <- NULL
+ remove.j <- NULL
+ for (k in 1:length(maxInd_curr)) {
+ ind.k <- maxInd_curr[k]
+ start.k <- ifelse(ind.k-winSize.j < 1, 1, ind.k-winSize.j)
+ end.k <- ifelse(ind.k+winSize.j > nMz, nMz, ind.k+winSize.j)
+ ind.curr <- which(localMax[start.k:end.k, col.j] > 0) + start.k - 1
+ ##ind.curr <- which(localMax[, col.j] > 0)
+ if (length(ind.curr) == 0) {
+ status.k <- peakStatus[[as.character(ind.k)]]
+ ## bug work-around
+ if (is.null(status.k)) status.k <- gapTh +1
+ ##
+ if (status.k > gapTh & scale.j >= 2) {
+ temp <- ridgeList[[as.character(ind.k)]]
+ orphanRidgeList <- c(orphanRidgeList, list(temp[1:(length(temp)-status.k)]))
+ orphanRidgeName <- c(orphanRidgeName, paste(col.j + status.k + 1, ind.k, sep='_'))
+ remove.j <- c(remove.j, as.character(ind.k))
+ next
+ } else {
+ ind.curr <- ind.k
+ peakStatus[[as.character(ind.k)]] <- status.k + 1
+ }
+ } else {
+ peakStatus[[as.character(ind.k)]] <- 0
+ if (length(ind.curr) >= 2) ind.curr <- ind.curr[which.min(abs(ind.curr - ind.k))]
+ }
+ ridgeList[[as.character(ind.k)]] <- c(ridgeList[[as.character(ind.k)]], ind.curr)
+ selPeak.j <- c(selPeak.j, ind.curr)
+ }
+ ## Remove the disconnected lines from the currrent list
+ if (length(remove.j) > 0) {
+ removeInd <- which(names(ridgeList) %in% remove.j)
+ ridgeList <- ridgeList[-removeInd]
+ peakStatus <- peakStatus[-removeInd]
+ }
+
+ ## Check for duplicated selected peaks and only keep the one with the longest path.
+ dupPeak.j <- unique(selPeak.j[duplicated(selPeak.j)])
+ if (length(dupPeak.j) > 0) {
+ removeInd <- NULL
+ for (dupPeak.jk in dupPeak.j) {
+ selInd <- which(selPeak.j == dupPeak.jk)
+ selLen <- sapply(ridgeList[selInd], length)
+ removeInd.jk <- which.max(selLen)
+ removeInd <- c(removeInd, selInd[-removeInd.jk])
+ orphanRidgeList <- c(orphanRidgeList, ridgeList[removeInd.jk])
+ orphanRidgeName <- c(orphanRidgeName, paste(col.j, selPeak.j[removeInd.jk], sep='_'))
+ }
+ selPeak.j <- selPeak.j[-removeInd]
+ ridgeList <- ridgeList[-removeInd]
+ peakStatus <- peakStatus[-removeInd]
+ }
+
+ ## Update the names of the ridgeList as the new selected peaks
+ ##if (scale.j >= 2) {
+ if (length(ridgeList) > 0) names(ridgeList) <- selPeak.j
+ if (length(peakStatus) > 0) names(peakStatus) <- selPeak.j
+ ##}
+
+ ## If the level is larger than 3, expand the peak list by including other unselected peaks at that level
+ if (scale.j >= 2) {
+ maxInd_next <- which(localMax[, col.j] > 0)
+ unSelPeak.j <- maxInd_next[!(maxInd_next %in% selPeak.j)]
+ newPeak.j <- as.list(unSelPeak.j)
+ names(newPeak.j) <- unSelPeak.j
+ ## Update ridgeList
+ ridgeList <- c(ridgeList, newPeak.j)
+ maxInd_curr <- c(selPeak.j, unSelPeak.j)
+ ## Update peakStatus
+ newPeakStatus <- as.list(rep(0, length(newPeak.j)))
+ names(newPeakStatus) <- newPeak.j
+ peakStatus <- c(peakStatus, newPeakStatus)
+ } else {
+ maxInd_curr <- selPeak.j
+ }
+ }
+
+ ## Attach the peak level at the beginning of the ridge names
+ if (length(ridgeList) > 0) names(ridgeList) <- paste(1, names(ridgeList), sep='_')
+ if (length(orphanRidgeList) > 0) names(orphanRidgeList) <- orphanRidgeName
+ ## Combine ridgeList and orphanRidgeList
+ ridgeList <- c(ridgeList, orphanRidgeList)
+ if (length(ridgeList) == 0) return(NULL)
+
+ ## Reverse the order as from the low level to high level.
+ ridgeList <- lapply(ridgeList, rev)
+ ## order the ridgeList in increasing order
+ ##ord <- order(selPeak.j)
+ ##ridgeList <- ridgeList[ord]
+
+ ## Remove possible duplicated ridges
+ ridgeList <- ridgeList[!duplicated(names(ridgeList))]
+
+ attr(ridgeList, 'class') <- 'ridgeList'
+ attr(ridgeList, 'scales') <- scales
+ return(ridgeList)
+}
+descendMin <- function(y, istart = which.max(y)) {
+
+ if (!is.double(y)) y <- as.double(y)
+ unlist(.C(C_DescendMin,
+ y,
+ length(y),
+ as.integer(istart-1),
+ ilower = integer(1),
+ iupper = integer(1))[4:5]) + 1
+}
+descendMinTol <- function(d,startpos,maxDescOutlier) {
+ l <- startpos[1]; r <- startpos[2]; outl <- 0; N <- length(d)
+ ## left
+ while ((l > 1) && (d[l] > 0) && outl <= maxDescOutlier) {
+ if (outl > 0) vpos <- opos else vpos <- l
+ if (d[l-1] > d[vpos]) outl <- outl + 1 else outl <- 0
+ if (outl == 1) opos <- l
+ l <- l -1
+ }
+ if (outl > 0) l <- l + outl
+ ## right
+ outl <- 0;
+ while ((r < N) && (d[r] > 0) && outl <= maxDescOutlier) {
+ if (outl > 0) vpos <- opos else vpos <- r
+ if (d[r+1] > d[vpos]) outl <- outl + 1 else outl <- 0
+ if (outl == 1) opos <- r
+ r <- r + 1
+ }
+ if (outl > 0) r <- r - outl
+ c(l,r)
+}
+joinOverlappingPeaks <- function(td, d, otd, omz, od, scantime, scan.range, peaks, maxGaussOverlap=0.5) {
+ ## Fix issue #284: avoid having identical peaks multiple times in this
+ ## matrix.
+ peaks <- unique(peaks)
+ gausspeaksidx <- which(!is.na(peaks[,"mu"]))
+ Ngp <- length(gausspeaksidx)
+ if (Ngp == 0)
+ return(peaks)
+
+ newpeaks <- NULL
+
+ gpeaks <- peaks[gausspeaksidx, , drop = FALSE]
+ if (nrow(peaks) - Ngp > 0)
+ notgausspeaks <- peaks[-gausspeaksidx, , drop = FALSE]
+
+ if (Ngp > 1) {
+ comb <- which(upper.tri(matrix(0, Ngp, Ngp)), arr.ind = TRUE)
+ overlap <- logical(nrow(comb))
+ overlap <- rep(FALSE, dim(comb)[1])
+ for (k in seq_len(nrow(comb))) {
+ p1 <- comb[k, 1]
+ p2 <- comb[k, 2]
+ overlap[k] <- gaussCoverage(xlim = scan.range,
+ h1 = gpeaks[p1, "h"],
+ mu1 = gpeaks[p1, "mu"],
+ s1 = gpeaks[p1, "sigma"],
+ h2 = gpeaks[p2, "h"],
+ mu2 = gpeaks[p2, "mu"],
+ s2 = gpeaks[p2, "sigma"]) >=
+ maxGaussOverlap
+ }
+ } else overlap <- FALSE
+
+ if (any(overlap) && (Ngp > 1)) {
+ jlist <- list()
+ if (length(which(overlap)) > 1) {
+ gm <- comb[overlap, ]
+ ## create list of connected components
+ cc <- list()
+ cc[[1]] <- gm[1,] ## copy first entry
+ for (j in 2:dim(gm)[1]) { ## search for connections
+ ccl <- unlist(cc)
+ nl <- sapply(cc, function(x) length(x))
+ ccidx <- rep(1:length(nl),nl)
+ idx <- match(gm[j,],ccl)
+ if (any(!is.na(idx))) { ## connection found, add to list
+ pos <- ccidx[idx[which(!is.na(idx))[1]]]
+ cc[[pos]] <- c(cc[[pos]],gm[j,])
+ } else ## create new list element
+ cc[[length(cc) + 1]] <- gm[j,]
+
+ }
+ ccn <- list()
+ lcc <- length(cc)
+ ins <- rep(FALSE,lcc)
+ if (lcc > 1) {
+ jcomb <- which(upper.tri(matrix(0,lcc,lcc)),arr.ind = TRUE)
+ for (j in 1:dim(jcomb)[1]) {
+ j1 <- jcomb[j,1]; j2 <- jcomb[j,2]
+ if (any(cc[[j1]] %in% cc[[j2]]))
+ ccn[[length(ccn) +1]] <- unique(c(cc[[j1]],cc[[j2]]))
+ else {
+ if (!ins[j1]) {
+ ccn[[length(ccn) +1]] <- unique(cc[[j1]])
+ ins[j1] <- TRUE
+ }
+ if (!ins[j2]) {
+ ccn[[length(ccn) +1]] <- unique(cc[[j2]])
+ ins[j2] <- TRUE
+ }
+ }
+ }
+ } else ccn <- cc;
+
+ size <- sapply(ccn, function(x) length(x))
+ s2idx <- which(size >= 2)
+
+ if (length(s2idx) > 0) {
+ for (j in 1:length(s2idx)) {
+ pgroup <- unique(ccn[[ s2idx[j] ]])
+ jlist[[j]] <- pgroup
+ }
+ } else stop('(length(s2idx) = 0) ?!?')
+ } else jlist[[1]] <- comb[overlap, ]
+
+ ## join all peaks belonging to one cc
+ for (j in seq_along(jlist)) {
+ jidx <- jlist[[j]]
+ newpeak <- gpeaks[jidx[1], , drop = FALSE]
+ newmin <- min(gpeaks[jidx, "lmin"])
+ newmax <- max(gpeaks[jidx, "lmax"])
+ newpeak[1, "scpos"] <- -1 ## not defined after join
+ newpeak[1, "scmin"] <- -1 ## ..
+ newpeak[1, "scmax"] <- -1 ## ..
+ newpeak[1, "scale"] <- -1 ## ..
+
+ newpeak[1, "maxo"] <- max(gpeaks[jidx, "maxo"])
+ newpeak[1, "sn"] <- max(gpeaks[jidx, "sn"])
+ newpeak[1, "lmin"] <- newmin
+ newpeak[1, "lmax"] <- newmax
+ newpeak[1, "rtmin"] <- scantime[td[newmin]]
+ newpeak[1, "rtmax"] <- scantime[td[newmax]]
+ newpeak[1,"rt"] <- weighted.mean(gpeaks[jidx, "rt"],
+ w = gpeaks[jidx, "maxo"])
+
+ ## Re-assign m/z values
+ p1 <- match(td[newmin], otd)[1]
+ p2 <- match(td[newmax], otd)
+ p2 <- p2[length(p2)]
+ if (is.na(p1)) p1 <- 1
+ if (is.na(p2)) p2 <- length(omz)
+ mz.value <- omz[p1:p2]
+ mz.int <- od[p1:p2]
+
+ ## re-calculate m/z value for peak range
+ #mzmean <- do.call(mzCenterFun, list(mz = mz.value,
+ # intensity = mz.int))
+ mzmean <- weighted.mean(mz.value, mz.int)
+ mzrange <- range(mz.value)
+ newpeak[1, "mz"] <- mzmean
+ newpeak[1, c("mzmin","mzmax")] <- mzrange
+
+ ## re-fit gaussian
+ md <- max(d[newmin:newmax])
+ d1 <- d[newmin:newmax] / md
+ pgauss <- fitGauss(td[newmin:newmax],
+ d[newmin:newmax],
+ pgauss = list(mu = td[newmin] +
+ (td[newmax] - td[newmin])/2,
+ sigma = td[newmax] - td[newmin],
+ h = max(gpeaks[jidx, "h"])))
+ if (!any(is.na(pgauss)) && all(pgauss > 0)) {
+ newpeak[1, "mu"] <- pgauss$mu
+ newpeak[1, "sigma"] <- pgauss$sigma
+ newpeak[1, "h"] <- pgauss$h
+ newpeak[1, "egauss"]<- sqrt((1/length(td[newmin:newmax])) *
+ sum(((d1 - gauss(td[newmin:newmax],
+ pgauss$h/md,
+ pgauss$mu,
+ pgauss$sigma))^2)))
+ } else { ## re-fit after join failed
+ newpeak[1, "mu"] <- NA
+ newpeak[1, "sigma"] <- NA
+ newpeak[1, "h"] <- NA
+ newpeak[1, "egauss"] <- NA
+ }
+
+ newpeaks <- rbind(newpeaks, newpeak)
+ }
+ ## add the remaining peaks
+ jp <- unique(unlist(jlist))
+ if (dim(peaks)[1] - length(jp) > 0)
+ newpeaks <- rbind(newpeaks, gpeaks[-jp, ])
+
+ } else
+ newpeaks <- gpeaks
+
+ grt.min <- newpeaks[, "rtmin"]
+ grt.max <- newpeaks[, "rtmax"]
+
+ if (nrow(peaks) - Ngp > 0) { ## notgausspeaks
+ for (k in 1:nrow(notgausspeaks)) {
+ ## here we can only check if they are completely overlapped
+ ## by other peaks
+ if (!any((notgausspeaks[k, "rtmin"] >= grt.min) &
+ (notgausspeaks[k,"rtmax"] <= grt.max)))
+ newpeaks <- rbind(newpeaks,notgausspeaks[k,])
+ }
+ }
+
+ rownames(newpeaks) <- NULL
+ newpeaks
+}
+trimm <- function(x, trim=c(0.05,0.95)) {
+ a <- sort(x[x>0])
+ Na <- length(a)
+ quant <- round((Na*trim[1])+1):round(Na*trim[2])
+ a[quant]
+}
+findEqualGreaterM <- function(x, values) {
+
+ if (!is.double(x)) x <- as.double(x)
+ if (!is.double(values)) values <- as.double(values)
+ .C(C_FindEqualGreaterM,
+ x,
+ length(x),
+ values,
+ length(values),
+ index = integer(length(values)))$index + 1
+}
+rectUnique <- function(m, order = seq(length = nrow(m)), xdiff = 0, ydiff = 0) {
+
+ nr <- nrow(m)
+ nc <- ncol(m)
+ if (!is.double(m))
+ m <- as.double(m)
+ .C(C_RectUnique,
+ m,
+ as.integer(order-1),
+ nr,
+ nc,
+ as.double(xdiff),
+ as.double(ydiff),
+ logical(nrow(m)),
+ DUP = FALSE)[[7]]
+}
+na.flatfill <- function(x) {
+
+ realloc <- which(!is.na(x))
+ if (realloc[1] > 1)
+ x[1:(realloc[1]-1)] <- x[realloc[1]]
+ if (realloc[length(realloc)] < length(x))
+ x[(realloc[length(realloc)]+1):length(x)] <- x[realloc[length(realloc)]]
+ x
+}
+SSgauss <- selfStart(~ h*exp(-(x-mu)^2/(2*sigma^2)), function(mCall, data, LHS) {
+
+ xy <- sortedXyData(mCall[["x"]], LHS, data)
+
+ len <- dim(xy)[1]
+ xyarea <- sum((xy[2:len,2]+xy[1:(len-1),2])*(xy[2:len,1]-xy[1:(len-1),1]))/2
+ maxpos <- which.max(xy[,2])
+
+ mu <- xy[maxpos,1]
+ h <- xy[maxpos,2]
+ sigma <- xyarea/(h*sqrt(2*pi))
+
+ value <- c(mu, sigma, h)
+ names(value) <- mCall[c("mu", "sigma", "h")]
+ value
+
+}, c("mu", "sigma", "h"))
+.narrow_rt_boundaries <- function(lm, d, thresh = 1) {
+ lm_seq <- lm[1]:lm[2]
+ above_thresh <- d[lm_seq] >= thresh
+ if (any(above_thresh)) {
+ ## Expand by one on each side to be consistent with old code.
+ above_thresh <- above_thresh | c(above_thresh[-1], FALSE) |
+ c(FALSE, above_thresh[-length(above_thresh)])
+ lm <- range(lm_seq[above_thresh], na.rm = TRUE)
+ }
+ lm
+}
+.rawMat <- function(mz, int, scantime, valsPerSpect, mzrange = numeric(), rtrange = numeric(), scanrange = numeric(), log = FALSE) {
+ if (length(rtrange) >= 2) {
+ rtrange <- range(rtrange)
+ ## Fix for issue #267. rtrange outside scanrange causes scanrange
+ ## being c(Inf, -Inf)
+ scns <- which((scantime >= rtrange[1]) & (scantime <= rtrange[2]))
+ if (!length(scns))
+ return(matrix(
+ nrow = 0, ncol = 3,
+ dimnames = list(character(), c("time", "mz", "intensity"))))
+ scanrange <- range(scns)
+ }
+ if (length(scanrange) < 2)
+ scanrange <- c(1, length(valsPerSpect))
+ else scanrange <- range(scanrange)
+ if (!all(is.finite(scanrange)))
+ stop("'scanrange' does not contain finite values")
+ if (!all(is.finite(mzrange)))
+ stop("'mzrange' does not contain finite values")
+ if (!all(is.finite(rtrange)))
+ stop("'rtrange' does not contain finite values")
+ if (scanrange[1] == 1)
+ startidx <- 1
+ else
+ startidx <- sum(valsPerSpect[1:(scanrange[1] - 1)]) + 1
+ endidx <- sum(valsPerSpect[1:scanrange[2]])
+ scans <- rep(scanrange[1]:scanrange[2],
+ valsPerSpect[scanrange[1]:scanrange[2]])
+ masses <- mz[startidx:endidx]
+ massidx <- 1:length(masses)
+ if (length(mzrange) >= 2) {
+ mzrange <- range(mzrange)
+ massidx <- massidx[(masses >= mzrange[1] & (masses <= mzrange[2]))]
+ }
+ int <- int[startidx:endidx][massidx]
+ if (log && (length(int) > 0))
+ int <- log(int + max(1 - min(int), 0))
+ cbind(time = scantime[scans[massidx]],
+ mz = masses[massidx],
+ intensity = int)
+}
+
+#' @importFrom Biobase rowMedians
+.getPeakGroupsRtMatrix <- function(peaks, peakIndex, sampleIndex, missingSample, extraPeaks) {
+ ## For each feature:
+ ## o extract the retention time of the peak with the highest intensity.
+ ## o skip peak groups if they are not assigned a peak in at least a
+ ## minimum number of samples OR if have too many peaks from the same
+ ## sample assigned to it.
+ nSamples <- length(sampleIndex)
+ rt <- lapply(peakIndex, function(z) {
+ cur_fts <- peaks[z, c("rt", "into", "sample"), drop = FALSE]
+ ## Return NULL if we've got less samples that required or is the total
+ ## number of peaks is larger than a certain threshold.
+ ## Note that the original implementation is not completely correct!
+ ## nsamp > nsamp + extraPeaks might be correct.
+ nsamp <- length(unique(cur_fts[, "sample"]))
+ if (nsamp < (nSamples - missingSample) |
+ nrow(cur_fts) > (nsamp + extraPeaks))
+ return(NULL)
+ cur_fts[] <- cur_fts[order(cur_fts[, 2], decreasing = TRUE), ]
+ cur_fts[match(sampleIndex, cur_fts[, 3]), 1]
+ })
+ rt <- do.call(rbind, rt)
+ ## Order them by median retention time. NOTE: this is different from the
+ ## original code, in which the peak groups are ordered by the median
+ ## retention time that is calculated over ALL peaks within the peak
+ ## group, not only to one peak selected for each sample (for multi
+ ## peak per sample assignments).
+ ## Fix for issue #175
+ if (is(rt, "matrix")) {
+ rt <- rt[order(Biobase::rowMedians(rt, na.rm = TRUE)), , drop = FALSE]
+ }
+ rt
+}
+.peakIndex <- function(object) {
+ if (inherits(object, "DataFrame")) {
+ idxs <- object$peakidx
+ names(idxs) <- rownames(object)
+ } else {
+ if (is.null(object[["FeatureGroupTable"]]))
+ stop("No feature definitions present. Please run groupChromPeaks first.")
+ idxs <- object[["FeatureGroupTable"]]@listData[["peakidx"]]
+ names(idxs) <- rownames(object[["FeatureGroupTable"]])
+ }
+ idxs
+}
+.applyRtAdjToChromPeaks <- function(x, rtraw, rtadj) {
+ ## Using a for loop here.
+ for (i in 1:length(rtraw)) {
+ whichSample <- which(x[, "sample"] == i)
+ if (length(whichSample)) {
+ x[whichSample, c("rt", "rtmin", "rtmax")] <-
+ .applyRtAdjustment(x[whichSample, c("rt", "rtmin", "rtmax")],
+ rtraw = rtraw[[i]], rtadj = rtadj[[i]])
+ }
+ }
+ x
+}
+.applyRtAdjustment <- function(x, rtraw, rtadj) {
+ ## re-order everything if rtraw is not sorted; issue #146
+ if (is.unsorted(rtraw)) {
+ idx <- order(rtraw)
+ rtraw <- rtraw[idx]
+ rtadj <- rtadj[idx]
+ }
+ adjFun <- stepfun(rtraw[-1] - diff(rtraw) / 2, rtadj)
+ res <- adjFun(x)
+ ## Fix margins.
+ idx_low <- which(x < rtraw[1])
+ if (length(idx_low)) {
+ first_adj <- idx_low[length(idx_low)] + 1
+ res[idx_low] <- x[idx_low] + res[first_adj] - x[first_adj]
+ }
+ idx_high <- which(x > rtraw[length(rtraw)])
+ if (length(idx_high)) {
+ last_adj <- idx_high[1] - 1
+ res[idx_high] <- x[idx_high] + res[last_adj] - x[last_adj]
+ }
+ if (is.null(dim(res)))
+ names(res) <- names(x)
+ res
+}
+.getChromPeakData <- function(object, peakArea, sample_idx,mzCenterFun = "weighted.mean",cn = c("mz", "rt", "into", "maxo", "sample")) {
+
+ ncols <- length(cn)
+ res <- matrix(ncol = ncols, nrow = nrow(peakArea))
+ colnames(res) <- cn
+ res[, "sample"] <- sample_idx
+ res[, c("mzmin", "mzmax")] <- peakArea[, c("mzmin", "mzmax")]
+ ## Load the data
+ message("Requesting ", nrow(res), " peaks from ",
+ basename(MSnbase::fileNames(object)), " ... ", appendLF = FALSE)
+
+ spctr <- MSnbase::spectra(object, BPPARAM = SerialParam())
+
+
+
+ mzs <- lapply(spctr, mz)
+ valsPerSpect <- lengths(mzs)
+ ints <- unlist(lapply(spctr, intensity), use.names = FALSE)
+ rm(spctr)
+
+ mzs <- unlist(mzs, use.names = FALSE)
+ mzs_range <- range(mzs)
+ rtim <- rtime(object)
+ rtim_range <- range(rtim)
+
+ for (i in seq_len(nrow(res))) {
+ rtr <- peakArea[i, c("rtmin", "rtmax")]
+ mzr <- peakArea[i, c("mzmin", "mzmax")]
+ ## If the rt range is completely out; additional fix for #267
+ if (rtr[2] < rtim_range[1] | rtr[1] > rtim_range[2] |
+ mzr[2] < mzs_range[1] | mzr[1] > mzs_range[2]) {
+ res[i, ] <- rep(NA_real_, ncols)
+ next
+ }
+ ## Ensure that the mz and rt region is within the range of the data.
+ rtr[1] <- max(rtr[1], rtim_range[1])
+ rtr[2] <- min(rtr[2], rtim_range[2])
+ mzr[1] <- max(mzr[1], mzs_range[1])
+ mzr[2] <- min(mzr[2], mzs_range[2])
+ mtx <- .rawMat(mz = mzs, int = ints, scantime = rtim,
+ valsPerSpect = valsPerSpect, rtrange = rtr,
+ mzrange = mzr)
+ if (length(mtx)) {
+ if (any(!is.na(mtx[, 3]))) {
+ ## How to calculate the area: (1)sum of all intensities / (2)by
+ ## the number of data points (REAL ones, considering also NAs)
+ ## and multiplied with the (3)rt width.
+ ## (1) sum(mtx[, 3], na.rm = TRUE)
+ ## (2) sum(rtim >= rtr[1] & rtim <= rtr[2]) - 1 ; if we used
+ ## nrow(mtx) here, which would correspond to the non-NA
+ ## intensities within the rt range we don't get the same results
+ ## as e.g. centWave. Using max(1, ... to avoid getting Inf in
+ ## case the signal is based on a single data point.
+ ## (3) rtr[2] - rtr[1]
+ res[i, "into"] <- sum(mtx[, 3], na.rm = TRUE) *
+ ((rtr[2] - rtr[1]) /
+ max(1, (sum(rtim >= rtr[1] & rtim <= rtr[2]) - 1)))
+ maxi <- which.max(mtx[, 3])
+ res[i, c("rt", "maxo")] <- mtx[maxi[1], c(1, 3)]
+ res[i, c("rtmin", "rtmax")] <- rtr
+ ## Calculate the intensity weighted mean mz
+ meanMz <- do.call(mzCenterFun, list(mtx[, 2], mtx[, 3]))
+ if (is.na(meanMz)) meanMz <- mtx[maxi[1], 2]
+ res[i, "mz"] <- meanMz
+ } else {
+ res[i, ] <- rep(NA_real_, ncols)
+ }
+ } else {
+ res[i, ] <- rep(NA_real_, ncols)
+ }
+ }
+ message("got ", sum(!is.na(res[, "into"])), ".")
+ return(res)
+}
+.feature_values <- function(pks, fts, method, value = "into",intensity = "into", colnames, missing = NA) {
+ ftIdx <- fts$peakidx
+ ## Match columns
+ idx_rt <- match("rt", colnames(pks))
+ idx_int <- match(intensity, colnames(pks))
+ idx_samp <- match("sample", colnames(pks))
+ vals <- matrix(nrow = length(ftIdx), ncol = length(colnames))
+ nSamples <- seq_along(colnames)
+ if (method == "sum") {
+ for (i in seq_along(ftIdx)) {
+ cur_pks <- pks[ftIdx[[i]], c(value, "sample")]
+ int_sum <- split(cur_pks[, value], cur_pks[, "sample"])
+ vals[i, as.numeric(names(int_sum))] <-
+ unlist(lapply(int_sum, base::sum), use.names = FALSE)
+ }
+ } else {
+ if (method == "medret") {
+ medret <- fts$rtmed
+ for (i in seq_along(ftIdx)) {
+ gidx <- ftIdx[[i]][
+ base::order(base::abs(pks[ftIdx[[i]],
+ idx_rt] - medret[i]))]
+ vals[i, ] <- gidx[
+ base::match(nSamples, pks[gidx, idx_samp])]
+ }
+ }
+ if (method == "maxint") {
+ for (i in seq_along(ftIdx)) {
+ gidx <- ftIdx[[i]][
+ base::order(pks[ftIdx[[i]], idx_int],
+ decreasing = TRUE)]
+ vals[i, ] <- gidx[base::match(nSamples,
+ pks[gidx, idx_samp])]
+ }
+ }
+ if (value != "index") {
+ if (!any(colnames(pks) == value))
+ stop("Column '", value, "' not present in the ",
+ "chromatographic peaks matrix!")
+ vals <- pks[vals, value]
+ dim(vals) <- c(length(ftIdx), length(nSamples))
+ }
+ }
+ if (value != "index") {
+ if (is.numeric(missing)) {
+ vals[is.na(vals)] <- missing
+ }
+ if (!is.na(missing) & missing == "rowmin_half") {
+ for (i in seq_len(nrow(vals))) {
+ nas <- is.na(vals[i, ])
+ if (any(nas))
+ vals[i, nas] <- min(vals[i, ], na.rm = TRUE) / 2
+ }
+ }
+ }
+ colnames(vals) <- colnames
+ rownames(vals) <- rownames(fts)
+ vals
+}
+.groupval <-function(xset, method = c("medret", "maxint"),value = "into", intensity = "into"){
+
+ if ( nrow(xset@groups)<1 || length(xset@groupidx) <1) {
+ stop("xcmsSet is not been grouped.")
+ }
+
+ method <- match.arg(method)
+
+ peakmat <- xset@peaks
+ groupmat <- xset@groups
+ groupindex <- xset@groupidx
+
+ sampnum <- seq(length = length(rownames(xset@phenoData)))
+ retcol <- match("rt", colnames(peakmat))
+ intcol <- match(intensity, colnames(peakmat))
+ sampcol <- match("sample", colnames(peakmat))
+
+ values <- matrix(nrow = length(groupindex), ncol = length(sampnum))
+
+ if (method == "medret") {
+ for (i in seq(along = groupindex)) {
+ gidx <- groupindex[[i]][order(abs(peakmat[groupindex[[i]],retcol] - median(peakmat[groupindex[[i]],retcol])))]
+ values[i,] <- gidx[match(sampnum, peakmat[gidx,sampcol])]
+ }
+ } else {
+ for (i in seq(along = groupindex)) {
+ gidx <- groupindex[[i]][order(peakmat[groupindex[[i]],intcol], decreasing = TRUE)]
+ values[i,] <- gidx[match(sampnum, peakmat[gidx,sampcol])]
+ }
+ }
+
+ if (value != "index") {
+ values <- peakmat[values,value]
+ dim(values) <- c(length(groupindex), length(sampnum))
+ }
+ colnames(values) <- rownames(xset@phenoData)
+ rownames(values) <- paste(round(groupmat[,"mzmed"],1), round(groupmat[,"rtmed"]), sep = "/")
+
+ values
+}
+
+
+### ---- ===== MatchedFilter Sub Kit ==== ---- #####
+binYonX <- function(x, y, breaks, nBins, binSize, binFromX,
+ binToX, fromIdx = 1L, toIdx = length(x),
+ method = "max", baseValue,
+ sortedX = !is.unsorted(x),
+ shiftByHalfBinSize = FALSE,
+ returnIndex = FALSE, returnX = TRUE) {
+ if (!missing(x) & missing(y))
+ y <- x
+ if (missing(x) | missing(y))
+ stop("Arguments 'x' and 'y' are mandatory!")
+ if (missing(nBins) & missing(binSize) & missing(breaks))
+ stop("One of 'breaks', 'nBins' or 'binSize' has to be defined!")
+ if (!sortedX) {
+ message("'x' is not sorted, will sort 'x' and 'y'.")
+ ## Sort method; see issue #180 for MSnbase
+ ## Note: order method = "radix" is considerably faster - but there is no
+ ## method argument for older R versions.
+ o <- order(x)
+ x <- x[o]
+ y <- y[o]
+ }
+ ## Check fromIdx and toIdx
+ if (any(fromIdx < 1) | any(toIdx > length(x)))
+ stop("'fromIdx' and 'toIdx' have to be within 1 and lenght(x)!")
+ if (length(toIdx) != length(fromIdx))
+ stop("'fromIdx' and 'toIdx' have to have the same length!")
+ if (missing(binFromX))
+ binFromX <- as.double(NA)
+ if (missing(binToX))
+ binToX <- as.double(NA)
+ ## For now we don't allow NAs in x
+ if (anyNA(x))
+ stop("No 'NA' values are allowed in 'x'!")
+ ## Check that input values have the correct data types.
+ if (!is.double(x)) x <- as.double(x)
+ if (!is.double(y)) y <- as.double(y)
+ if (!is.double(binFromX)) binFromX <- as.double(binFromX)
+ if (!is.double(binToX)) binToX <- as.double(binToX)
+ if (!is.integer(fromIdx)) fromIdx <- as.integer(fromIdx)
+ if (!is.integer(toIdx)) toIdx <- as.integer(toIdx)
+ ## breaks has precedence over nBins over binSize.
+ shiftIt <- 0L
+ if (!missing(breaks)) {
+ if (shiftByHalfBinSize)
+ warning("Argument 'shiftByHalfBinSize' is ignored if 'breaks'",
+ " are provided.")
+ if (!is.double(breaks)) breaks <- as.double(nBins)
+ nBins <- NA_integer_
+ binSize <- as.double(NA)
+ } else {
+ if (!missing(nBins)) {
+ breaks <- as.double(NA)
+ if (!is.integer(nBins)) nBins <- as.integer(nBins)
+ binSize <- as.double(NA)
+ } else{
+ breaks <- as.double(NA)
+ nBins <- NA_integer_
+ if (!is.double(binSize)) binSize <- as.double(binSize)
+ }
+ }
+ if (shiftByHalfBinSize)
+ shiftIt <- 1L
+ ## Define default value for baseValue
+ if (missing(baseValue)) {
+ baseValue = as.double(NA)
+ } else {
+ if (!is.double(baseValue)) baseValue <- as.double(baseValue)
+ }
+
+ getIndex <- 0L
+ if (returnIndex)
+ getIndex <- 1L
+ getX <- 0L
+ if (returnX)
+ getX <- 1L
+ if (length(toIdx) > 1) {
+ .Call(C_binYonX_multi, x, y, breaks, nBins, binSize,
+ binFromX, binToX, force(fromIdx - 1L), force(toIdx - 1L),
+ shiftIt,
+ as.integer(.aggregateMethod2int(method)),
+ baseValue,
+ getIndex,
+ getX,
+ PACKAGE = "MetaboAnalystR")
+ } else {
+ .Call(C_binYonX, x, y, breaks, nBins, binSize,
+ binFromX, binToX, force(fromIdx - 1L), force(toIdx - 1L),
+ shiftIt,
+ as.integer(.aggregateMethod2int(method)),
+ baseValue,
+ getIndex,
+ getX,
+ PACKAGE = "MetaboAnalystR")
+ }
+}
+
+.aggregateMethod2int <- function(method = "max") {
+ .aggregateMethods <- c(1, 2, 3, 4);
+ names(.aggregateMethods) <- c("max", "min", "sum", "mean")
+ method <- match.arg(method, names(.aggregateMethods))
+ return(.aggregateMethods[method])
+}
+imputeLinInterpol <- function(x, baseValue, method = "lin", distance = 1L,
+ noInterpolAtEnds = FALSE) {
+ method <- match.arg(method, c("none", "lin", "linbase")) ## interDist? distance = 2
+ if (method == "none") {
+ return(x)
+ }
+ if (!is.double(x)) x <- as.double(x)
+ if (method == "lin") {
+ noInter <- 0L
+ if (noInterpolAtEnds)
+ noInter <- 1L
+ return(.Call(C_impute_with_linear_interpolation, x, noInter,
+ PACKAGE = "MetaboAnalystR"))
+ }
+ if (method == "linbase") {
+ if (missing(baseValue))
+ baseValue <- min(x, na.rm = TRUE) / 2
+ if (!is.double(baseValue)) baseValue <- as.double(baseValue)
+ if (!is.integer(distance)) distance <- as.integer(distance)
+ return(.Call(C_impute_with_linear_interpolation_base, x, baseValue,
+ distance, PACKAGE = "MetaboAnalystR"))
+ }
+}
+colMax <- function (x, na.rm = FALSE, dims = 1) {
+
+ if (is.data.frame(x))
+ x <- as.matrix(x)
+ if (!is.array(x) || length(dn <- dim(x)) < 2)
+ stop("`x' must be an array of at least two dimensions")
+ if (dims < 1 || dims > length(dn) - 1)
+ stop("invalid `dims'")
+ n <- prod(dn[1:dims])
+ dn <- dn[-(1:dims)]
+ if (!is.double(x)) x <- as.double(x)
+ z <- .C(C_ColMax,
+ x,
+ as.integer(n),
+ as.integer(prod(dn)),
+ double(prod(dn)),
+ PACKAGE = "MetaboAnalystR")[[4]]
+ if (length(dn) > 1) {
+ dim(z) <- dn
+ dimnames(z) <- dimnames(x)[-(1:dims)]
+ }
+ else names(z) <- dimnames(x)[[dims + 1]]
+ z
+}
+filtfft <- function(y, filt) {
+
+ yfilt <- numeric(length(filt))
+ yfilt[1:length(y)] <- y
+ yfilt <- fft(fft(yfilt, inverse = TRUE) * filt)
+
+ Re(yfilt[1:length(y)])
+}
+descendZero <- function(y, istart = which.max(y)) {
+
+ if (!is.double(y)) y <- as.double(y)
+ unlist(.C(C_DescendZero,
+ y,
+ length(y),
+ as.integer(istart-1),
+ ilower = integer(1),
+ iupper = integer(1),
+ PACKAGE = "MetaboAnalystR")[4:5]) + 1
+}
+which.colMax <- function (x, na.rm = FALSE, dims = 1) {
+
+ if (is.data.frame(x))
+ x <- as.matrix(x)
+ if (!is.array(x) || length(dn <- dim(x)) < 2)
+ stop("`x' must be an array of at least two dimensions")
+ if (dims < 1 || dims > length(dn) - 1)
+ stop("invalid `dims'")
+ n <- prod(dn[1:dims])
+ dn <- dn[-(1:dims)]
+ if (!is.double(x)) x <- as.double(x)
+ z <- .C(C_WhichColMax,
+ x,
+ as.integer(n),
+ as.integer(prod(dn)),
+ integer(prod(dn)),
+ PACKAGE = "MetaboAnalystR")[[4]]
+ if (length(dn) > 1) {
+ dim(z) <- dn
+ dimnames(z) <- dimnames(x)[-(1:dims)]
+ }
+ else names(z) <- dimnames(x)[[dims + 1]]
+ z
+}
+breaks_on_nBins <- function(fromX, toX, nBins, shiftByHalfBinSize = FALSE) {
+ if(missing(fromX) | missing(toX) | missing(nBins))
+ stop("'fromX', 'toX' and 'nBins' are required!")
+ if (!is.double(fromX)) fromX <- as.double(fromX)
+ if (!is.double(toX)) toX <- as.double(toX)
+ if (!is.integer(nBins)) nBins <- as.integer(nBins)
+ shiftIt <- 0L
+ if (shiftByHalfBinSize)
+ shiftIt <- 1L
+ return(.Call(C_breaks_on_nBins, fromX, toX, nBins, shiftIt,
+ PACKAGE = "MetaboAnalystR"))
+}
+
+### ---- ==== Botthom of this sub Kit ==== --- ####
+
+
+
+#
+######### --------------======== Bottom of this Function Kit =============--------
+
+
+
+
+
+
+# ---------------------------2. Peaks Picking_Section-------------------------------
+
+### Functions_Peak Peaking _ used for parameters optimization
+#' @title Data Preparation for ChromPeaking Finding
+#' @param object MSnExp object.
+#' @import MSnbase
+#' @author Zhiqiang Pang \email{zhiqiang.pang@mail.mcgill.ca}
+#' Mcgill University
+#' License: GNU GPL (>= 2)
+PeakPicking_prep <-function(object){
+
+ ## Check if the data is centroided
+ centroided <- all(centroided(object))
+ if (is.na(centroided)) {
+ suppressWarnings(
+ centroided <- isCentroided(
+ object[[ceiling(length(object) / 3)]])
+ )
+ }
+ if (is.na(centroided) || !centroided)
+ warning("Your data appears to be not centroided! CentWave",
+ " works best on data in centroid mode.")
+
+
+ ##### Revise for Centwave MSnExp -------------
+
+ ## (1) split the object per file from MSnExp.
+ object_mslevel_i<-splitByFile(object = object, f = factor(c(1:length(object@phenoData@data[["sample_name"]]))))
+ object_mslevel_o<-bplapply(object_mslevel_i, FUN = function(x){x@assayData})
+ message("Data Spliting Finished !")
+
+ ## (2) use parallel to do the peak detection.
+ message("Peak Preparing Begin...")
+ object_mslevel_name<-bplapply(object_mslevel_o,ls);
+ object_mslevell<-object_mslevel<-list();
+ for (j in 1:length(object_mslevel_o)){
+ for (i in 1:length(object_mslevel_name[[j]])){
+ #print(i,j,"\n")
+ object_mslevell[[i]]<-object_mslevel_o[[j]][[object_mslevel_name[[j]][i]]]
+ }
+ names(object_mslevell)<-object_mslevel_name[[j]];
+ object_mslevel[[j]]<-object_mslevell;
+ }
+
+ for (i in 1:length(object_mslevel)){
+ #for (j in 1:length(object_mslevel[[i]])){
+ ncount<-as.numeric(which(sapply(names(object_mslevel[[i]]),is.na)));
+ if (!identical(ncount,numeric(0))){
+ object_mslevel[[i]]<-object_mslevel[[i]][-ncount]
+ }
+ #}
+ }
+ message("Peak Preparing Done !")
+ return(object_mslevel)
+
+
+}
+
+#' @title Calculate PPS method
+#' @description Peak picking method. Specifically used for parameters optimization
+#' @param xset MSnExp object.
+#' @param object_mslevel List, prepared by findChromPeaks_prep function.
+#' @param param Parameters list.
+#' @param BPPARAM Parallel Method.
+#' @param msLevel msLevel. Only 1 is supported currently.
+#' @import MSnbase
+#' @author Zhiqiang Pang \email{zhiqiang.pang@mail.mcgill.ca}
+#' Mcgill University
+#' License: GNU GPL (>= 2)
+PeakPicking_core <-function(object,object_mslevel,param, BPPARAM = bpparam(), msLevel = 1L){
+
+
+
+ ## Restrict to MS 1 data for now.
+ if (length(msLevel) > 1)
+ stop("Currently only peak detection in a single MS level is ",
+ "supported", call. = FALSE)
+
+ if (is.null(param$fwhm)){
+
+ resList <- bplapply(object_mslevel,
+ FUN = PeakPicking_centWave_slave,
+ param = param,
+ BPPARAM = BPPARAM)
+
+ } else {
+
+ resList <- bplapply(object_mslevel,
+ FUN = PeakPicking_MatchedFilter_slave,
+ param = param,
+ BPPARAM = BPPARAM)
+
+ }
+
+ print("Peak Profiling Finished !")
+
+ rm(object_mslevel)
+ ## (3) PEAK SUMMARY------------
+
+ pks <- vector("list", length(resList))
+ for (i in 1:length(resList)) {
+ n_pks <- nrow(resList[[i]])
+ if (is.null(n_pks))
+ n_pks <- 0
+ if (n_pks == 0) {
+ pks[[i]] <- NULL
+ warning("No peaks found in sample number ", i, ".")
+ } else {
+ pks[[i]] <- cbind(resList[[i]], sample = rep.int(i, n_pks))
+ }
+
+ }
+ pks <- do.call(rbind, pks)
+
+ # Make the chrompeaks embeded
+ newFd <- list()
+ #newFd@.xData <- as.environment(as.list(object@msFeatureData, all.names = TRUE))
+ rownames(pks) <- sprintf(paste0("CP", "%0", ceiling(log10(nrow(pks) + 1L)), "d"),
+ seq(from = 1, length.out = nrow(pks)))
+
+ newFd$chromPeaks <- pks
+ newFd$chromPeakData <- S4Vectors::DataFrame(ms_level = rep(1L, nrow(pks)), is_filled = rep(FALSE, nrow(pks)),
+ row.names = rownames(pks))
+
+ ## mSet Generation
+ mSet<-list()
+ mSet$msFeatureData <- newFd
+ mSet$inMemoryData <- object
+
+ return(mSet)
+
+}
+
+
+
+# -------------------------------3. MS2 Data_Section---------------------------------
+
+
+#' Extract MS2 Data
+#' @description This function returns a list of spectra that matches with
+#' a user specified precursor m/z.
+#' @param filename Name of the file (e.g. mzML, mzXML)
+#' @param peakParams Object containing parameters for peak picking.
+#' @param mzmin Minimum m/z when selecting a precursor from peak list
+#' @param mzmax Maximum m/z when selecting a precursor from peak list
+#' @author Jasmine Chong \email{jasmine.chong@mail.mcgill.ca},
+#' Mai Yamamoto \email{yamamoto.mai@mail.mcgill.ca}, and Jeff Xia \email{jeff.xia@mcgill.ca}
+#' McGill University, Canada
+#' License: GNU GPL (>= 2)
+
+
+ExtractMS2data <- function(filename, peakParams, mzmin, mzmax){
+
+ ## Function to extract MSMS spectra
+ xrms <- readMSData(filename, mode = "onDisk", centroided = TRUE)
+ # get all MS2 spectra from DDA experiment
+ ms2spectra <- spectra(filterMsLevel(xrms, msLevel = 2))
+
+ ## Detect chromatographic peaks
+ # set parameters and find chromatographic peaks
+ ms1cwp <- CentWaveParam(snthresh = peakParams$sn_thresh,
+ noise = 100, ppm = peakParams$ppm, peakwidth = c(peakParams$min_pkw, peakParams$max_pkw))
+ ms1data <- findChromPeaks(xrms, param = ms1cwp, msLevel = 1)
+
+ #get all peaks
+ chromPeaks <- chromPeaks(ms1data)
+
+ # pick one compound
+ ## find which row contains the mass we want
+ chp <- as.data.frame(chromPeaks)
+ rownum <- which(chp$mz >= mzmin & chp$mz <= mzmax)
+ chromPeak <- chromPeaks[rownum,]
+
+ #filter out fitting spectra
+ filteredMs2spectra <- .getDdaMS2Scans(chromPeak, ms2spectra)
+
+ return(filteredMs2spectra)
+}
+
+### Helper function
+### function for DDA data
+### Credit: Michael Witting; https://github.com/michaelwitting/metabolomics2018/blob/master/R/msLevelMerge.R
+### MS2 spectra need to be list of spectrum2 objects
+.getDdaMS2Scans <- function(chromPeak, ms2spectra, mzTol = 0.01, rtTol = 20) {
+
+ #make a new list
+ filteredMs2spectra <- list()
+
+ #isolate only the ones within range
+ for(i in 1:length(ms2spectra)) {
+
+ #isolate Ms2 spectrum
+ ms2spectrum <- ms2spectra[[i]]
+
+ #check if within range of peak
+ if(abs(chromPeak[4] - ms2spectrum@rt) < rtTol & abs(chromPeak[1] - ms2spectrum@precursorMz) < mzTol) {
+ filteredMs2spectra <- c(filteredMs2spectra, ms2spectrum)
+ }
+ }
+
+ #return list with filtered ms2 spectra
+ return(filteredMs2spectra)
+}
+
+#' Plot selected M2 spectra for an m/z feature
+#' @description This function creates a plot of the user selected precursor m/z.
+#' @param ms2 Spectrum2 class object containing all of the spectra for the selected
+#' m/z feature.
+#' @author Jasmine Chong \email{jasmine.chong@mail.mcgill.ca},
+#' Mai Yamamoto \email{yamamoto.mai@mail.mcgill.ca}, and Jeff Xia \email{jeff.xia@mcgill.ca}
+#' McGill University, Canada
+#' License: GNU GPL (>= 2)
+
+
+PlotMS2Spectra <- function(ms2, spectra = 1){
+
+ MSnbase::plot(ms2[[spectra]])
+
+}
+
+
+
+# -----------------------------------4. Annotation-----------------------
+
+##' @references Kuhl C, Tautenhahn R, Boettcher C, Larson TR, Neumann S (2012).
+##' "CAMERA: an integrated strategy for compound spectra extraction and annotation of
+##' liquid chromatography/mass spectrometry data sets." Analytical Chemistry, 84, 283-289.
+##' http://pubs.acs.org/doi/abs/10.1021/ac202450g.
+
+####### ---------- ====== Function Kit From CAMERA ======= ----------- ######/
+getPeaks_selection <- function(xs, method="medret", value="into"){
+
+ if (!class(xs) == "xcmsSet") {
+ stop ("Parameter xs is no xcmsSet object\n")
+ }
+
+ # Testing if xcmsSet is grouped
+ if (nrow(xs@groups) > 0 && length(xs@filepaths) > 1) {
+ # get grouping information
+ groupmat <- xs@groups
+ # generate data.frame for peaktable
+ ts <- data.frame(cbind(groupmat, groupval(xs, method=method, value=value)), row.names = NULL)
+ #rename column names
+ cnames <- colnames(ts)
+ if (cnames[1] == 'mzmed') {
+ cnames[1] <- 'mz'
+ } else {
+ stop ('Peak information ?!?')
+ }
+ if (cnames[4] == 'rtmed') {
+ cnames[4] <- 'rt'
+ } else {
+ stop ('Peak information ?!?')
+ }
+ colnames(ts) <- cnames
+ } else if (length(rownames(xs@phenoData)) == 1) { #Contains only one sample?
+ ts <- xs@peaks
+ } else {
+ stop ('First argument must be a xcmsSet with group information or contain only one sample.')
+ }
+
+ return(as.matrix(ts))
+}
+groupval <- function(object, method = c("medret", "maxint"), value = "index", intensity = "into") {
+
+ if ( nrow(object@groups)<1 || length(object@groupidx) <1) {
+ stop("mSet$xcmsSet is not been grouped.")
+ }
+
+ method <- match.arg(method)
+
+ peakmat <- object@peaks; groupmat <- object@groups; groupindex <- object@groupidx
+
+ sampnum <- seq(length = length(rownames(object@phenoData)))
+ retcol <- match("rt", colnames(peakmat))
+ intcol <- match(intensity, colnames(peakmat))
+ sampcol <- match("sample", colnames(peakmat))
+
+ values <- matrix(nrow = length(groupindex), ncol = length(sampnum))
+
+ if (method == "medret") {
+ for (i in seq(along = groupindex)) {
+ gidx <- groupindex[[i]][order(abs(peakmat[groupindex[[i]],retcol] - median(peakmat[groupindex[[i]],retcol])))]
+ values[i,] <- gidx[match(sampnum, peakmat[gidx,sampcol])]
+ }
+ } else {
+ for (i in seq(along = groupindex)) {
+ gidx <- groupindex[[i]][order(peakmat[groupindex[[i]],intcol], decreasing = TRUE)]
+ values[i,] <- gidx[match(sampnum, peakmat[gidx,sampcol])]
+ }
+ }
+
+ if (value != "index") {
+ values <- peakmat[values,value]
+ dim(values) <- c(length(groupindex), length(sampnum))
+ }
+ colnames(values) <- rownames(object@phenoData)
+ rownames(values) <- paste(round(groupmat[,"mzmed"],1), round(groupmat[,"rtmed"]), sep = "/")
+
+ values
+}
+percentOutput <- function(len.old, len.add, len.max, cnt){
+ len <- len.old + len.add;
+ perc <- round((len) / len.max * 100)
+ perc <- perc %/% 10 * 10;
+ if (perc != cnt && perc != 0) {
+ print(perc,' ');
+ cnt2 <- perc;
+ eval.parent(substitute(cnt <- cnt2))
+ }
+ if (.Platform$OS.type == "windows"){
+ flush.console();
+ }
+ eval.parent(substitute(len.old <- len))
+}
+is.wholenumber <- function(x, tol = .Machine$double.eps^0.5) abs(x - round(x)) < tol
+calcIsotopeMatrix <- function(maxiso=4){
+
+ if(!is.numeric(maxiso)){
+ stop("Parameter maxiso is not numeric!\n")
+ } else if(maxiso < 1 | maxiso > 8){
+ stop(paste("Parameter maxiso must between 1 and 8. ",
+ "Otherwise use your own IsotopeMatrix.\n"),sep="")
+ }
+
+ isotopeMatrix <- matrix(NA, 8, 4);
+ colnames(isotopeMatrix) <- c("mzmin", "mzmax", "intmin", "intmax")
+
+ isotopeMatrix[1, ] <- c(1.000, 1.0040, 1.0, 150)
+ isotopeMatrix[2, ] <- c(0.997, 1.0040, 0.01, 200)
+ isotopeMatrix[3, ] <- c(1.000, 1.0040, 0.001, 200)
+ isotopeMatrix[4, ] <- c(1.000, 1.0040, 0.0001, 200)
+ isotopeMatrix[5, ] <- c(1.000, 1.0040, 0.00001, 200)
+ isotopeMatrix[6, ] <- c(1.000, 1.0040, 0.000001, 200)
+ isotopeMatrix[7, ] <- c(1.000, 1.0040, 0.0000001, 200)
+ isotopeMatrix[8, ] <- c(1.000, 1.0040, 0.00000001, 200)
+
+ return(isotopeMatrix[1:maxiso, , drop=FALSE])
+
+}
+findIsotopesPspec <- function(isomatrix, mz, ipeak, int, params){
+ #isomatrix - isotope annotations (5 column matrix)
+ #mz - m/z vector, contains all m/z values from specific pseudospectrum
+ #int - int vector, see above
+ #maxiso - how many isotopic peaks are allowed
+ #maxcharge - maximum allowed charge
+ #devppm - scaled ppm error
+ #mzabs - absolut error in m/z
+
+ #matrix with all important informationen
+ spectra <- matrix(c(mz, ipeak), ncol=2)
+ int <- int[order(spectra[, 1]), , drop=FALSE]
+ spectra <- spectra[order(spectra[, 1]), ];
+ cnt <- nrow(spectra);
+ #isomatrix <- matrix(NA, ncol=5, nrow=0)
+ #colnames(isomatrix) <- c("mpeak", "isopeak", "iso", "charge", "intrinsic")
+
+ #calculate error
+ error.ppm <- params$devppm * mz;
+ #error.abs <- ),1, function(x) x + params$mzabs*rbind(1,2,3)));
+
+ #for every peak in pseudospectrum
+ for ( j in 1:(length(mz) - 1)){
+ #create distance matrix
+ MI <- spectra[j:cnt, 1] - spectra[j, 1];
+ #Sum up all possible/allowed isotope distances + error(ppm of peak mz and mzabs)
+ max.index <- max(which(MI < (sum(params$IM[1:params$maxiso, "mzmax"]) + error.ppm[j] + params$mzabs )))
+ #check if one peaks falls into isotope window
+ if(max.index == 1){
+ #no promising candidate found, move on
+ next;
+ }
+
+ #IM - isotope matrix (column diffs(min,max) per charge, row num. isotope)
+ IM <- t(sapply(1:params$maxcharge,function(x){
+ mzmin <- (params$IM[, "mzmin"]) / x;
+ mzmax <- (params$IM[, "mzmax"]) / x;
+ error <- (error.ppm[j]+params$mzabs) / x
+ res <- c(0,0);
+ for(k in 1:length(mzmin)){
+ res <- c(res, mzmin[k]+res[2*k-1], mzmax[k]+res[2*k])
+ }
+ res[seq(1,length(res),by=2)] <- res[seq(1,length(res),by=2)]-error
+ res[seq(2,length(res),by=2)] <- res[seq(2,length(res),by=2)]+error
+ return (res[-c(1:2)])
+ } ))
+
+ #Sort IM to fix bug, with high ppm and mzabs values
+ #TODO: Find better solution and give feedback to user!
+ IM <- t(apply(IM,1,sort))
+
+ #find peaks, which m/z value is in isotope interval
+ hits <- t(apply(IM, 1, function(x){ findInterval(MI[1:max.index], x)}))
+ rownames(hits) <- c(1:nrow(hits))
+ colnames(hits) <- c(1:ncol(hits))
+ hits[which(hits==0)] <-NA
+ hits <- hits[, -1, drop=FALSE]
+ hits.iso <- hits%/%2 + 1;
+
+
+ #check occurence of first isotopic peak
+ for(iso in 1:min(params$maxiso,ncol(hits.iso))){
+ hit <- apply(hits.iso,1, function(x) any(naOmit(x)==iso))
+ hit[which(is.na(hit))] <- TRUE
+ if(all(hit)) break;
+ hits.iso[!hit,] <- t(apply(hits.iso[!hit,,drop=FALSE],1, function(x) {
+ if(!all(is.na(x))){
+ ini <- which(x > iso)
+ if(!is.infinite(ini) && length(ini) > 0){
+ x[min(ini):ncol(hits.iso)] <- NA
+ }
+ }
+ x
+ }))
+ }
+
+ #set NA to 0
+ hits[which(is.na(hits.iso))] <- 0
+ #check if any isotope is found
+ hit <- apply(hits, 1, function(x) sum(x)>0)
+ #drop nonhits
+ hits <- hits[hit, , drop=FALSE]
+
+ #if no first isotopic peaks exists, next
+ if(nrow(hits) == 0){
+ next;
+ }
+
+ #getting max. isotope cluster length
+ #TODO: unique or not????
+ #isolength <- apply(hits, 1, function(x) length(which(unique(x) %% 2 !=0)))
+ #isohits - for each charge, length of peak within intervals
+ isohits <- lapply(1:nrow(hits), function(x) which(hits[x, ] %% 2 !=0))
+ isolength <- sapply(isohits, length)
+
+ #Check if any result is found
+ if(all(isolength==0)){
+ next;
+ }
+
+ #itensity checks
+ #candidate.matrix
+ #first column - how often succeded the isotope intensity test
+ #second column - how often could a isotope int test be performed
+ candidate.matrix <- matrix(0, nrow=length(isohits), ncol=max(isolength)*2);
+
+ for(iso in 1:length(isohits)){
+ for(candidate in 1:length(isohits[[iso]])){
+ for(sample.index in c(1:ncol(int))){
+ #Test if C12 Peak is NA
+ if(!is.na(int[j, sample.index])){
+ #candidate.matrix[maxIso, 1] <- candidate.matrix[maxIso, 1] + 1
+ }
+ charge <- as.numeric(row.names(hits)[iso])
+ int.c12 <- int[j, sample.index]
+ isotopePeak <- hits[iso,isohits[[iso]][candidate]]%/%2 + 1;
+ if(isotopePeak == 1){
+ #first isotopic peak, check C13 rule
+ int.c13 <- int[isohits[[iso]][candidate]+j, sample.index];
+ int.available <- all(!is.na(c(int.c12, int.c13)))
+ if (int.available){
+ theo.mass <- spectra[j, 1] * charge; #theoretical mass
+ numC <- abs(round(theo.mass / 12)); #max. number of C in molecule
+ inten.max <- int.c12 * numC * 0.011; #highest possible intensity
+ inten.min <- int.c12 * 1 * 0.011; #lowest possible intensity
+ if((int.c13 < inten.max && int.c13 > inten.min) || !params$filter){
+ candidate.matrix[iso,candidate * 2 - 1] <- candidate.matrix[iso,candidate * 2 - 1] + 1
+ candidate.matrix[iso,candidate * 2 ] <- candidate.matrix[iso,candidate * 2] + 1
+ }else{
+ candidate.matrix[iso,candidate * 2 ] <- candidate.matrix[iso,candidate * 2] + 1
+ }
+ } else {
+ #todo
+ }
+ } else {
+ #x isotopic peak
+ int.cx <- int[isohits[[iso]][candidate]+j, sample.index];
+ int.available <- all(!is.na(c(int.c12, int.cx)))
+ if (int.available) {
+ intrange <- c((int.c12 * params$IM[isotopePeak,"intmin"]/100),
+ (int.c12 * params$IM[isotopePeak,"intmax"]/100))
+ #filter Cx isotopic peaks muss be smaller than c12
+ if(int.cx < intrange[2] && int.cx > intrange[1]){
+ candidate.matrix[iso,candidate * 2 - 1] <- candidate.matrix[iso,candidate * 2 - 1] + 1
+ candidate.matrix[iso,candidate * 2 ] <- candidate.matrix[iso,candidate * 2] + 1
+ }else{
+ candidate.matrix[iso,candidate * 2 ] <- candidate.matrix[iso,candidate * 2] + 1
+ }
+ } else {
+ candidate.matrix[iso,candidate * 2 ] <- candidate.matrix[iso,candidate * 2] + 1
+ }#end int.available
+ }#end if first isotopic peak
+ }#for loop samples
+ }#for loop candidate
+ }#for loop isohits
+
+ #calculate ratios
+ candidate.ratio <- candidate.matrix[, seq(from=1, to=ncol(candidate.matrix),
+ by=2)] / candidate.matrix[, seq(from=2,
+ to=ncol(candidate.matrix), by=2)];
+ if(is.null(dim(candidate.ratio))){
+ candidate.ratio <- matrix(candidate.ratio, nrow=nrow(candidate.matrix))
+ }
+ if(any(is.nan(candidate.ratio))){
+ candidate.ratio[which(is.nan(candidate.ratio))] <- 0;
+ }
+
+ #decision between multiple charges or peaks
+ for(charge in 1:nrow(candidate.matrix)){
+ if(any(duplicated(hits[charge, isohits[[charge]]]))){
+ #One isotope peaks has more than one candidate
+ ##check if problem is still consistent
+ for(iso in unique(hits[charge, isohits[[charge]]])){
+ if(length(index <- which(hits[charge, isohits[[charge]]]==iso))== 1){
+ #now duplicates next
+ next;
+ }else{
+ #find best
+ index2 <- which.max(candidate.ratio[charge, index]);
+ save.ratio <- candidate.ratio[charge, index[index2]]
+ candidate.ratio[charge,index] <- 0
+ candidate.ratio[charge,index[index2]] <- save.ratio
+ index <- index[-index2]
+ isohits[[charge]] <- isohits[[charge]][-index]
+ }
+ }
+ }#end if
+
+ for(isotope in 1:ncol(candidate.ratio)){
+ if(candidate.ratio[charge, isotope] >= params$minfrac){
+ isomatrix <- rbind(isomatrix,
+ c(spectra[j, 2],
+ spectra[isohits[[charge]][isotope]+j, 2],
+ isotope, as.numeric(row.names(hits)[charge]), 0))
+ } else{
+ break;
+ }
+ }
+ }#end for charge
+ }#end for j
+
+ return(isomatrix)
+}
+getEICs <- function(xraw,peaks,maxscans=length(xraw@scantime)) {
+ npeaks <- dim(peaks)[1]; scans <- length(xraw@scantime)
+ eics <- matrix(as.numeric(0),npeaks,maxscans)
+ for (p in 1:npeaks) {
+ eics[p,1:scans] <- as.integer(getEIC(xraw,massrange=c(peaks[p,"mzmin"],peaks[p,"mzmax"]))$intensity)
+ }
+ eics
+}
+create.matrix <- function(dim1,dim2) {
+ x <- matrix()
+ length(x) <- dim1*dim2
+ dim(x) <- c(dim1,dim2)
+ x
+}
+getAllPeakEICs <- function(mSet, index=NULL){
+
+ #Checking parameter index
+ if(is.null(index)){
+ stop("Parameter index is not set.\n")
+ }else if(length(index) != nrow(mSet$AnnotateObject$groupInfo)){
+ stop("Index length must equals number of peaks.\n")
+ }
+
+ nfiles <- length(mSet$xcmsSet@filepaths)
+ scantimes <- list()
+
+ if(nfiles == 1){
+ #Single sample experiment
+ if (file.exists(mSet$xcmsSet@filepaths[1])) {
+
+ mSet_splits <- mSet$onDiskData
+ scantimes[[1]] <- scan_length <- sapply(mSet_splits, length)
+ maxscans <- max(scan_length)
+
+ #xraw <- xcmsRaw(filepaths(mSet$xcmsSet)[1],profstep=0)
+ #maxscans <- length(xraw@scantime)
+ #scantimes[[1]] <- xraw@scantime
+ mset$onDiskData <- mSet_splits
+
+ pdata <- as.data.frame(mSet$xcmsSet@peaks)
+
+ EIC <- create.matrix(nrow(pdata),maxscans)
+ EIC[,] <- getEIC4Peaks(mset,pdata,maxscans)#getEIC4Peaks(xraw,pdata,maxscans)
+
+ } else {
+ stop('Raw data file:',mSet$xcmsSet@filepaths[1],' not found ! \n');
+ }
+ } else {
+ #Multiple sample experiment
+ gval <- groupval(mSet$xcmsSet);
+
+ message('Generating EIC\'s . ',appendLF = F)
+
+ #na flag, stores if sample contains NA peaks
+ na.flag <- 0; maxscans <- 0;
+
+ mSet_splits <- split(mSet$onDiskData,fromFile(mSet$onDiskData))
+ message('.',appendLF = F)
+
+ if (file.exists(mSet$xcmsSet@filepaths[1])) {
+
+ scan_length <- sapply(mSet_splits, length)
+
+
+ maxscans <- max(scan_length)
+ message('.',appendLF = F)
+
+ } else {
+
+ stop('Raw data file:',mSet$xcmsSet@filepaths[1],' not found ! \n');
+
+ }
+
+ #generate EIC Matrix
+ EIC <- create.matrix(nrow(gval),maxscans)
+
+
+ mset <-list();mset$env <- new.env(parent=.GlobalEnv)
+ message('.')
+
+
+ #loop over all samples
+ for (f in 1:nfiles){
+
+ message(paste("Detecting",basename(mSet$xcmsSet@filepaths)[f]," ... "),appendLF = F)
+
+ #which peaks should read from this sample
+ idx.peaks <- which(index == f);
+
+ #check if we need data from sample f
+ if(length(idx.peaks) == 0){
+ next;
+ }
+
+ #check if raw data file of sample f exists
+ if (file.exists(mSet$xcmsSet@filepaths[f])) {
+ #read sample
+
+ scantimes[[f]] <- scan_length[f]
+
+ pdata <- as.data.frame(mSet$xcmsSet@peaks[gval[idx.peaks,f],,drop=FALSE]) # data for peaks from file f
+
+ #Check if peak data include NA values
+ if(length(which(is.na(pdata[,1]))) > 0){
+ na.flag <- 1;
+ }
+ mset$onDiskData <- mSet_splits[[f]]
+
+ #Generate raw data according to peak data
+ EIC[idx.peaks,] <- getEIC4Peaks(mset,pdata,maxscans)
+
+ } else {
+ stop('Raw data file:',mSet$xcmsSet@filepaths[f],' not found ! \n')
+ }
+
+ }
+
+ if(na.flag ==1){
+ print("Warning: Found NA peaks in selected sample.");
+ }
+ }
+ invisible(list(scantimes=scantimes,EIC=EIC));
+}
+getEIC4Peaks <- function(mset,peaks,maxscans){
+
+ mset$env$mz <- lapply(MSnbase::spectra(mset$onDiskData, BPPARAM = SerialParam()), mz)
+ mset$env$intensity <- MSnbase::intensity(mset$onDiskData, BPPARAM = SerialParam())
+
+ mset$scantime <- MSnbase::rtime(mset$onDiskData)
+
+ valCount <- cumsum(lengths(mset$env$mz, FALSE))
+ mset$scanindex <- as.integer(c(0, valCount[-length(valCount)])) ## Get index vector for C calls
+
+ npeaks <- dim(peaks)[1];
+ scans <- length(mset$scantime);
+ eics <- matrix(NA,npeaks,maxscans);
+
+ mset$env$mz <- as.double(unlist(mset$env$mz))
+ mset$env$intensity <- as.double(unlist(mset$env$intensity))
+ scan_time_leng <- as.integer(length(mset$scantime))
+
+ message(npeaks," peaks found ! ")
+
+ for (p in 1:npeaks) {
+
+ timerange <- c(peaks[p,"rtmin"],peaks[p,"rtmax"]);
+ tidx <- which((mset$scantime >= timerange[1]) & (mset$scantime <= timerange[2]));
+ if(length(tidx)>0){
+ scanrange <- range(tidx);
+ }else{
+ scanrange <- 1:scans;
+ }
+ massrange <- c(peaks[p,"mzmin"],peaks[p,"mzmax"]);
+ eic <- .Call(C_getEIC,
+ mset$env$mz,
+ mset$env$intensity,
+ as.integer(mset$scanindex),
+ as.double(massrange),
+ as.integer(scanrange),
+ scan_time_leng,
+ PACKAGE ='MetaboAnalystR' )$intensity;
+
+ eic[eic==0] <- NA;
+ eics[p,scanrange[1]:scanrange[2]] <- eic;
+ }
+ eics
+}
+calcCiS<- function(mSet, EIC=EIC, corval=0.75, pval=0.05, psg_list=NULL ){
+
+ #Columns Peak 1, Peak 2, correlation coefficienct, Pseudospectrum Index
+ resMat <- create.matrix(100000,4);
+ colnames(resMat) <- c("x","y","cor","ps")
+ cnt <- 0;
+
+ npeaks <- nrow(mSet$AnnotateObject$groupInfo);
+
+ ncl <- sum(sapply(mSet$AnnotateObject$pspectra, length));
+ npeaks.global <- 0; #Counter for % bar
+ npspectra <- length(mSet$AnnotateObject$pspectra);
+
+ #Check if object have been preprocessed with groupFWHM
+ if(npspectra < 1){
+ npspectra <- 1;
+ mSet$AnnotateObject$pspectra[[1]] <- seq(1:nrow(mSet$AnnotateObject$groupInfo));
+ print('Calculating peak correlations in 1 group. ');
+ lp <- -1;
+ pspectra_list <- 1;
+ mSet$AnnotateObject$psSamples <- 1;
+ }else{
+ if(is.null(psg_list)){
+ print(paste('Calculating peak correlations in',npspectra,'Groups... '));
+ lp <- -1;
+ pspectra_list <- 1:npspectra;
+ }else{
+ print(paste('Calculating peak correlations in',length(psg_list),'Groups... '));
+ lp <- -1;
+ pspectra_list <- psg_list;
+ ncl <- sum(sapply(mSet$AnnotateObject$pspectra[psg_list],length));
+ }
+ }
+
+ if(dim(EIC)[2] != npeaks){
+ EIC <- t(EIC);
+ #Second check, otherwise number of peaks != number of EIC curves
+ if(dim(EIC)[2] != npeaks){
+ stop(paste("Wrong dimension of EIC. It has ",dim(EIC)[1]," Rows for ",npeaks,"peaks",sep=""));
+ }
+ }
+ lp <- -1;
+ #Iterate over all PS-spectra
+ pb <- progress_bar$new(format = "Generating [:bar] :percent Time left: :eta", total = length(pspectra_list), clear = T, width= 75)
+
+ for(j in 1:length(pspectra_list)){
+ i <- pspectra_list[j];
+ pi <- mSet$AnnotateObject$pspectra[[i]];
+ npi <- length(pi);
+
+ if( ((npi^2)/2 + cnt) >= nrow(resMat)){
+ #resize resMat
+ resMat <- rbind(resMat,create.matrix(100000,4));
+ }
+
+ pb$tick();
+
+ #Need at least two peaks for correlation
+ if(npi < 2) {
+ next;
+ }
+
+ #Suppress warnings
+ options(warn = -1);
+ res <- Hmisc::rcorr(EIC[, pi], type="pearson")
+ options(warn = 0);
+
+ #Set lower triangle to NA
+ res$r[lower.tri(res$r,diag = TRUE)] <- NA;
+ res$P[lower.tri(res$P,diag = TRUE)] <- NA;
+
+ #Find peaks with have correlation higher corr_threshold and p <= 0.05
+ index <- which(( res$r > corval) & (res$P <= pval))
+ if( (length(index) + cnt) >= nrow(resMat)){
+ #resize resMat
+ resMat <- rbind(resMat, create.matrix(max(length(index)+1,100000),4));
+ }
+
+ if(length(index) > 0){
+ for( x in 1:(length(index))){
+ col <- index[x] %/% npi + 1;
+ row <- index[x] %% npi;
+ if(row == 0){
+ row <- npi;
+ col <- col - 1;
+ }
+ xi <- pi[row];
+ yi <- pi[col];
+ #y > x should be satisfied for every value, since we have set lower.tri to NA
+ cnt<-cnt+1;
+ resMat[cnt,] <- c(xi,yi,res$r[row, col],i);
+ }
+ }else{
+ next;
+ }
+ }
+
+
+ return(invisible(resMat[1:cnt,,drop=FALSE]))
+}
+calcPC.hcs <- function(mSet, ajc=NULL,psg_list=NULL) {
+
+ npspectra <- length(mSet$AnnotateObject$pspectra);
+ pspectra <- mSet$AnnotateObject$pspectra
+ psSamples <- mSet$AnnotateObject$psSamples;
+ npeaks.global <- 0;
+ ncl <- sum(sapply(mSet$AnnotateObject$pspectra, length));
+ colnames(ajc)[3] <- c("weight") ##todo: Change to generell ajc interface
+
+ #Information for % output
+ if(is.null(psg_list)){
+ print(paste('Calculating graph cross linking in', npspectra, 'Groups...'));
+ lperc <- -1;
+ pspectra_list <- 1:npspectra;
+ ncl <- sum(sapply(mSet$AnnotateObject$pspectra, length));
+ }else{
+ print(paste('Calculating graph cross linking in',length(psg_list),'Groups...'));
+ lperc <- -1;
+ pspectra_list <- psg_list;
+ ncl <- sum(sapply(mSet$AnnotateObject$pspectra[psg_list], length));
+ }
+
+ #peak counter
+ npeaks <- 0;
+ lp <- -1;
+ pb <- progress_bar$new(format = "Calculating [:bar] :percent Time left: :eta", total = length(pspectra_list), clear = T, width= 75)
+
+ for(j in 1:length(pspectra_list)){
+ i <- pspectra_list[j];#index of pseudospectrum
+ pi <- mSet$AnnotateObject$pspectra[[i]]; #peak_id in pseudospectrum
+ names(pi) <- as.character(pi);
+
+ #percent output
+ pb$tick();
+ #end percent output
+
+ index <- which(ajc[,4] == i)
+ if(length(index) < 1){
+ g <- ftM2graphNEL(matrix(nrow=0,ncol=2),V=as.character(pi),edgemode="undirected")
+ }else{
+ g <- ftM2graphNEL(ajc[index,1:2,drop=FALSE],W=ajc[index,3,drop=FALSE], V=as.character(pi), edgemode="undirected");
+ }
+ hcs <- highlyConnSG(g);
+
+ #order cluster after size
+ cnts <- sapply(hcs$clusters,length);
+ grps <- 1:length(hcs$clusters);
+ grps <- grps[order(cnts, decreasing = TRUE)]
+
+ for (ii in 1:length(grps)){
+ if(ii==1){
+ #save old pspectra number
+ pspectra[[i]] <- as.integer(hcs$cluster[[grps[ii]]])
+ pi[hcs$cluster[[grps[ii]]]] <- NA
+ } else {
+ npspectra <- npspectra +1
+ pspectra[[npspectra]] <- as.integer(hcs$cluster[[grps[ii]]])
+ pi[hcs$cluster[[grps[ii]]]] <- NA
+ psSamples[npspectra] <- psSamples[i]
+ }
+ }
+ index <- which(!is.na(pi));
+ if(length(index)>0){
+ for(ii in 1:length(index)){
+ npspectra <- npspectra +1
+ pspectra[[npspectra]] <- pi[index[ii]]
+ psSamples[npspectra] <- psSamples[i]
+ }
+ }
+
+ }
+
+ mSet$AnnotateObject$pspectra <- pspectra;
+ mSet$AnnotateObject$psSamples <- psSamples;
+
+ print(paste("New number of ps-groups: ",length(pspectra)));
+ return(mSet)
+}
+findAdducts <- function(mSet, ppm=5, mzabs=0.015, multiplier=3, polarity=NULL, rules=NULL,
+ max_peaks=100, psg_list=NULL, intval="maxo",maxcharge){
+ multFragments=FALSE;
+ # Scaling ppm factor
+ devppm <- ppm / 1000000;
+ # counter for % bar
+ npeaks.global <- 0;
+
+ # get mz values from peaklist
+ imz <- mSet$AnnotateObject$groupInfo[, "mz"];
+
+ #number of pseudo-spectra
+ npspectra <- length(mSet$AnnotateObject$pspectra);
+
+ #If groupCorr or groupFHWM have not been invoke, select all peaks in one sample
+ if(npspectra < 1){
+ npspectra <- 1;
+ mSet$AnnotateObject$pspectra[[1]] <- seq(1:nrow(mSet$AnnotateObject$groupInfo));
+ }
+
+ if(mSet$AnnotateObject$sample == 1 && length(rownames(mSet$xcmsSet@phenoData)) == 1){
+ ##one sample case
+ mint <- mSet$AnnotateObject$groupInfo[, intval];
+ }else{
+ ##multiple sample
+ if(is.na(mSet$AnnotateObject$sample[1])){
+ index <- 1:length(mSet$xcmsSet@filepaths);
+ }else{
+ index <- mSet$AnnotateObject$sample;
+ }
+
+ print("Generating peak matrix for peak annotation!");
+ mint <- groupval(mSet$xcmsSet,value=intval)[, index, drop=FALSE];
+ peakmat <- mSet$xcmsSet@peaks;
+ groupmat <- mSet$xcmsSet@groups;
+
+ imz <- groupmat[, "mzmed"];
+ irt <- groupmat[, "rtmed"];
+ int.val <- c();
+ nsample <- length(mSet$AnnotateObject$sample);
+ }
+
+
+ # isotopes
+ isotopes <- mSet$AnnotateObject$isotopes;
+ # adductlist
+ derivativeIons <- vector("list", length(imz));
+
+ # other variables
+ oidscore <- c();
+ index <- c();
+ annoID <- matrix(ncol=4, nrow=0)
+ annoGrp <- matrix(ncol=4, nrow=0)
+ colnames(annoID) <- colnames(mSet$AnnotateObject$annoID)
+ colnames(annoGrp) <- colnames(mSet$AnnotateObject$annoGrp)
+
+ ##Examine polarity and rule set
+ if(!(mSet$AnnotateObject$polarity == "")){
+ print(paste("Polarity is set in annotaParam:", mSet$AnnotateObject$polarity));
+ if(is.null(rules)){
+ if(!is.null(mSet$AnnotateObject$ruleset)){
+ rules <- mSet$AnnotateObject$ruleset;
+ }else{
+ print("Ruleset could not read from object! Recalculate");
+ rules <- calcRules(maxcharge=maxcharge, mol=3, nion=2, nnloss=1, nnadd=1, nh=2,
+ polarity=mSet$AnnotateObject$polarity,
+ lib.loc= .libPaths(), multFragments=multFragments);
+ mSet$AnnotateObject$ruleset <- rules;
+ }
+ }else{
+ mSet$AnnotateObject$ruleset <- rules;
+ print("Found and use user-defined ruleset!");
+ }
+ }else{
+ if(!is.null(polarity)){
+ if(polarity %in% c("positive","negative")){
+ if(is.null(rules)){
+ rules <- calcRules(maxcharge=maxcharge, mol=3, nion=2, nnloss=1, nnadd=1,
+ nh=2, polarity=polarity, lib.loc= .libPaths(),
+ multFragments=multFragments);
+ }else{ print("Found and use user-defined ruleset!");}
+ mSet$AnnotateObject$polarity <- polarity;
+ }else stop("polarity mode unknown, please choose between positive and negative.")
+ }else if(length(mSet$xcmsSet@polarity) > 0){
+ index <- which(sampclass(mSet$xcmsSet) == mSet$AnnotateObject$category)[1] + mSet$AnnotateObject$sample-1;
+ if(mSet$xcmsSet@polarity[index] %in% c("positive","negative")){
+ if(is.null(rules)){
+ rules <- calcRules(maxcharge=maxcharge, mol=3, nion=2, nnloss=1, nnadd=1,
+ nh=2, polarity=mSet$xcmsSet@polarity[index],
+ lib.loc= .libPaths(), multFragments=multFragments);
+ }else{ print("Found and use user-defined ruleset!");}
+ mSet$AnnotateObject$polarity <- polarity;
+ }else stop("polarity mode in xcmsSet unknown, please define variable polarity.")
+ }else stop("polarity mode could not be estimated from the xcmsSet, please define variable polarity!")
+ #save ruleset
+ mSet$AnnotateObject$ruleset <- rules;
+ }
+
+ ##Run as single or parallel mode
+ runParallel <- 0;
+
+ if(mSet$AnnotateObject$runParallel$enable == 1){
+ if(!(is.null(mSet$AnnotateObject$runParallel$cluster)) || mpi.comm.size() > 0 ){
+ runParallel <- 1;
+ }else{
+ warning("CAMERA runs in parallel mode, but no slaves are spawned!\nRun in single core mode!\n");
+ runParallel <- 0;
+ }
+ }else{
+ runParallel <- 0;
+ }
+
+ if("quasi" %in% colnames(rules)){
+ #backup for old rule sets
+ quasimolion <- which(rules[, "quasi"]== 1)
+ }else{
+ quasimolion <- which(rules[, "mandatory"]== 1)
+ }
+
+ #Remove recognized isotopes from annotation m/z vector
+ for(x in seq(along = isotopes)){
+ if(!is.null(isotopes[[x]])){
+ if(isotopes[[x]]$iso != 0){
+ imz[x] <- NA;
+ }
+ }
+ }
+
+ #counter for % bar
+ npeaks <- 0;
+ massgrp <- 0;
+ ncl <- sum(sapply(mSet$AnnotateObject$pspectra, length));
+
+ if (runParallel == 1) { ## ... we run in parallel mode
+ if(is.null(psg_list)){
+ print(paste('Calculating possible adducts in',npspectra,'Groups... '));
+ lp <- -1;
+ pspectra_list <- 1:npspectra;
+ }else{
+ print(paste('Calculating possible adducts in',length(psg_list),'Groups... '));
+ lp <- -1;
+ pspectra_list <- psg_list;
+ }
+
+ argList <- list();
+
+ cnt_peak <- 0;
+ if(is.null(max_peaks)){
+ max_peaks=100;
+ }
+ paramsGlobal <- list();
+ if("typ" %in% colnames(rules)){
+ rules.idx <- which(rules[, "typ"]== "A")
+ parent <- TRUE;
+ }else{
+ #backup for old rule sets
+ rules.idx <- 1:nrow(rules);
+ parent <- FALSE;
+ }
+
+ #Add params to env
+ paramsGlobal <- list()
+ paramsGlobal$pspectra <- mSet$AnnotateObject$pspectra;
+ paramsGlobal$imz <- imz;
+ paramsGlobal$rules <- rules;
+ paramsGlobal$mzabs <- mzabs;
+ paramsGlobal$devppm <- devppm;
+ paramsGlobal$isotopes <- isotopes;
+ paramsGlobal$quasimolion <- quasimolion;
+ paramsGlobal$parent <- parent;
+ paramsGlobal$rules.idx <- rules.idx;
+ #create params
+ #paramsGlobal <- list2env(params)
+
+ params <- list();
+
+ for(j in 1:length(pspectra_list)){
+ i <- pspectra_list[j];
+ params$i[[length(params$i)+1]] <- i;
+ cnt_peak <- cnt_peak+length(mSet$AnnotateObject$pspectra[[i]]);
+ if(cnt_peak > max_peaks || j == length(pspectra_list)){
+ argList[[length(argList)+1]] <- params
+ cnt_peak <- 0;
+ params <- list();
+ }
+ }
+
+ #Some informationen for the user
+ print(paste("Parallel mode: There are",length(argList), "tasks."))
+
+ if(is.null(mSet$AnnotateObject$runParallel$cluster)){
+ #Use MPI
+ result <- xcmsPapply(argList, annotateGrpMPI2, paramsGlobal)
+ }else{
+ #For snow
+ result <- xcms:::xcmsClusterApply(cl=mSet$AnnotateObject$runParallel$cluster,
+ x=argList, fun=annotateGrpMPI,
+ msgfun=msgfun.snowParallel,
+ paramsGlobal)
+ }
+
+ for(ii in 1:length(result)){
+ if(length(result[[ii]]) == 0){
+ next;
+ }
+ for(iii in 1:length(result[[ii]])){
+ hypothese <- result[[ii]][[iii]];
+ if(is.null(hypothese)){
+ next;
+ }
+ charge <- 0;
+ old_massgrp <- 0;
+ index <- argList[[ii]]$i[[iii]];
+ ipeak <- mSet$AnnotateObject$pspectra[[index]];
+ for(hyp in 1:nrow(hypothese)){
+ peakid <- as.numeric(ipeak[hypothese[hyp, "massID"]]);
+ if(old_massgrp != hypothese[hyp,"massgrp"]) {
+ massgrp <- massgrp+1;
+ old_massgrp <- hypothese[hyp,"massgrp"];
+ annoGrp <- rbind(annoGrp,c(massgrp,hypothese[hyp,"mass"],
+ sum(hypothese[ which(hypothese[,"massgrp"]==old_massgrp),"score"]),i) )
+ }
+
+ if(parent){
+ annoID <- rbind(annoID, cbind(peakid, massgrp, hypothese[hyp, c("ruleID","parent")]))
+ }else{
+ annoID <- rbind(annoID, cbind(peakid, massgrp, hypothese[hyp, c("ruleID")],NA))
+ }
+
+ }
+ }
+ }
+
+ derivativeIons <- getderivativeIons(annoID,annoGrp,rules,length(imz));
+
+ mSet$AnnotateObject$derivativeIons <- derivativeIons;
+ mSet$AnnotateObject$annoID <- annoID;
+ mSet$AnnotateObject$annoGrp <- annoGrp;
+ return(object)
+ } else {
+ ##Parallel Core Mode
+ if(is.null(psg_list)){
+ print(paste('Calculating possible adducts in',npspectra,'Groups... '));
+ lp <- -1;
+ pspectra_list <- 1:npspectra;
+ }else{
+ print(paste('Calculating possible adducts in',length(psg_list),'Groups... '));
+ lp <- -1;
+ pspectra_list <- psg_list;
+ sum_peaks <- sum(sapply(mSet$AnnotateObject$pspectra[psg_list],length));
+ }
+
+ if("typ" %in% colnames(rules)){
+ rules.idx <- which(rules[, "typ"]== "A")
+ parent <- TRUE;
+ }else{
+ #backup for old rule sets
+ rules.idx <- 1:nrow(rules);
+ parent <- FALSE;
+ }
+ along = pspectra_list;
+ pb <- progress_bar$new(format = "Calculating [:bar] :percent Time left: :eta", total = length(along), clear = T, width= 75)
+
+ for(j in seq(along)){
+ i <- pspectra_list[j];
+
+ #peak index for those in pseudospectrum i
+ ipeak <- mSet$AnnotateObject$pspectra[[i]];
+
+ #percent output
+ pb$tick();
+ #end percent output
+
+ #check if the pspec contains more than one peak
+ if(length(ipeak) > 1){
+
+ hypothese <- annotateGrp(ipeak, imz, rules, mzabs, devppm, isotopes, quasimolion, rules.idx=rules.idx);
+ #save results
+ if(is.null(hypothese)){
+ next;
+ }
+ charge <- 0;
+ old_massgrp <- 0;
+
+ #combine annotation hypotheses to annotation groups for one compound mass
+ for(hyp in 1:nrow(hypothese)){
+ peakid <- as.numeric(ipeak[hypothese[hyp, "massID"]]);
+ if(old_massgrp != hypothese[hyp, "massgrp"]) {
+ massgrp <- massgrp + 1;
+ old_massgrp <- hypothese[hyp, "massgrp"];
+ annoGrp <- rbind(annoGrp, c(massgrp, hypothese[hyp, "mass"],
+ sum(hypothese[ which(hypothese[, "massgrp"] == old_massgrp), "score"]), i) )
+ }
+ if(parent){
+ annoID <- rbind(annoID, c(peakid, massgrp, hypothese[hyp, "ruleID"], ipeak[hypothese[hyp, "parent"]]))
+ }else{
+ annoID <- rbind(annoID, c(peakid, massgrp, hypothese[hyp, "ruleID"], NA))
+ }
+ }
+ }
+ }
+
+ derivativeIons <- getderivativeIons(annoID, annoGrp, rules, length(imz));
+
+
+ mSet$AnnotateObject$derivativeIons <- derivativeIons;
+ mSet$AnnotateObject$annoID <- annoID;
+ mSet$AnnotateObject$annoGrp <- annoGrp;
+ return(mSet)
+ }
+}
+getPeaklist <- function(mSet, intval="into") {
+
+ if (! intval %in% colnames(mSet$xcmsSet@peaks)) {
+ stop("unknown intensity value!")
+ }
+
+ #generate peaktable
+ #Check if xcmsSet contains only one sample
+ if(mSet$AnnotateObject$sample == 1 && length(rownames(mSet$xcmsSet@phenoData)) == 1){
+ #intval is here ignored since all intensity values are already contained
+ peaktable <- mSet$AnnotateObject$groupInfo;
+ }else {
+ #Case of xcmsSet with multiple samples
+ #Use groupInfo information and replace intensity values
+ peaktable <- mSet$AnnotateObject$groupInfo;
+
+ #get intensity values from xcmsSet
+ grpval <- groupval(mSet$xcmsSet, value=intval);
+
+ #get column range for replacement
+ grpval.ncol <- ncol(grpval)
+ start <- ncol(peaktable) - grpval.ncol +1;
+ ende <- start + grpval.ncol - 1;
+
+ peaktable[, start:ende] <- grpval;
+ }
+
+ #allocate variables for CAMERA output
+ adduct <- vector("character", nrow(mSet$AnnotateObject$groupInfo));
+ isotopes <- vector("character", nrow(mSet$AnnotateObject$groupInfo));
+ pcgroup <- vector("character", nrow(mSet$AnnotateObject$groupInfo));
+
+ #default polarity set to positive
+ polarity <- "+";
+
+ if(length(mSet$AnnotateObject$polarity) > 0){
+ if(mSet$AnnotateObject$polarity == "negative"){
+ polarity <- "-";
+ }
+ }
+
+ #First isotope informationen and adduct informationen
+ for(i in seq(along = isotopes)){
+ #check if adduct annotation is present for peak i
+ if(length(mSet$AnnotateObject$derivativeIons) > 0 && !(is.null(mSet$AnnotateObject$derivativeIons[[i]]))) {
+ #Check if we have more than one annotation for peak i
+ if(length(mSet$AnnotateObject$derivativeIons[[i]]) > 1) {
+ #combine ion species name and rounded mass hypophysis
+ names <- paste(mSet$AnnotateObject$derivativeIons[[i]][[1]]$name, signif(mSet$AnnotateObject$derivativeIons[[i]][[1]]$mass, 6));
+ for(ii in 2:length(mSet$AnnotateObject$derivativeIons[[i]])) {
+ names <- paste(names, mSet$AnnotateObject$derivativeIons[[i]][[ii]]$name, signif(mSet$AnnotateObject$derivativeIons[[i]][[ii]]$mass, 6));
+ }
+ #save name in vector adduct
+ adduct[i] <- names;
+ } else {
+ #Only one annotation
+ adduct[i] <- paste(mSet$AnnotateObject$derivativeIons[[i]][[1]]$name, signif(mSet$AnnotateObject$derivativeIons[[i]][[1]]$mass, 6));
+ }
+ } else {
+ #no annotation empty name
+ adduct[i] <- "";
+ }
+
+ #Check if we have isotope informationen about peak i
+ if(length(mSet$AnnotateObject$isotopes) > 0&& !is.null(mSet$AnnotateObject$isotopes[[i]])) {
+ num.iso <- mSet$AnnotateObject$isotopes[[i]]$iso;
+ #Which isotope peak is peak i?
+ if(num.iso == 0){
+ str.iso <- "[M]";
+ } else {
+ str.iso <- paste("[M+", num.iso, "]", sep="")
+ }
+ #Multiple charged?
+ if(mSet$AnnotateObject$isotopes[[i]]$charge > 1){
+ isotopes[i] <- paste("[", mSet$AnnotateObject$isotopes[[i]]$y, "]", str.iso, mSet$AnnotateObject$isotopes[[i]]$charge, polarity, sep="");
+ }else{
+ isotopes[i] <- paste("[", mSet$AnnotateObject$isotopes[[i]]$y, "]", str.iso, polarity, sep="");
+ }
+ } else {
+ #No isotope informationen available
+ isotopes[i] <- "";
+ }
+ }
+
+ #Have we more than one pseudospectrum?
+ if(length(mSet$AnnotateObject$pspectra) < 1){
+ pcgroup <- 0;
+ } else {
+ for(i in seq(along = mSet$AnnotateObject$pspectra)){
+ index <- mSet$AnnotateObject$pspectra[[i]];
+ pcgroup[index] <- i;
+ }
+ }
+
+ rownames(peaktable)<-NULL;#Bugfix for: In data.row.names(row.names, rowsi, i) :Â some row.names duplicated:
+ return(invisible(data.frame(peaktable, isotopes, adduct, pcgroup, stringsAsFactors=FALSE, row.names=NULL)));
+}
+sampclass <- function(object) {
+ if (ncol(object@phenoData) >0) {
+ if(any(colnames(object@phenoData)=="class")){
+ sclass <- object$class
+ ## in any rate: transform class to a character vector
+ ## and generate a new factor on that with the levels
+ ## being in the order of the first occurrence of the
+ ## elements (i.e. no alphanumeric ordering).
+ sclass <- as.character(sclass)
+ sclass <- factor(sclass, levels=unique(sclass))
+ return(sclass)
+ }
+ interaction(object@phenoData, drop=TRUE)
+ } else {
+ factor()
+ }
+}
+calcRules <- function (maxcharge=3, mol=3, nion=2, nnloss=1,
+ nnadd=1, nh=2, polarity=NULL, lib.loc = .libPaths(), multFragments=FALSE){
+
+ r <- new("ruleSet")
+
+ r <- setDefaultLists(r, lib.loc=lib.loc)
+ r <- readLists(r)
+ r <- setParams(r, maxcharge=maxcharge, mol=mol, nion=nion,
+ nnloss=nnloss, nnadd=nnadd, nh=nh, polarity=polarity, lib.loc = lib.loc)
+ if(multFragments){
+ r <- generateRules2(r)
+ }else{
+ r <- generateRules(r)
+ }
+
+ return(r@rules)
+}
+
+generateRules <- function (object) {
+
+ maxcharge=object@maxcharge
+ mol=object@mol
+ nion=object@nion
+ nnloss=object@nnloss
+ nnadd=object@nnadd
+ nh=object@nh
+ polarity=object@polarity
+
+ ionlist=object@ionlist
+ neutralloss=object@neutralloss
+ neutraladdition=object@neutraladdition
+
+ rules=object@rules
+
+ name<-c();
+ nmol<-c();
+ charge<-c();
+ massdiff<-c();
+ oidscore<-c();
+ quasi<-c();
+ ips<-c();
+
+ ##Erzeuge Regeln
+ tmpname <- c();
+ tmpnmol <- c();
+ tmpcharge <- 0;
+ tmpmass <- 0;
+ tmpips <- 0;
+
+ ## Molekülionen
+ if(polarity=="positive"){
+ ## Wasserstoff, hard codiert
+ for(k in 1:mol){
+ if(k == 1){
+ str <- "";
+ tmpips <- 1.0;
+ }else{
+ str <- k;
+ tmpips <- 0.5;
+ };
+ name <- append(name, paste("[", str, "M+H]+", sep=""));
+ charge <- append(charge, 1);
+ massdiff <- append(massdiff, 1.007276);
+ nmol <- append(nmol, k);
+ if(k == 1) {
+ quasi <- append(quasi, 1);
+ } else {
+ quasi <- append(quasi, 0);
+ };
+ oidscore <- append(oidscore, 1);
+ ips <- append(ips, tmpips)
+ name <- append(name,paste("[",str,"M+2H]2+",sep=""));
+ charge<-append(charge,2);
+ massdiff<-append(massdiff,2.014552);
+ nmol<-append(nmol,k);quasi<-append(quasi,0);
+ oidscore<-append(oidscore,2);
+ ips<-append(ips,tmpips)
+ name<-append(name,paste("[",str,"M+3H]3+",sep=""));
+ charge<-append(charge,3);
+ massdiff<-append(massdiff,3.021828);
+ nmol<-append(nmol,k);
+ quasi<-append(quasi,0);
+ oidscore<-append(oidscore,3);
+ ips<-append(ips,tmpips)
+ oid<-3;
+ for(i in 1:nrow(ionlist)){
+ if(ionlist[i,2]<=0) {next;}
+ if(ionlist[i,2]==1){
+ name<-append(name,paste("[",str,"M+H+",ionlist[i,1],"]2+",sep=""));
+ }else{
+ name<-append(name,paste("[",str,"M+H+",ionlist[i,1],"]",ionlist[i,2]+1,"+",sep=""));
+ }
+ charge <- append(charge,ionlist[i,2]+1);
+ massdiff <- append(massdiff,ionlist[i,3]+1.007276);
+ nmol <- append(nmol,k);
+ quasi <- append(quasi,0);
+ oidscore <- append(oidscore,oid+i);
+ if(tmpips>0.75){
+ ips<-append(ips,0.5)
+ }else{
+ ips<-append(ips,tmpips);
+ }#Austausch
+ }
+ oid<-oid+nrow(ionlist);
+ coeff<-expand.grid(rep(list(0:nion),nrow(ionlist)))
+ if(length(list<-which(ionlist[,2]<=0))>0){
+ coeff[,list]<-0;
+ }
+ coeff<-unique(coeff);
+ coeff<-cbind(coeff,rep(0,nrow(coeff)));
+ coeff<-coeff[-1,]
+ tmp<-NULL;
+ for(i in 1:nrow(ionlist)){
+ if(ionlist[i,2]<=0)next;
+ ## Austausch erstmal nur einen pro Ion
+ tmp<-rbind(tmp,t(apply(coeff,1,function(x) {x[i]<-x[i]+1;x[nrow(ionlist)+1]<-1;x})));
+ }
+ coeff<-unique(rbind(coeff,tmp));
+ i <- 1
+ while (i <= nrow(coeff)){
+ tmpname<-paste("[",str,"M",sep="");
+ tmpcharge<-0;tmpmass<-0;
+ for(ii in 1:(ncol(coeff)-1)){
+ if(coeff[i,ii]>0){
+ if(coeff[i,ii]>1){
+ tmpname<-paste(tmpname,"+",coeff[i,ii],ionlist[ii,1],sep="");
+ }else{
+ tmpname<-paste(tmpname,"+",ionlist[ii,1],sep="");
+ }
+ tmpcharge<-tmpcharge+coeff[i,ii]*ionlist[ii,2];
+ tmpmass<-tmpmass+coeff[i,ii]*ionlist[ii,3]
+ }
+ }
+ if(coeff[i,ncol(coeff)]>0){
+ ## Austausch hat stattgefunden, einfach bsp 1
+ tmpname<-paste(tmpname,"-H",sep="");
+ tmpcharge<-tmpcharge-1;
+ tmpmass<-tmpmass-1.007276;
+ tmpips<-0.25;
+ }
+ if(tmpcharge>1){
+ tmpname<-paste(tmpname,"]",tmpcharge,"+",sep="")
+ }else{
+ tmpname<-paste(tmpname,"]+",sep="")
+ }
+ name<-append(name,tmpname)
+ charge<-append(charge,tmpcharge)
+ massdiff<-append(massdiff,tmpmass)
+ nmol <- append(nmol,k);
+ oidscore<-append(oidscore,oid+i)
+ if(sum(coeff[i,])==1&& k==1){
+ quasi <- append(quasi,1);
+ ips <-append(ips,tmpips);
+ }else{
+ quasi <- append(quasi,0);
+ if(tmpips>0.75){
+ ips <- append(ips,0.75);
+ }else{
+ ips <- append(ips,tmpips);
+ }
+ }
+ i <- i+1
+ }
+ }
+ oid<-max(oidscore);
+
+ ## Create Neutral Addition
+ index<-which(quasi==1)
+
+ if (nrow(neutraladdition)>0) {
+ for(i in 1:nrow(neutraladdition)) {
+ if(length(index2<-which(ionlist[,2]>0))>0){
+ for(ii in 1:length(index2)){
+ if(ionlist[index2[ii],2] > 1){
+ name <- append(name,paste("[M+",ionlist[index2[ii],1],"+",neutraladdition[i,1],"]",abs(ionlist[index2[ii],2]),"+",sep=""));
+ }else{
+ name <- append(name,paste("[M+",ionlist[index2[ii],1],"+",neutraladdition[i,1],"]+",sep=""));
+ }
+ charge <- append(charge,ionlist[index2[ii],2]);
+ massdiff <- append(massdiff,neutraladdition[i,2]+ionlist[index2[ii],3]);
+ nmol <- append(nmol,1);
+ quasi <- append(quasi,0);
+ oidscore <- append(oidscore,oid+1);oid<-oid+1;
+ ips<-append(ips,0.5);
+ }
+ }
+ if(neutraladdition[i,1]=="NaCOOH"){next;}
+ name<-append(name,paste("[M+H+",neutraladdition[i,1],"]+",sep=""));
+ charge<-append(charge,+1);
+ massdiff<- append(massdiff,neutraladdition[i,2]+1.007276);
+ nmol<-append(nmol,1);
+ quasi<-append(quasi,0)
+ oidscore<-append(oidscore,oid+1);oid<-oid+1;
+ ips<-append(ips,0.5);
+ }
+ oid<-max(oidscore);
+ }
+
+ ##Erzeuge Neutral loss
+ index<-which(quasi==1)
+ for(i in 1:nrow(neutralloss)){
+ for(ii in 1:maxcharge){
+ if(ii > 1){
+ name<-append(name,paste("[M+",ii,"H-",neutralloss[i,1],"]",ii,"+",sep=""));
+ }else {name<-append(name,paste("[M+H-",neutralloss[i,1],"]+",sep=""));}
+ charge<-append(charge,ii);
+ massdiff<- append(massdiff,-neutralloss[i,2]+1.007276*ii);
+ nmol<-append(nmol,1);
+ quasi<-append(quasi,0)
+ oidscore<-append(oidscore,oid+1);oid<-oid+1;
+ ips<-append(ips,0.25);
+ }
+ }
+ ruleset <- data.frame(name,nmol,charge,massdiff,oidscore,quasi,ips)
+ if(length(index<-which(ruleset[,"charge"]>maxcharge))>0){
+ ruleset<- ruleset[-index,];
+ }
+ }else if(polarity=="negative"){
+ ## Wasserstoff, hard codiert
+ for(k in 1:mol){
+ if(k==1){str<-"";tmpips<-1.0;}else{str<-k;tmpips<-0.5};
+ name<-append(name,paste("[",str,"M-H]-",sep=""));
+ charge<-append(charge,-1);massdiff<-append(massdiff,-1.007276);nmol<-append(nmol,k);if(k==1){quasi<-append(quasi,1);}else{quasi<-append(quasi,0);};oidscore<-append(oidscore,1);ips<-append(ips,tmpips)
+ name<-append(name,paste("[",str,"M-2H]2-",sep=""));charge<-append(charge,-2);massdiff<-append(massdiff,-2.014552);nmol<-append(nmol,k);quasi<-append(quasi,0);oidscore<-append(oidscore,2);ips<-append(ips,tmpips)
+ name<-append(name,paste("[",str,"M-3H]3-",sep=""));charge<-append(charge,-3);massdiff<-append(massdiff,-3.021828);nmol<-append(nmol,k);quasi<-append(quasi,0);oidscore<-append(oidscore,3);ips<-append(ips,tmpips)
+ oid<-3;
+ for(i in 1:nrow(ionlist)){
+ if(ionlist[i,2]>=0){
+ if(ionlist[i,2] == 1){
+ name<-append(name,paste("[",str,"M-2H+",ionlist[i,1],"]-",sep=""));
+ charge <- append(charge,ionlist[i,2]-2);
+ massdiff<- append(massdiff,ionlist[i,3]-(2*1.007276));
+ nmol <- append(nmol,k);
+ quasi <- append(quasi,0);
+ oidscore<-append(oidscore,oid+i);
+ ips<-append(ips,0.25);
+ next;
+ } else {
+ if(ionlist[i,2] > maxcharge) {next;}
+ localCharge <- ionlist[i,2]+1
+ name<-append(name,paste("[",str,"M-",localCharge,"H+",ionlist[i,1],"]-",sep=""));
+ charge <- append(charge,ionlist[i,2]-localCharge);
+ massdiff<- append(massdiff,ionlist[i,3]-(localCharge*1.007276));
+ nmol <- append(nmol,k);
+ quasi <- append(quasi,0);
+ oidscore<-append(oidscore,oid+i);
+ ips<-append(ips,0.25);
+ next;
+ }
+ }
+ if(ionlist[i,2]== -1){
+ name<-append(name,paste("[",str,"M-H+",ionlist[i,1],"]2-",sep=""));
+ }else{
+ name<-append(name,paste("[",str,"M-H+",ionlist[i,1],"]",ionlist[i,2]+1,"-",sep=""));
+ }
+ charge <- append(charge,ionlist[i,2]-1);
+ massdiff<- append(massdiff,ionlist[i,3]-1.007276);
+ nmol <- append(nmol,k);
+ quasi <- append(quasi,0);
+ oidscore<-append(oidscore,oid+i);
+ ips<-append(ips,tmpips);
+ #Austausch
+ }
+ oid<-oid+nrow(ionlist);
+ coeff<-expand.grid(rep(list(0:nion),nrow(ionlist)))
+ if(length(list<-which(ionlist[,2]>=0))>0){
+ coeff[,list]<-0;
+ }
+ coeff<-unique(coeff);
+ coeff<-cbind(coeff,rep(0,nrow(coeff)));
+ coeff<-coeff[-1,] ## remove first row
+ i <- 1
+ while (i <= nrow(coeff)){
+ tmpname<-paste("[",str,"M",sep="");
+ tmpcharge<-0;tmpmass<-0;
+ for(ii in 1:(ncol(coeff)-1)){
+ if(coeff[i,ii]>0){
+ if(coeff[i,ii]>1){
+ tmpname<-paste(tmpname,"+",coeff[i,ii],ionlist[ii,1],sep="");
+ }else{
+ tmpname<-paste(tmpname,"+",ionlist[ii,1],sep="");
+ }
+ tmpcharge<-tmpcharge+coeff[i,ii]*ionlist[ii,2];
+ tmpmass<-tmpmass+coeff[i,ii]*ionlist[ii,3]
+ }
+ }
+ if(coeff[i,ncol(coeff)]>0){
+ #Austausch hat stattgefunden, einfach bsp 1
+ tmpname<-paste(tmpname,"-H",sep="");
+ tmpcharge<-tmpcharge-1;
+ tmpmass<-tmpmass-1.007276;
+ tmpips<-0.5;
+ }
+ if(tmpcharge< -1){
+ tmpname<-paste(tmpname,"]",abs(tmpcharge),"-",sep="")
+ }else{
+ tmpname<-paste(tmpname,"]-",sep="")
+ }
+ name<-append(name,tmpname)
+ charge<-append(charge,tmpcharge)
+ massdiff<-append(massdiff,tmpmass)
+ nmol <-append(nmol,k);
+ oidscore<-append(oidscore,oid+i)
+ if(sum(coeff[i,])==1&& k==1){
+ quasi <-append(quasi,1);
+ }else{
+ quasi <-append(quasi,0);
+ }
+ ips <-append(ips,tmpips);
+ i <- i+1
+ }
+ }
+ oid<-max(oidscore);
+
+ ##Erzeuge Neutral Addition
+ index<-which(quasi==1)
+ for(i in 1:nrow(neutraladdition)){
+ if(length(index2<-which(ionlist[,2]<0))>0){
+ for(ii in 1:length(index2)){
+ if(ionlist[index2[ii],2]< -1){
+ name <- append(name,paste("[M+",ionlist[index2[ii],1],"+",neutraladdition[i,1],"]",abs(ionlist[index2[ii],2]),"-",sep=""));
+ }else{
+ name <- append(name,paste("[M+",ionlist[index2[ii],1],"+",neutraladdition[i,1],"]-",sep=""));
+ }
+ charge <- append(charge,ionlist[index2[ii],2]);
+ massdiff<- append(massdiff,neutraladdition[i,2]+ionlist[index2[ii],3]);
+ nmol <- append(nmol,1);
+ quasi <- append(quasi,0);
+ oidscore<-append(oidscore,oid+1);oid<-oid+1;
+ ips<-append(ips,0.5);
+ }
+ }
+ name<-append(name,paste("[M-H+",neutraladdition[i,1],"]-",sep=""));
+ charge<-append(charge,-1);
+ massdiff<- append(massdiff,neutraladdition[i,2]-1.007276);
+ nmol<-append(nmol,1);
+ quasi<-append(quasi,0)
+ oidscore<-append(oidscore,oid+1);oid<-oid+1;
+ ips<-append(ips,0.5);
+ }
+ oid<-max(oidscore);
+
+ ##Erzeuge Neutral loss
+ index<-which(quasi==1)
+ for(i in 1:nrow(neutralloss)){
+ name<-append(name,paste("[M-H-",neutralloss[i,1],"]-",sep=""));
+ charge<-append(charge,-1);
+ massdiff<- append(massdiff,-neutralloss[i,2]-1.007276);
+ nmol<-append(nmol,1);
+ quasi<-append(quasi,0)
+ oidscore<-append(oidscore,oid+1);oid<-oid+1;
+ ips<-append(ips,0.25);
+ }
+ ruleset <- data.frame(name,nmol,charge,massdiff,oidscore,quasi,ips)
+ if(length(index<-which(ruleset[,"charge"]< -maxcharge))>0){
+ ruleset<- ruleset[-index,];
+ }
+ }else stop("Unknown error")
+
+ ## Update object rules and return ruleset
+ object@rules=ruleset
+ object;
+}
+generateRules2 <- function (object) {
+
+ maxcharge=object@maxcharge
+ mol=object@mol
+ nion=object@nion
+ nnloss=object@nnloss
+ nnadd=object@nnadd
+ nh=object@nh
+ polarity=object@polarity
+
+ ionlist=object@ionlist
+ neutralloss=object@neutralloss
+ neutraladdition=object@neutraladdition
+
+ rules=object@rules
+
+ ##Create Rules
+ ruleset <- matrix(nrow=0, ncol=8);
+ colnames(ruleset) <- c("name", "nmol","charge", "massdiff", "typ","mandatory",
+ "score", "parent")
+
+ tmpname <- c();
+ tmpcharge <- 0;
+ tmpmass <- 0;
+ tmpionparent <- NA;
+ massH <- 1.007276
+
+ ##Positive Rule set
+ if(polarity == "positive"){
+ charge <- "+"
+ chargeValue <- 1
+ }else if(polarity == "negative"){
+ charge <- "-"
+ chargeValue <- -1
+ }else{
+ stop("Unknown polarity mode in rule set generation! Debug!\n")
+ }
+
+ #Hydrogen part is hard coded
+ for(k in 1:mol) {
+ if(k == 1){
+ #For M+H
+ str <- "";
+ tmpips <- 1.5;
+ quasi <- 1
+ }else{
+ #For xM+H
+ str <- k;
+ tmpips <- 0;
+ quasi <- 0
+ }
+
+ for(xh in seq.int(nh)){
+ if(xh == 1){
+ ruleset <- rbind(ruleset, cbind(paste("[", str, "M", charge, "H]", charge, sep=""), k, chargeValue,
+ massH*chargeValue, "A",
+ quasi, tmpips+0.5, tmpionparent));
+ } else {
+ ruleset <- rbind(ruleset, cbind(paste("[", str, "M", charge, xh, "H]", xh, charge, sep=""),
+ k,xh*chargeValue, massH*xh*chargeValue, "A", 0, 0.5, tmpionparent+1));
+ }
+ }
+
+ for(i in 1:nrow(ionlist)){
+ #Add change of kat- respectively anion against one hydrogen
+ if(ionlist[i, 2] > 0 & charge == "-"){
+ if(ionlist[i, 2] == 1){
+ sumcharge <- "";
+ hdiff <- 1;
+ }else{
+ sumcharge <- ionlist[i, 2];
+ hdiff <- ionlist[i,2]-1;
+ }
+ ruleset <- rbind(ruleset, cbind(paste("[", str, "M", charge,"H+", ionlist[i,1], "-", sumcharge,"H]", "",
+ charge, sep=""), k, ionlist[i, 2]*chargeValue,
+ ionlist[i, 3]-massH*(1+hdiff),
+ "A", 0, 0.25, tmpionparent));
+ }
+
+ #xM+H + additional Kation like Na or K
+ if(ionlist[i,2] <= 0 & chargeValue > 0) {
+ #Ions with negative charge, when polarity is positive
+ next;
+ } else if(ionlist[i, 2] >= 0 & chargeValue < 0){
+ #Ions with positive charge, when polarity is negative
+ next;
+ }
+
+ #Add Rule to Ruleset
+ if(abs(ionlist[i, 2]) == 1){
+ ruleset <- rbind(ruleset, cbind(paste("[", str, "M", charge,"H+", ionlist[i,1], "]2",
+ charge, sep=""), k, ionlist[i, 2]+1*chargeValue,
+ ionlist[i, 3]+massH*chargeValue, "A", 0, 0.25, tmpionparent));
+ }else{
+ ruleset <- rbind(ruleset, cbind(paste("[", str, "M", charge,"H+", ionlist[i, 1], "]",
+ ionlist[i, 2]+(1*chargeValue),
+ charge, sep=""), k, ionlist[i, 2]+1*chargeValue,
+ ionlist[i, 3]+massH*chargeValue, "A" ,0, 0.25, tmpionparent));
+ }
+
+ }#End for loop nrow(ionlist)
+
+ ##Coeff - coefficient Matrix, for generating rules with
+ #combination of kat- or anionsexchange ions like [M-2H+Na] (M-H and change of H against Na)
+ coeff <- expand.grid(rep(list(0:nion), nrow(ionlist)))
+ if(chargeValue > 0){
+ index <- which(ionlist[, 2] <= 0);
+ }else{
+ index <- which(ionlist[, 2] >= 0);
+ }
+
+ if(length(index) > 0){
+ coeff[, index] <- 0;
+ }
+
+ tmp <- NULL;
+ for(i in 1:nrow(ionlist)){
+ if((chargeValue > 0 & ionlist[i, 2] <= 0) | (chargeValue < 0 & ionlist[i,2] >=0)){
+ next;
+ }
+ #Austausch erstmal nur einen pro Ion
+ tmp <- rbind(tmp, t(apply(coeff, 1, function(x) {
+ x[i] <- x[i]+1;
+ x[nrow(ionlist)+1] <- -1;
+ x }
+ )));
+ }
+ coeff <- cbind(coeff, rep(0, nrow(coeff)));
+ colnames(coeff)[4] <- "Var4"
+ colnames(tmp)[4] <- "Var4"
+ coeff <- unique(rbind(coeff, tmp));
+
+ for(i in 1:nrow(coeff)){
+ if(sum(coeff[i, 1:nrow(ionlist)]) > 2 | sum(coeff[i, 1:nrow(ionlist)]) < 1){
+ next;
+ }
+
+ tmpname <- paste("[",str,"M",sep="");
+ tmpcharge <- 0;
+ tmpmass <- 0;
+
+ for(ii in 1:(ncol(coeff))){
+ if(coeff[i,ii] > 0){
+ if(coeff[i,ii] > 1){
+ tmpname <- paste(tmpname, "+", coeff[i, ii], ionlist[ii, 1], sep="");
+ }else{
+ tmpname <- paste(tmpname, "+", ionlist[ii, 1], sep="");
+ }
+ tmpcharge <- tmpcharge + coeff[i, ii] * ionlist[ii, 2];
+ tmpmass <- tmpmass + coeff[i, ii] * ionlist[ii, 3];
+ } else if (coeff[i,ii] < 0){
+ tmpname <- paste(tmpname, "-H", sep="");
+ tmpcharge <- tmpcharge - 1;
+ tmpmass <- tmpmass - massH;
+ }
+ }
+
+ if(abs(tmpcharge) > 1){
+ tmpname <- paste(tmpname, "]", tmpcharge, charge, sep="")
+ }else{
+ tmpname <- paste(tmpname, "]", charge, sep="")
+ }
+
+ if(tmpcharge > maxcharge | tmpcharge == 0){
+ next;
+ }
+
+ if(sum(coeff[i, ]) == 1 && k == 1 && coeff[i, 4] >=0){
+ ruleset <- rbind(ruleset, cbind(tmpname, k, tmpcharge, tmpmass, "A", 1, 0.75, tmpionparent));
+ }else{
+ ruleset <- rbind(ruleset, cbind(tmpname, k, tmpcharge, tmpmass, "A", 0, 0.25, tmpionparent));
+ }
+ }#end for loop nrow(coeff)
+ }#end for loop k
+
+ # Create neutral addition to M+H from list
+ for(i in 1:nrow(neutraladdition)){
+ #Add neutral ion to only M+H
+ ruleset <- rbind(ruleset, cbind(paste("[M", charge, "H+", neutraladdition[i, 1], "]", charge, sep="") , 1, chargeValue,
+ neutraladdition[i, 2]+(massH*chargeValue), "A", 0, 0.25, 1));
+ }
+
+ ## Add neutral loss from list to ruleset
+ for(i in 1:nrow(neutralloss)){
+ ruleset <- rbind(ruleset, cbind(paste("-", neutralloss[i, 1], sep=""), 1, 0,
+ -neutralloss[i, 2], "F", 0, 0.25, 1));
+ #Eliminate rules with charge > maxcharge
+ if(length(index <- which(ruleset[, "charge"] > maxcharge)) > 0){
+ ruleset <- ruleset[-index, ];
+ }
+ }
+ ruleset <- as.data.frame(ruleset, stringsAsFactors=FALSE)
+ class(ruleset$nmol) <- "numeric"
+ class(ruleset$charge) <- "numeric"
+ class(ruleset$massdiff) <- "numeric"
+ class(ruleset$mandatory) <- "numeric"
+ class(ruleset$score) <- "numeric"
+ class(ruleset$parent) <- "numeric"
+ object@rules=ruleset
+ object;
+
+ return(object);
+}
+setDefaultLists <- function(object, lib.loc=.libPaths()) {
+
+ ##Read Tabellen
+ object@ionlistfile <- system.file('lists/ions.csv', package = "MetaboAnalystR",
+ lib.loc=lib.loc)[1]
+ if (!file.exists(object@ionlistfile)) stop('ions.csv not found.')
+
+ object@neutrallossfile <- system.file('lists/neutralloss.csv',
+ package = "MetaboAnalystR", lib.loc=lib.loc)[1]
+ if (!file.exists(object@neutrallossfile)) stop('neutralloss.csv not found.')
+
+ object@neutraladditionfile <- system.file('lists/neutraladdition.csv',
+ package = "MetaboAnalystR", lib.loc=lib.loc)[1]
+ if (!file.exists(object@neutraladditionfile)) stop('neutraladdition.csv not found.')
+ object
+}
+readLists <- function(object) {
+
+ object@ionlist <- read.table(object@ionlistfile, header=TRUE, dec=".", sep=",",
+ as.is=TRUE, stringsAsFactors = FALSE);
+
+ object@neutralloss <- read.table(object@neutrallossfile, header=TRUE, dec=".", sep=",",
+ as.is=TRUE, stringsAsFactors = FALSE);
+
+ object@neutraladdition <- read.table(object@neutraladditionfile,
+ header=TRUE, dec=".", sep=",",
+ as.is=TRUE, stringsAsFactors = FALSE);
+ object
+}
+setParams <- function (object, maxcharge=3, mol=3, nion=2, nnloss=1, nnadd=1, nh=2,
+ polarity=NULL, lib.loc=NULL) {
+ object@maxcharge=maxcharge
+ object@mol=mol
+ object@nion=nion
+ object@nnloss=nnloss
+ object@nnadd=nnadd
+ object@nh=nh
+ object@polarity=polarity
+ object@lib.loc=lib.loc
+ object
+}
+annotateGrp <- function(ipeak, imz, rules, mzabs, devppm, isotopes, quasimolion, rules.idx) {
+ #m/z vector for group i with peakindex ipeak
+ mz <- imz[ipeak];
+ naIdx <- which(!is.na(mz))
+
+ #Spectrum have only annotated isotope peaks, without monoisotopic peak
+ #Give error or warning?
+ if(length(na.omit(mz[naIdx])) < 1){
+ return(NULL);
+ }
+
+ ML <- massDiffMatrix(mz[naIdx], rules[rules.idx,]);
+
+ hypothese <- createHypothese(ML, rules[rules.idx, ], devppm, mzabs, naIdx);
+
+ #create hypotheses
+ if(is.null(nrow(hypothese)) || nrow(hypothese) < 2 ){
+ return(NULL);
+ }
+
+ #remove hypotheses, which violates via isotope annotation discovered ion charge
+ if(length(isotopes) > 0){
+ hypothese <- checkIsotopes(hypothese, isotopes, ipeak);
+ }
+
+ if(nrow(hypothese) < 2){
+ return(NULL);
+ }
+
+ #Test if hypothese grps include mandatory ions
+ #Filter Rules #2
+ if(length(quasimolion) > 0){
+ hypothese <- checkQuasimolion(hypothese, quasimolion);
+ }
+
+ if(nrow(hypothese) < 2){
+ return(NULL);
+ };
+
+ #Entferne Hypothesen, welche gegen OID-Score&Kausalität verstossen!
+ hypothese <- checkOidCausality(hypothese, rules[rules.idx, ]);
+ if(nrow(hypothese) < 2){
+ return(NULL);
+ };
+
+ #Prüfe IPS-Score
+ hypothese <- checkIps(hypothese)
+ if(nrow(hypothese) < 2){
+ return(NULL)
+ }
+
+ #We have hypotheses and want to add neutral losses
+ if("typ" %in% colnames(rules)){
+ hypothese <- addFragments(hypothese, rules, mz)
+
+ hypothese <- resolveFragmentConnections(hypothese)
+ }
+ return(hypothese);
+}
+massDiffMatrix <- function(m, rules){
+ #m - m/z vector
+ #rules - annotation rules
+ nRules <- nrow(rules);
+ DM <- matrix(NA, length(m), nRules)
+
+ for (i in seq_along(m)){
+ for (j in seq_len(nRules)){
+ DM[i, j] <- (abs(rules[j, "charge"] * m[i]) - rules[j, "massdiff"]) / rules[j, "nmol"] # ((z*m) - add) /n
+ }
+ }
+ return(DM)
+}
+createHypothese <- function(ML, rules, devppm, mzabs, naIdx){
+ ML.nrow <- nrow(ML);
+ ML.vec <- as.vector(ML);
+ max.value <- max(round(ML, 0));
+ hashmap <- vector(mode="list", length=max.value);
+ for(i in 1:length(ML)){
+ val <- trunc(ML[i],0);
+ if(val>1){
+ hashmap[[val]] <- c(hashmap[[val]],i);
+ }
+ }
+ if("ips" %in% colnames(rules)){
+ score <- "ips"
+ }else{
+ score <- "score"
+ }
+ hypothese <- matrix(NA,ncol=8,nrow=0);
+ colnames(hypothese) <- c("massID", "ruleID", "nmol", "charge", "mass", "score", "massgrp", "check");
+ massgrp <- 1;
+
+ for(i in seq(along=hashmap)){
+ if(is.null(hashmap[[i]])){
+ next;
+ }
+
+ candidates <- ML.vec[hashmap[[i]]];
+ candidates.index <- hashmap[[i]];
+ if(i != 1 && !is.null(hashmap[[i-1]]) && min(candidates) < i+(2*devppm*i+mzabs)){
+ index <- which(ML.vec[hashmap[[i-1]]]> i-(2*devppm*i+mzabs))
+ if(length(index)>0) {
+ candidates <- c(candidates, ML.vec[hashmap[[i-1]]][index]);
+ candidates.index <- c(candidates.index,hashmap[[i-1]][index]);
+ }
+ }
+
+ if(length(candidates) < 2){
+ next;
+ }
+
+ tol <- max(2*devppm*mean(candidates, na.rm=TRUE))+ mzabs;
+ result <- cutree(hclust(dist(candidates)), h=tol);
+ index <- which(table(result) >= 2);
+ if(length(index) == 0){
+ next;
+ }
+ m <- lapply(index, function(x) which(result == x));
+ for(ii in 1:length(m)){
+ ini.adducts <- candidates.index[m[[ii]]];
+ for( iii in 1:length(ini.adducts)){
+ adduct <- ini.adducts[iii] %/% ML.nrow +1;
+ mass <- ini.adducts[iii] %% ML.nrow;
+ if(mass == 0){
+ mass <- ML.nrow;
+ adduct <- adduct -1;
+ }
+ hypothese <- rbind(hypothese, c(naIdx[mass], adduct, rules[adduct, "nmol"], rules[adduct, "charge"], mean(candidates[m[[ii]]]), rules[adduct,score],massgrp ,1));
+ }
+ if(length(unique(hypothese[which(hypothese[, "massgrp"] == massgrp), "massID"])) == 1){
+ ##only one mass annotated
+ hypothese <- hypothese[-(which(hypothese[,"massgrp"]==massgrp)),,drop=FALSE]
+ }else{
+ massgrp <- massgrp +1;
+ }
+ }
+ }
+ return(hypothese);
+}
+checkIsotopes <- function(hypothese, isotopes, ipeak){
+ for(hyp in 1:nrow(hypothese)){
+ peakid <- ipeak[hypothese[hyp, 1]];
+ if(!is.null(isotopes[[peakid]])){
+ #Isotope da
+ explainable <- FALSE;
+ if(isotopes[[peakid]]$charge == abs(hypothese[hyp, "charge"])){
+ explainable <- TRUE;
+ }
+ if(!explainable){
+ #delete Rule
+ hypothese[hyp,"check"]=0;
+ }
+ }
+ }
+ hypothese <- hypothese[which(hypothese[, "check"]==TRUE), ,drop=FALSE];
+ #check if hypothese grps annotate at least two different peaks
+ hypothese <- checkHypothese(hypothese)
+
+ return(hypothese)
+}
+checkHypothese <- function(hypothese){
+ if(is.null(nrow(hypothese))){
+ hypothese <- matrix(hypothese, byrow=F, ncol=8)
+ }
+ colnames(hypothese) <- c("massID", "ruleID", "nmol", "charge", "mass", "score", "massgrp", "check")
+ for(i in unique(hypothese[,"massgrp"])){
+ if(length(unique(hypothese[which(hypothese[, "massgrp"] == i), "massID"])) == 1){
+ ##only one mass annotated
+ hypothese <- hypothese[-(which(hypothese[,"massgrp"]==i)), , drop=FALSE]
+ }
+ }
+ return(hypothese)
+}
+
+checkIps <- function(hypothese){
+ for(hyp in 1:nrow(hypothese)){
+ if(length(which(hypothese[, "massgrp"] == hypothese[hyp, "massgrp"])) < 2){
+ hypothese[hyp, "check"] = 0;
+ }
+ }
+ hypothese <- hypothese[which(hypothese[, "check"]==TRUE), ];
+ if(is.null(nrow(hypothese))) {
+ hypothese <- matrix(hypothese, byrow=F, ncol=9)
+ }
+ if(nrow(hypothese) < 1){
+ colnames(hypothese)<-c("massID", "ruleID", "nmol", "charge", "mass", "oidscore", "ips","massgrp", "check")
+ return(hypothese)
+ }
+ for(hyp in 1:nrow(hypothese)){
+ if(length(id <- which(hypothese[, "massID"] == hypothese[hyp, "massID"] & hypothese[, "check"] != 0)) > 1){
+ masses <- hypothese[id, "mass"]
+ nmasses <- sapply(masses, function(x) {
+ sum(hypothese[which(hypothese[, "mass"] == x), "score"])
+ })
+ masses <- masses[-which(nmasses == max(nmasses))];
+ if(length(masses) > 0){
+ hypothese[unlist(sapply(masses, function(x) {which(hypothese[, "mass"]==x)})), "check"]=0;
+ }
+ }
+ }
+
+ hypothese <- hypothese[which(hypothese[, "check"]==TRUE), ,drop=FALSE];
+ #check if hypothese grps annotate at least two different peaks
+ hypothese <- checkHypothese(hypothese)
+ return(hypothese)
+}
+checkOidCausality <- function(hypothese,rules){
+ #check every hypothese grp
+ for(hyp in unique(hypothese[,"massgrp"])){
+ hyp.nmol <- which(hypothese[, "massgrp"] == hyp & hypothese[, "nmol"] > 1)
+
+ for(hyp.nmol.idx in hyp.nmol){
+ if(length(indi <- which(hypothese[, "mass"] == hypothese[hyp.nmol.idx, "mass"] &
+ abs(hypothese[, "charge"]) == hypothese[, "nmol"])) > 1){
+ if(hyp.nmol.idx %in% indi){
+ #check if [M+H] [2M+2H]... annotate the same molecule
+ massdiff <- rules[hypothese[indi, "ruleID"], "massdiff"] /
+ rules[hypothese[indi, "ruleID"], "charge"]
+ if(length(indi_new <- which(duplicated(massdiff))) > 0){
+ hypothese[hyp.nmol.idx, "check"] <- 0;
+ }
+ }
+ }
+ }
+ }
+
+ hypothese <- hypothese[which(hypothese[, "check"] == TRUE), ,drop=FALSE];
+ #check if hypothese grps annotate at least two different peaks
+ hypothese <- checkHypothese(hypothese)
+ return(hypothese)
+}
+checkQuasimolion <- function(hypothese, quasimolion){
+ hypomass <- unique(hypothese[, "mass"])
+ for(mass in 1:length(hypomass)){
+ if(!any(quasimolion %in% hypothese[which(hypothese[, "mass"] == hypomass[mass]), "ruleID"])){
+ hypothese[which(hypothese[, "mass"] == hypomass[mass]), "check"] = 0;
+ }else if(is.null(nrow(hypothese[which(hypothese[, "mass"] == hypomass[mass]), ]))){
+ hypothese[which(hypothese[, "mass"] == hypomass[mass]), "check"] = 0;
+ }
+ }
+
+ hypothese <- hypothese[which(hypothese[, "check"]==TRUE), , drop=FALSE];
+ #check if hypothese grps annotate at least two different peaks
+ hypothese <- checkHypothese(hypothese)
+
+ return(hypothese)
+}
+
+getderivativeIons <- function(annoID, annoGrp, rules, npeaks){
+ #generate Vector length npeaks
+ derivativeIons <- vector("list", npeaks);
+ #intrinsic charge
+ #TODO: Not working at the moment
+ charge <- 0;
+
+ #check if we have annotations
+ if(nrow(annoID) < 1){
+ return(derivativeIons);
+ }
+
+ for(i in 1:nrow(annoID)){
+
+ peakid <- annoID[i, 1];
+ grpid <- annoID[i, 2];
+ ruleid <- annoID[i, 3];
+
+ if(is.null(derivativeIons[[peakid]])){
+ #Peak has no annotations so far
+ if(charge == 0 | rules[ruleid, "charge"] == charge){
+ derivativeIons[[peakid]][[1]] <- list( rule_id = ruleid,
+ charge = rules[ruleid, "charge"],
+ nmol = rules[ruleid, "nmol"],
+ name = paste(rules[ruleid, "name"]),
+ mass = annoGrp[grpid, 2])
+ }
+ } else {
+ #Peak has already an annotation
+ if(charge == 0 | rules[ruleid, "charge"] == charge){
+ derivativeIons[[peakid]][[(length(
+ derivativeIons[[peakid]])+1)]] <- list( rule_id = ruleid,
+ charge = rules[ruleid, "charge"],
+ nmol = rules[ruleid, "nmol"],
+ name=paste(rules[ruleid, "name"]),
+ mass=annoGrp[grpid, 2])
+ }
+ }
+
+ charge <- 0;
+ }
+ return(derivativeIons);
+}
+getIsotopeCluster <- function(object, number=NULL, value="maxo",
+ sampleIndex=NULL){
+
+ #check values
+ if(is.null(object)) {
+ stop("No xsa argument was given.\n");
+ }else if(!class(object)=="xsAnnotate"){
+ stop("Object parameter is no xsAnnotate object.\n");
+ }
+
+ value <- match.arg(value, c("maxo", "into", "intb"), several.ok=FALSE)
+
+ if(!is.null(number) & !is.numeric(number)){
+ stop("Number must be NULL or numeric");
+ }
+
+ if(!is.null(sampleIndex) & !all(is.numeric(sampleIndex))){
+ stop("Parameter sampleIndex must be NULL or numeric");
+ }
+
+ if(is.null(sampleIndex)){
+ nSamples <- 1;
+ } else if( all(sampleIndex <= length(object@xcmsSet@filepaths) & sampleIndex > 0)){
+ nSamples <- length(sampleIndex);
+ } else {
+ stop("All values in parameter sampleIndex must be lower equal
+ the number of samples and greater than 0.\n")
+ }
+
+ if(length(sampnames(object@xcmsSet)) > 1){ ## more than one sample
+ gvals <- groupval(object@xcmsSet, value=value);
+ groupmat <- object@groupInfo;
+ iso.matrix <- matrix(0, ncol=nSamples, nrow=length(object@isotopes));
+ if(is.null(sampleIndex)){
+ for(i in 1:length(object@pspectra)){
+ iso.matrix[object@pspectra[[i]],1] <- gvals[object@pspectra[[i]],object@psSamples[i]];
+ }
+ } else {
+ for(i in 1:length(object@pspectra)){
+ iso.matrix[object@pspectra[[i]], ] <- gvals[object@pspectra[[i]], sampleIndex]
+ }
+ }
+ peakmat <- cbind(groupmat[, "mz"], iso.matrix );
+ rownames(peakmat) <- NULL;
+ if(is.null(sampleIndex)){
+ colnames(peakmat) <- c("mz",value);
+ }else{
+ colnames(peakmat) <- c("mz", sampnames(object@xcmsSet)[sampleIndex]);
+ }
+
+ if(any(is.na(peakmat))){
+ print("Warning: peak table contains NA values. To remove apply fillpeaks on xcmsSet.");
+ }
+
+ } else if(length(sampnames(object@xcmsSet)) == 1){ ## only one sample was
+ peakmat <- object@groupInfo[, c("mz", value)];
+ } else {
+ stop("sampnames could not extracted from the xcmsSet.\n");
+ }
+
+ #collect isotopes
+
+ index <- which(!sapply(object@isotopes, is.null));
+
+ tmp.Matrix <- cbind(index, matrix(unlist(object@isotopes[index]), ncol=4, byrow=TRUE))
+ colnames(tmp.Matrix) <- c("Index","IsoCluster","Type","Charge","Val")
+
+ max.cluster <- max(tmp.Matrix[,"IsoCluster"])
+ max.type <- max(tmp.Matrix[,"Type"])
+
+ isotope.Matrix <- matrix(NA, nrow=max.cluster, ncol=(max.type+2));
+ invisible(apply(tmp.Matrix,1, function(x) {
+ isotope.Matrix[x["IsoCluster"],x["Type"]+2] <<- x["Index"];
+ isotope.Matrix[x["IsoCluster"],1] <<- x["Charge"];
+ }))
+
+ invisible(apply(isotope.Matrix,1, function(x) {
+ list(peaks=peakmat[na.omit(x[-1]),],charge=x[1])
+ }))
+}
+
+naOmit <- function(x) {
+ return (x[!is.na(x)]);
+}
+####### ------------ ======== Bottom of this kit ========= ------------ ######\
+
+# --------------------------------------5.MSread--------------------------
+read.MSdata <- function(files, pdata = NULL, msLevel. = NULL, centroided. = NA,
+ smoothed. = NA, cache. = 1L,
+ mode = c("inMemory", "onDisk")) {
+ mode <- match.arg(mode)
+ ## o normalize the file path, i.e. replace relative path with absolute
+ ## path. That fixes possible problems on Windows with SNOW parallel
+ ## processing and also proteowizard problems on unis system with ~ paths.
+ files <- normalizePath(files)
+ suppressWarnings(.hasChroms <- MSnbase::hasChromatograms(files))
+
+ if (!length(files)) {
+ process <- new("MSnProcess",
+ processing = paste("No data loaded:", date()))
+ if (mode == "inMemory")
+ res <- new("MSnExp",
+ processingData = process)
+ else res <- new("OnDiskMSnExp",
+ processingData = process)
+ } else {
+ if (mode == "inMemory") {
+ if (is.null(msLevel.)) msLevel. <- 2L
+ res <- read.InMemMSd.data(files, pdata = pdata, msLevel. = msLevel.,
+ centroided. = centroided., smoothed. = smoothed., cache. = cache.)
+ } else { ## onDisk
+ res <- read.OnDiskMS.data(files = files, pdata = pdata,
+ msLevel. = msLevel., centroided. = centroided., smoothed. = smoothed.)
+ }
+ }
+ res
+}
+
+read.InMemMSd.data <- function(files, pdata, msLevel., centroided., smoothed., cache. = 1) {
+ MSnbase:::.testReadMSDataInput(environment())
+ if (msLevel. == 1) cache. <- 0
+ msLevel. <- as.integer(msLevel.)
+ ## Creating environment with Spectra objects
+ assaydata <- new.env(parent = emptyenv())
+ ioncount <- c()
+ ioncounter <- 1
+ filenams <- filenums <- c()
+ fullhd2 <- fullhdorder <- c()
+ fullhdordercounter <- 1
+ .instrumentInfo <- list()
+ ## List eventual limitations
+ #if (MSnbase:::isCdfFile(files)) {
+ # message("Polarity can not be extracted from netCDF files, please set ",
+ # "manually the polarity with the 'polarity' method.")
+ #}
+ ## ## Idea:
+ ## ## o initialize a featureData-data.frame,
+ ## ## o for each file, extract header info and put that into
+ ## featureData;
+
+ for (f in files) {
+ print(paste("Reading MS from",basename(f),"begin !"))
+
+ filen <- match(f, files)
+ filenums <- c(filenums, filen)
+ filenams <- c(filenams, f)
+ ## issue #214: define backend based on file format.
+ msdata <- mzR::openMSfile(f,backend = NULL)
+ .instrumentInfo <- c(.instrumentInfo, list(mzR::instrumentInfo(msdata)))
+ fullhd <- mzR::header(msdata)
+ ## Issue #325: get centroided information from file, but overwrite if
+ ## specified with centroided. parameter.
+ if (!is.na(centroided.))
+ fullhd$centroided <- as.logical(centroided.)
+ spidx <- which(fullhd$msLevel == msLevel.)
+ ## increase vectors as needed
+ ioncount <- c(ioncount, numeric(length(spidx)))
+ fullhdorder <- c(fullhdorder, numeric(length(spidx)))
+ if (msLevel. == 1) {
+ if (length(spidx) == 0)
+ stop("No MS1 spectra in file",f)
+
+ pb <- progress_bar$new(format = "Reading [:bar] :percent Time left: :eta",
+ total = length(spidx), clear = T, width= 75)
+
+ for (i in 1:length(spidx)) {
+
+ pb$tick();
+
+ j <- spidx[i]
+ hd <- fullhd[j, ]
+ ## Fix missing polarity from netCDF
+ pol <- hd$polarity
+ if (length(pol) == 0)
+ pol <- NA
+ .p <- mzR::peaks(msdata, j)
+ sp <- new("Spectrum1",
+ rt = hd$retentionTime,
+ acquisitionNum = as.integer(hd$acquisitionNum),
+ scanIndex = as.integer(hd$seqNum),
+ tic = hd$totIonCurrent,
+ mz = .p[, 1],
+ intensity = .p[, 2],
+ fromFile = as.integer(filen),
+ centroided = as.logical(hd$centroided),
+ smoothed = as.logical(smoothed.),
+ polarity = as.integer(pol))
+ ## peaksCount
+ ioncount[ioncounter] <- sum(.p[, 2])
+ ioncounter <- ioncounter + 1
+ .fname <-MSnbase:::formatFileSpectrumNames(fileIds=filen,
+ spectrumIds=i,
+ nSpectra=length(spidx),
+ nFiles=length(files))
+ assign(.fname, sp, assaydata)
+ fullhdorder[fullhdordercounter] <- .fname
+ fullhdordercounter <- fullhdordercounter + 1
+ }
+ } else { ## .msLevel != 1
+ if (length(spidx) == 0)
+ stop("No MS(n>1) spectra in file", f)
+ print(paste("Reading ", length(spidx), " MS", msLevel.,
+ " spectra from file ", basename(f)))
+
+ scanNums <- fullhd[fullhd$msLevel == msLevel., "precursorScanNum"]
+ if (length(scanNums) != length(spidx))
+ stop("Number of spectra and precursor scan number do not match!")
+
+ pb <- progress_bar$new(format = "Reading [:bar] :percent Time left: :eta",
+ total = length(spidx), clear = T, width= 75)
+
+ for (i in 1:length(spidx)) {
+
+ pb$tick();
+
+ j <- spidx[i]
+ hd <- fullhd[j, ]
+ .p <- mzR::peaks(msdata, j)
+ sp <- new("Spectrum2",
+ msLevel = as.integer(hd$msLevel),
+ merged = as.numeric(hd$mergedScan),
+ precScanNum = as.integer(scanNums[i]),
+ precursorMz = hd$precursorMZ,
+ precursorIntensity = hd$precursorIntensity,
+ precursorCharge = as.integer(hd$precursorCharge),
+ collisionEnergy = hd$collisionEnergy,
+ rt = hd$retentionTime,
+ acquisitionNum = as.integer(hd$acquisitionNum),
+ scanIndex = as.integer(hd$seqNum),
+ tic = hd$totIonCurrent,
+ mz = .p[, 1],
+ intensity = .p[, 2],
+ fromFile = as.integer(filen),
+ centroided = as.logical(hd$centroided),
+ smoothed = as.logical(smoothed.),
+ polarity = as.integer(hd$polarity))
+ ## peaksCount
+ ioncount[ioncounter] <- sum(.p[, 2])
+ ioncounter <- ioncounter + 1
+ .fname <- MSnbase:::formatFileSpectrumNames(fileIds=filen,
+ spectrumIds=i,
+ nSpectra=length(spidx),
+ nFiles=length(files))
+ assign(.fname, sp, assaydata)
+ fullhdorder[fullhdordercounter] <- .fname
+ fullhdordercounter <- fullhdordercounter + 1
+ }
+ }
+ if (cache. >= 1)
+ fullhd2 <- rbind(fullhd2, fullhd[spidx, ])
+
+ gc()
+ mzR::close(msdata)
+ rm(msdata);
+
+
+ print(paste("This reading finished !"))
+
+ }
+
+ ## cache level 2 yet implemented
+ cache. <- MSnbase:::testCacheArg(cache., maxCache = 2)
+ if (cache. >= 1) {
+ fl <- sapply(assaydata, function(x) x@fromFile)
+ featnms <- ls(assaydata) ## feature names in final MSnExp
+ fl <- fl[featnms] ## reorder file numbers
+ stopifnot(all(base::sort(featnms) == base::sort(fullhdorder)))
+ fullhdorder <- match(featnms, fullhdorder)
+ tmphd <- fullhd2[fullhdorder, ] ## reorder
+ ioncount <- ioncount[fullhdorder]
+ newhd <- data.frame(fileIdx = fl,
+ retention.time = tmphd$retentionTime,
+ precursor.mz = tmphd$precursorMZ,
+ precursor.intensity = tmphd$precursorIntensity,
+ charge = tmphd$precursorCharge,
+ peaks.count = tmphd$peaksCount,
+ tic = tmphd$totIonCurrent,
+ ionCount = ioncount,
+ ms.level = tmphd$msLevel,
+ acquisition.number = tmphd$acquisitionNum,
+ collision.energy = tmphd$collisionEnergy)
+ } else {
+ newhd <- NULL ## not used anyway
+ }
+ .cacheEnv <- MSnbase:::setCacheEnv(list("assaydata" = assaydata,
+ "hd" = newhd),
+ cache., lock = TRUE)
+ ## CACHING AS BEEN SUPERSEDED BY THE OnDiskMSnExp IMPLEMENTATION
+ ## if cache==2, do not lock assign msdata in .cacheEnv then lock
+ ## it and do not close(msdata) above; rm(msdata) is OK
+
+ ## Create 'MSnProcess' object
+ process <- new("MSnProcess",
+ processing = paste("Data loaded:", date()),
+ files = files,
+ smoothed = smoothed.)
+ ## Create 'fdata' and 'pdata' objects
+ nms <- ls(assaydata)
+ if (is.null(pdata)) {
+ .pd <- data.frame(sampleNames = basename(files))
+ rownames(.pd) <- .pd$sampleNames
+ pdata <- new("AnnotatedDataFrame",
+ data = .pd)
+ }
+ fdata <- new("AnnotatedDataFrame",
+ data = data.frame(
+ spectrum = 1:length(nms),
+ row.names = nms))
+ fdata <- fdata[ls(assaydata)] ## reorder features
+ ## expriment data slot
+ if (length(.instrumentInfo) > 1) {
+ cmp <- length(unique(sapply(.instrumentInfo, "[[", 1)))
+ if (cmp > 1)
+ message("According to the instrument information in the files,\n",
+ "the data has been acquired on different instruments!")
+ for (nm in names(.instrumentInfo[[1]]))
+ .instrumentInfo[[1]][[nm]] <- sapply(.instrumentInfo, "[[", nm)
+ }
+ expdata <- new("MIAPE",
+ instrumentManufacturer = .instrumentInfo[[1]]$manufacturer,
+ instrumentModel = .instrumentInfo[[1]]$model,
+ ionSource = .instrumentInfo[[1]]$ionisation,
+ analyser = as.character(.instrumentInfo[[1]]$analyzer),
+ detectorType = .instrumentInfo[[1]]$detector)
+ ## Create and return 'MSnExp' object
+
+ toReturn <- new("MSnExp",
+ assayData = assaydata,
+ phenoData = pdata,
+ featureData = fdata,
+ processingData = process,
+ experimentData = expdata,
+ .cache = .cacheEnv)
+ return(toReturn)
+}
+read.OnDiskMS.data <- function(files, pdata, msLevel., centroided., smoothed.) {
+ MSnbase:::.testReadMSDataInput(environment())
+ stopifnot(is.logical(centroided.))
+
+ ## Creating environment with Spectra objects
+ assaydata <- new.env(parent = emptyenv())
+ filenams <- filenums <- c()
+ fullhd2 <- fullhdorder <- c()
+ fullhdordercounter <- 1
+ .instrumentInfo <- list()
+ ## List eventual limitations
+ if (MSnbase:::isCdfFile(files)) {
+ message("Polarity can not be extracted from netCDF files, please set ",
+ "manually the polarity with the 'polarity' method.")
+ }
+ ## Idea:
+ ## o initialize a featureData-data.frame,
+ featureDataList <- list()
+ ## o for each file, extract header info and put that into featureData
+ pb <- progress_bar$new(format = "Reading [:bar] :percent Time left: :eta",
+ total = length(spidx), clear = T, width= 75)
+
+ for (f in files) {
+
+ pb$tick();
+
+ filen <- match(f, files)
+ filenums <- c(filenums, filen)
+ filenams <- c(filenams, f)
+ ## issue #214: define backend based on file format.
+ msdata <- mzR::openMSfile(f,backend = NULL)
+ .instrumentInfo <- c(.instrumentInfo, list(mzR::instrumentInfo(msdata)))
+ fullhd <- mzR::header(msdata)
+ spidx <- seq_len(nrow(fullhd))
+
+ ## Don't read the individual spectra, just define the names of
+ ## the spectra.
+ fullhdorder <- c(fullhdorder,
+ MSnbase:::formatFileSpectrumNames(fileIds=filen,
+ spectrumIds=seq_along(spidx),
+ nSpectra=length(spidx),
+ nFiles=length(files)))
+ ## Extract all Spectrum info from the header and put it into the featureData
+ fdData <- fullhd[spidx, , drop = FALSE]
+ ## rename totIonCurrent and peaksCount, as detailed in
+ ## https://github.com/lgatto/MSnbase/issues/105#issuecomment-229503816
+ names(fdData) <- sub("peaksCount", "originalPeaksCount", names(fdData))
+ ## Add also:
+ ## o fileIdx -> links to fileNames property
+ ## o spIdx -> the index of the spectrum in the file.
+ fdData <- cbind(fileIdx = rep(filen, nrow(fdData)),
+ spIdx = spidx,
+ smoothed = rep(as.logical(smoothed.), nrow(fdData)),
+ fdData, stringsAsFactors = FALSE)
+ if (MSnbase:::isCdfFile(f)) {
+ ## Add the polarity columns if missing in netCDF
+ if (!any(colnames(fdData) == "polarity"))
+ fdData <- cbind(fdData, polarity = rep(as.integer(NA),
+ nrow(fdData)))
+ }
+ ## Order the fdData by acquisitionNum to force use of acquisitionNum
+
+ ## as unique ID for the spectrum (issue #103). That way we can use
+ ## the spIdx (is the index of the spectrum within the file) for
+ ## subsetting and extracting.
+ if (!all(sort(fdData$acquisitionNum) == fdData$acquisitionNum))
+ warning(paste("Unexpected acquisition number order detected.",
+ "Please contact the maintainers or open an issue",
+ "on https://github.com/lgatto/MSnbase.",
+ sep = "\n")) ## see issue #160
+ fdData <- fdData[order(fdData$acquisitionNum), ]
+ featureDataList <- c(featureDataList, list(fdData))
+ ## Fix for #151; would be nice if we could remove that at some point.
+ gc()
+ mzR::close(msdata)
+ rm(msdata)
+ }
+ ## new in version 1.9.8
+ lockEnvironment(assaydata, bindings = TRUE)
+ .cacheEnv <- setCacheEnv(list("assaydata" = assaydata,
+ "hd" = NULL),
+ level = 0,
+ lock = TRUE)
+
+ ## Create 'MSnProcess' object
+ process <- new("MSnProcess",
+ processing = paste0("Data loaded [", date(), "]"),
+ files = files,
+ smoothed = NA)
+ ## Create 'fdata' and 'pdata' objects
+ if (is.null(pdata)) {
+ .pd <- data.frame(sampleNames = basename(files))
+ rownames(.pd) <- .pd$sampleNames
+ pdata <- new("AnnotatedDataFrame",
+ data = .pd)
+ }
+ ## If we've got a featureDataList, use it
+ if (length(featureDataList) > 0) {
+ fdata <- do.call(rbind, featureDataList)
+ fdata <- cbind(fdata, spectrum = 1:nrow(fdata),
+ stringsAsFactors = FALSE)
+ ## Setting rownames on the data.frame not on the AnnotatedDataFrame;
+ ## did get strange errors otherwise.
+ rownames(fdata) <- fullhdorder
+ ## Re-order them
+ fdata <- fdata[base::sort(fullhdorder), ]
+ fdata <- new("AnnotatedDataFrame", data = fdata)
+ ## Re-order the features.
+ ## fdata <- fdata[ls(assaydata), ]
+ } else fdata <- new("AnnotatedDataFrame")
+
+ ## expriment data slot
+ if (length(.instrumentInfo) > 1) {
+ cmp <- length(unique(sapply(.instrumentInfo, "[[", 1)))
+ if (cmp > 1)
+ message("According to the instrument information in the files,\n",
+ "the data has been acquired on different instruments!")
+ for (nm in names(.instrumentInfo[[1]]))
+ .instrumentInfo[[1]][[nm]] <- sapply(.instrumentInfo, "[[", nm)
+ }
+ expdata <- new("MIAPE",
+ instrumentManufacturer = .instrumentInfo[[1]]$manufacturer,
+ instrumentModel = .instrumentInfo[[1]]$model,
+ ionSource = .instrumentInfo[[1]]$ionisation,
+ analyser = as.character(.instrumentInfo[[1]]$analyzer),
+ detectorType = .instrumentInfo[[1]]$detector)
+ ## Create ProcessingStep if needed.
+ ## Create the OnDiskMSnExp object.
+ res <- new("OnDiskMSnExp",
+ assayData = assaydata,
+ phenoData = pdata,
+ featureData = fdata,
+ processingData = process,
+ experimentData = expdata,
+ .cache = .cacheEnv)
+ if (!is.null(msLevel.)) {
+ msLevel. <- as.integer(msLevel.)
+ res <- filterMsLevel(res, msLevel.)
+ }
+ if (any(!is.na(centroided.))) {
+ if (length(centroided.) == 1) {
+ centroided(res) <- centroided.
+ } else {
+ for (i in seq_along(centroided.))
+ centroided(res, msLevel. = i) <- centroided.[i]
+ }
+ }
+ return(res)
+}
+
+
+
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sqlite/hsa_genes.sqlite b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sqlite/hsa_genes.sqlite
new file mode 100644
index 0000000000000000000000000000000000000000..15b2f6ca3c09c343b6ae77eacf266c4ab015a8e2
Binary files /dev/null and b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sqlite/hsa_genes.sqlite differ
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sqlite/mmu_genes.sqlite b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sqlite/mmu_genes.sqlite
new file mode 100644
index 0000000000000000000000000000000000000000..c2c3a1c305d5506ee4680610f0f00214181b41a7
Binary files /dev/null and b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sqlite/mmu_genes.sqlite differ
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/stats_chemometrics.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/stats_chemometrics.R
new file mode 100755
index 0000000000000000000000000000000000000000..e5a6a623669919714e7d12647b7f0ebafa09ded5
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/stats_chemometrics.R
@@ -0,0 +1,2489 @@
+#'Perform PCA analysis
+#'@description Perform PCA analysis, obtain variance explained, store item to PCA object
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'@param mSetObj Input name of the created mSet Object
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PCA.Anal <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ pca <- prcomp(mSetObj$dataSet$norm, center=TRUE, scale=F);
+
+ # obtain variance explained
+ sum.pca <- summary(pca);
+ imp.pca <- sum.pca$importance;
+ std.pca <- imp.pca[1,]; # standard devietation
+ var.pca <- imp.pca[2,]; # variance explained by each PC
+ cum.pca <- imp.pca[3,]; # cummulated variance explained
+
+ # store the item to the pca object
+ mSetObj$analSet$pca<-append(pca, list(std=std.pca, variance=var.pca, cum.var=cum.pca));
+ fast.write.csv(signif(mSetObj$analSet$pca$x,5), file="pca_score.csv");
+ fast.write.csv(signif(mSetObj$analSet$pca$rotation,5), file="pca_loadings.csv");
+ mSetObj$analSet$pca$loading.type <- "all";
+ mSetObj$custom.cmpds <- c();
+ return(.set.mSet(mSetObj));
+}
+
+#'Rotate PCA analysis
+#'@description Rotate PCA analysis
+#'@param mSetObj Input name of the created mSet Object
+#'@param axisOpt Input the axis option
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+PCA.Flip <- function(mSetObj=NA, axisOpt){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ pca<-mSetObj$analSet$pca;
+ # store the item to the pca object
+ if(axisOpt == "x"){
+ pca$x[,1] <- -pca$x[,1];
+ pca$rotation[,1] <- -pca$rotation[,1];
+ }else if(axisOpt == "y"){
+ pca$x[,2] <- -pca$x[,2];
+ pca$rotation[,2] <- -pca$rotation[,2];
+ }else{ # all
+ pca$x <- -pca$x;
+ pca$rotation <- -pca$rotation;
+ }
+ fast.write.csv(signif(pca$x,5), file="pca_score.csv");
+ fast.write.csv(signif(pca$rotation,5), file="pca_loadings.csv");
+
+ mSetObj$analSet$pca <- pca;
+ return(.set.mSet(mSetObj));
+}
+
+#'Plot PCA pair summary, format image in png, tiff, pdf, ps, svg
+#'@description Rotate PCA analysis
+#'@usage PlotPCAPairSummary(mSetObj=NA, imgName, format="png", dpi=72, width=NA, pc.num)
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@param pc.num Numeric, input a number to indicate the number of principal components to display in the pairwise score plot.
+#'@export
+#'
+PlotPCAPairSummary <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA, pc.num){
+
+ mSetObj <- .get.mSet(mSetObj);
+ pclabels <- paste("PC", 1:pc.num, "\n", round(100*mSetObj$analSet$pca$variance[1:pc.num],1), "%");
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- 10;
+ }else if(width == 0){
+ w <- 8;
+ }else{
+ w <- width;
+ }
+
+ mSetObj$imgSet$pca.pair <- imgName;
+
+ h <- w;
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ if(mSetObj$dataSet$cls.type == "disc"){
+ pairs(mSetObj$analSet$pca$x[,1:pc.num], col=GetColorSchema(mSetObj$dataSet$cls), pch=as.numeric(mSetObj$dataSet$cls)+1, labels=pclabels);
+ }else{
+ pairs(mSetObj$analSet$pca$x[,1:pc.num], labels=pclabels);
+ }
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+#'Plot PCA scree plot
+#'@description Rotate PCA analysis
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@param scree.num Numeric, input a number to indicate the number of principal components to display in the scree plot.
+#'@usage PlotPCAScree(mSetObj=NA, imgName, format="png", dpi=72, width=NA, scree.num)
+#'@export
+#'
+PlotPCAScree <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA, scree.num){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ stds <-mSetObj$analSet$pca$std[1:scree.num];
+ pcvars<-mSetObj$analSet$pca$variance[1:scree.num];
+ cumvars<-mSetObj$analSet$pca$cum.var[1:scree.num];
+
+ ylims <- range(c(pcvars,cumvars));
+ extd<-(ylims[2]-ylims[1])/10
+ miny<- ifelse(ylims[1]-extd>0, ylims[1]-extd, 0);
+ maxy<- ifelse(ylims[2]+extd>1, 1.0, ylims[2]+extd);
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- 10;
+ }else if(width == 0){
+ w <- 8;
+ }else{
+ w <- width;
+ }
+ h <- w*2/3;
+
+ mSetObj$imgSet$pca.scree <- imgName;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ par(mar=c(5,5,6,3));
+ plot(pcvars, type='l', col='blue', main='Scree plot', xlab='PC index', ylab='Variance explained', ylim=c(miny, maxy), axes=F)
+ text(pcvars, labels =paste(100*round(pcvars,3),'%'), adj=c(-0.3, -0.5), srt=45, xpd=T)
+ points(pcvars, col='red');
+
+ lines(cumvars, type='l', col='green')
+ text(cumvars, labels =paste(100*round(cumvars,3),'%'), adj=c(-0.3, -0.5), srt=45, xpd=T)
+ points(cumvars, col='red');
+
+ abline(v=1:scree.num, lty=3);
+ axis(2);
+ axis(1, 1:length(pcvars), 1:length(pcvars));
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+#'Create 2D PCA score plot
+#'@description Rotate PCA analysis
+#'@usage PlotPCA2DScore(mSetObj=NA, imgName, format="png", dpi=72, width=NA, pcx, pcy, reg = 0.95, show=1, grey.scale = 0)
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@param pcx Specify the principal component on the x-axis
+#'@param pcy Specify the principal component on the y-axis
+#'@param reg Numeric, input a number between 0 and 1, 0.95 will display the 95 percent confidence regions, and 0 will not.
+#'@param show Display sample names, 1 = show names, 0 = do not show names.
+#'@param grey.scale Use grey-scale colors, 1 = grey-scale, 0 = not grey-scale.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotPCA2DScore <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA, pcx, pcy, reg = 0.95, show=1, grey.scale = 0){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ xlabel = paste("PC",pcx, "(", round(100*mSetObj$analSet$pca$variance[pcx],1), "%)");
+ ylabel = paste("PC",pcy, "(", round(100*mSetObj$analSet$pca$variance[pcy],1), "%)");
+ pc1 = mSetObj$analSet$pca$x[, pcx];
+ pc2 = mSetObj$analSet$pca$x[, pcy];
+ text.lbls<-substr(names(pc1),1,14) # some names may be too long
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- 9;
+ }else if(width == 0){
+ w <- 7.2;
+ }else{
+ w <- width;
+ }
+ h <- w;
+
+ mSetObj$imgSet$pca.score2d <- imgName;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ op<-par(mar=c(5,5,3,3));
+
+ if(mSetObj$dataSet$cls.type == "disc"){
+ # obtain ellipse points to the scatter plot for each category
+
+ if(mSetObj$dataSet$type.cls.lbl=="integer"){
+ cls <- as.factor(as.numeric(levels(mSetObj$dataSet$cls))[mSetObj$dataSet$cls]);
+ }else{
+ cls <- mSetObj$dataSet$cls;
+ }
+
+ lvs <- levels(cls);
+ pts.array <- array(0, dim=c(100,2,length(lvs)));
+ for(i in 1:length(lvs)){
+ inx <-mSetObj$dataSet$cls == lvs[i];
+ groupVar<-var(cbind(pc1[inx],pc2[inx]), na.rm=T);
+ groupMean<-cbind(mean(pc1[inx], na.rm=T),mean(pc2[inx], na.rm=T));
+ pts.array[,,i] <- ellipse::ellipse(groupVar, centre = groupMean, level = reg, npoints=100);
+ }
+
+ xrg <- range(pc1, pts.array[,1,]);
+ yrg <- range(pc2, pts.array[,2,]);
+ x.ext<-(xrg[2]-xrg[1])/12;
+ y.ext<-(yrg[2]-yrg[1])/12;
+ xlims<-c(xrg[1]-x.ext, xrg[2]+x.ext);
+ ylims<-c(yrg[1]-y.ext, yrg[2]+y.ext);
+
+ cols <- GetColorSchema(cls, grey.scale==1);
+ uniq.cols <- unique(cols);
+
+ plot(pc1, pc2, xlab=xlabel, xlim=xlims, ylim=ylims, ylab=ylabel, type='n', main="Scores Plot",
+ col=cols, pch=as.numeric(mSetObj$dataSet$cls)+1); ## added
+ grid(col = "lightgray", lty = "dotted", lwd = 1);
+
+ # make sure name and number of the same order DO NOT USE levels, which may be different
+ legend.nm <- unique(as.character(sort(cls)));
+ ## uniq.cols <- unique(cols);
+
+ ## BHAN: when same color is choosen; it makes an error
+ if ( length(uniq.cols) > 1 ) {
+ names(uniq.cols) <- legend.nm;
+ }
+
+ # draw ellipse
+ for(i in 1:length(lvs)){
+ if (length(uniq.cols) > 1) {
+ polygon(pts.array[,,i], col=adjustcolor(uniq.cols[lvs[i]], alpha=0.2), border=NA);
+ } else {
+ polygon(pts.array[,,i], col=adjustcolor(uniq.cols, alpha=0.2), border=NA);
+ }
+ if(grey.scale) {
+ lines(pts.array[,,i], col=adjustcolor("black", alpha=0.5), lty=2);
+ }
+ }
+
+ pchs <- GetShapeSchema(mSetObj, show, grey.scale);
+ if(grey.scale) {
+ cols <- rep("black", length(cols));
+ }
+ if(show == 1){
+ text(pc1, pc2, label=text.lbls, pos=4, xpd=T, cex=0.75);
+ points(pc1, pc2, pch=pchs, col=cols);
+ }else{
+ if(length(uniq.cols) == 1){
+ points(pc1, pc2, pch=pchs, col=cols, cex=1.0);
+ }else{
+ if(grey.scale == 1 | (exists("shapeVec") && all(shapeVec>=0))){
+ my.cols <- adjustcolor(cols, alpha.f = 0.4);
+ my.cols[pchs == 21] <- "black";
+ points(pc1, pc2, pch=pchs, col=my.cols, bg=adjustcolor(cols, alpha.f = 0.4), cex=1.8);
+ }else{
+ points(pc1, pc2, pch=21, bg=adjustcolor(cols, alpha.f = 0.4), cex=2);
+ }
+ }
+ }
+ uniq.pchs <- unique(pchs);
+ if(grey.scale) {
+ uniq.cols <- "black";
+ }
+
+ if(length(lvs) < 6){
+ legend("topright", legend = legend.nm, pch=uniq.pchs, col=uniq.cols);
+ }else if (length(lvs) < 10){
+ legend("topright", legend = legend.nm, pch=uniq.pchs, col=uniq.cols, cex=0.75);
+ }else{
+ legend("topright", legend = legend.nm, pch=uniq.pchs, col=uniq.cols, cex=0.5);
+ }
+
+ }else{
+ plot(pc1, pc2, xlab=xlabel, ylab=ylabel, type='n', main="Scores Plot");
+ points(pc1, pc2, pch=15, col="magenta");
+ text(pc1, pc2, label=text.lbls, pos=4, col ="blue", xpd=T, cex=0.8);
+ }
+ par(op);
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+#'Create 3D PCA score plot
+#'@description Rotate PCA analysis
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@usage PlotPCA3DScore(mSetObj=NA, imgName, format="json", inx1, inx2, inx3)
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param inx1 Numeric, indicate the number of the principal component for the x-axis of the loading plot.
+#'@param inx2 Numeric, indicate the number of the principal component for the y-axis of the loading plot.
+#'@param inx3 Numeric, indicate the number of the principal component for the z-axis of the loading plot.
+#'@export
+#'
+PlotPCA3DScore <- function(mSetObj=NA, imgName, format="json", inx1, inx2, inx3){
+ mSetObj <- .get.mSet(mSetObj);
+
+ pca <- mSetObj$analSet$pca;
+ pca3d <- list();
+ pca3d$score$axis <- paste("PC", c(inx1, inx2, inx3), " (", 100*round( mSetObj$analSet$pca$variance[c(inx1, inx2, inx3)], 3), "%)", sep="");
+ coords <- data.frame(t(signif(pca$x[,c(inx1, inx2, inx3)], 5)));
+ colnames(coords) <- NULL;
+ pca3d$score$xyz <- coords;
+ pca3d$score$name <- rownames(mSetObj$dataSet$norm);
+
+ if(mSetObj$dataSet$type.cls.lbl=="integer"){
+ cls <- as.character(sort(as.factor(as.numeric(levels(mSetObj$dataSet$cls))[mSetObj$dataSet$cls])));
+ }else{
+ cls <- as.character(mSetObj$dataSet$cls);
+ }
+
+ if(all.numeric(cls)){
+ cls <- paste("Group", cls);
+ }
+
+ pca3d$score$facA <- cls;
+
+ # now set color for each group
+ cols <- unique(GetColorSchema(mSetObj$dataSet$cls));
+ pca3d$score$colors <- my.col2rgb(cols);
+ imgName = paste(imgName, ".", format, sep="");
+ json.obj <- RJSONIO::toJSON(pca3d, .na='null');
+ sink(imgName);
+ cat(json.obj);
+ sink();
+
+ if(!.on.public.web){
+ return(.set.mSet(mSetObj));
+ }
+}
+
+#'@export
+PlotPCA3DLoading <- function(mSetObj=NA, imgName, format="json", inx1, inx2, inx3){
+ mSetObj <- .get.mSet(mSetObj);
+ pca = mSetObj$analSet$pca
+ coords<-signif(as.matrix(cbind(pca$rotation[,inx1],pca$rotation[,inx2],pca$rotation[,inx3])),5);
+ pca3d <- list();
+
+ pca3d$loading$axis <- paste("Loading ", c(inx1, inx2, inx3), sep="");
+ coords <- data.frame(t(signif(pca$rotation[,1:3], 5)));
+
+ colnames(coords) <- NULL;
+ pca3d$loading$xyz <- coords;
+ pca3d$loading$name <- rownames(pca$rotation);
+ pca3d$loading$entrez <-rownames(pca$rotation);
+
+ if(mSetObj$dataSet$type.cls.lbl=="integer"){
+ cls <- as.character(sort(as.factor(as.numeric(levels(mSetObj$dataSet$cls))[mSetObj$dataSet$cls])));
+ }else{
+ cls <- as.character(mSetObj$dataSet$cls);
+ }
+
+ if(all.numeric(cls)){
+ cls <- paste("Group", cls);
+ }
+
+ pca3d$cls = cls;
+ # see if there is secondary
+
+ require(RJSONIO);
+ imgName = paste(imgName, ".", format, sep="");
+ json.mat <- toJSON(pca3d, .na='null');
+ sink(imgName);
+ cat(json.mat);
+ sink();
+ current.msg <<- "Annotated data is now ready for PCA 3D visualization!";
+
+ if(.on.public.web){
+ return(1);
+ }else{
+ return(.set.mSet(mSetObj));
+ }
+
+}
+
+#'Update PCA loadings
+#'@description Update the PCA loadings
+#'@param mSetObj Input name of the created mSet Object
+#'@param plotType Set annotation type, "all" to label all variables and
+#'"none" to label no variables.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+UpdatePCA.Loading<- function(mSetObj=NA, plotType){
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$analSet$pca$loading.type <- plotType;
+ mSetObj$custom.cmpds <- c();
+ return(.set.mSet(mSetObj));
+}
+
+#'Plot PCA loadings and also set up the matrix for display
+#'@description Rotate PCA analysis
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@usage PlotPCALoading(mSetObj=NA, imgName, format="png", dpi=72, width=NA, inx1, inx2, plotType, lbl.feat=1)
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@param inx1 Numeric, indicate the number of the principal component for the x-axis of the loading plot.
+#'@param inx2 Numeric, indicate the number of the principal component for the y-axis of the loading plot.
+#'@export
+#'
+PlotPCALoading <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA, inx1, inx2){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ loadings<-as.matrix(cbind(mSetObj$analSet$pca$rotation[,inx1],mSetObj$analSet$pca$rotation[,inx2]));
+ # sort based on absolute values of 1, 2
+ ord.inx <- order(-abs(loadings[,1]), -abs(loadings[,2]));
+ loadings <- signif(loadings[ord.inx,],5);
+
+ ldName1<-paste("Loadings", inx1);
+ ldName2<-paste("Loadings", inx2);
+ colnames(loadings)<-c(ldName1, ldName2);
+ mSetObj$analSet$pca$imp.loads<-loadings; # set up the loading matrix
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- 9;
+ }else if(width == 0){
+ w <- 7.2;
+ }else{
+ w <- width;
+ }
+ h <- w;
+
+ mSetObj$imgSet$pca.loading <- imgName;
+ plotType <- mSetObj$analSet$pca$loading.type;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+
+ par(mar=c(6,5,2,6));
+ plot(loadings[,1],loadings[,2], las=2, xlab=ldName1, ylab=ldName2);
+
+ mSetObj$pca.axis.lims <- par("usr"); # x1, x2, y1 ,y2
+ grid(col = "lightgray", lty = "dotted", lwd = 1);
+ points(loadings[,1],loadings[,2], pch=19, col=adjustcolor("magenta", alpha.f = 0.4));
+
+ if(plotType=="all"){
+ text(loadings[,1],loadings[,2], labels=substr(rownames(loadings), 1, 16), pos=4, col="blue", xpd=T);
+ }else if(plotType == "custom"){
+ if(length(mSetObj$custom.cmpds) > 0){
+ hit.inx <- colnames(mSetObj$dataSet$norm) %in% mSetObj$custom.cmpds;
+ text(loadings[hit.inx,1],loadings[hit.inx,2], labels=rownames(loadings)[hit.inx], pos=4, col="blue", xpd=T);
+ }
+ }else{
+ # do nothing
+ }
+
+ dev.off();
+ return(.set.mSet(mSetObj));
+
+}
+
+#'Create PCA Biplot, set xpd = T to plot outside margin
+#'@description Rotate PCA analysis
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@usage PlotPCABiplot(mSetObj=NA, imgName, format="png", dpi=72, width=NA, inx1, inx2)
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@param inx1 Numeric, indicate the number of the principal component for the x-axis of the loading plot.
+#'@param inx2 Numeric, indicate the number of the principal component for the y-axis of the loading plot.
+#'@export
+#'
+PlotPCABiplot <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA, inx1, inx2){
+
+ mSetObj <- .get.mSet(mSetObj);
+ choices = c(inx1, inx2);
+ scores <- mSetObj$analSet$pca$x;
+ lam <- mSetObj$analSet$pca$sdev[choices]
+ n <- NROW(scores)
+ lam <- lam * sqrt(n);
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- 9;
+ }else if(width == 0){
+ w <- 7.2;
+ }else{
+ w <- width;
+ }
+ h <- w;
+
+ mSetObj$imgSet$pca.biplot<-imgName;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ biplot(t(t(scores[, choices]) / lam), t(t(mSetObj$analSet$pca$rotation[, choices]) * lam), xpd =T, cex=0.9);
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+#'PLS analysis using oscorespls (Orthogonal scores algorithm)
+#'so that VIP can be calculated
+#'note: the VIP is calculated only after PLSDA-CV is performed
+#'to determine the best # of comp. used for VIP
+#'@description PLS analysis using oscorespls
+#'@param mSetObj Input name of the created mSet Object
+#'@param reg Logical
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+PLSR.Anal <- function(mSetObj=NA, reg=FALSE){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ comp.num <- dim(mSetObj$dataSet$norm)[1]-1;
+
+ if(comp.num > 8) {
+ #need to deal with small number of predictors
+ comp.num <- min(dim(mSetObj$dataSet$norm)[2], 8)
+ }
+
+ if(.on.public.web){
+ load_pls()
+ }
+
+ # note, standardize the cls, to minimize the impact of categorical to numerical impact
+ if(reg){
+ cls <- scale(as.numeric(mSetObj$dataSet$cls))[,1];
+ }else{
+ cls <- model.matrix(~mSetObj$dataSet$cls-1);
+ }
+
+ datmat <- as.matrix(mSetObj$dataSet$norm);
+ mSetObj$analSet$plsr <- pls::plsr(cls~datmat, method='oscorespls', ncomp=comp.num);
+ mSetObj$analSet$plsr$reg <- reg;
+ mSetObj$analSet$plsr$loading.type <- "all";
+ mSetObj$custom.cmpds <- c();
+
+ fast.write.csv(signif(mSetObj$analSet$plsr$scores,5), row.names=rownames(mSetObj$dataSet$norm), file="plsda_score.csv");
+ fast.write.csv(signif(mSetObj$analSet$plsr$loadings,5), file="plsda_loadings.csv");
+ return(.set.mSet(mSetObj));
+}
+
+#'Plot PLS pairwise summary
+#'@description Plot PLS pairwise summary
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@param pc.num Numeric, indicate the number of principal components
+#'@export
+
+PlotPLSPairSummary <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA, pc.num){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- 9;
+ }else if(width == 0){
+ w <- 7.2;
+
+ }else{
+ w <- width;
+ }
+ h <- w;
+
+ mSetObj$imgSet$pls.pair <- imgName;
+
+ vars <- round(100*mSetObj$analSet$plsr$Xvar[1:pc.num]/mSetObj$analSet$plsr$Xtotvar,1);
+ my.data <- mSetObj$analSet$plsr$scores[,1:pc.num];
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ pclabels <- paste("Component", 1:pc.num, "\n", vars, "%");
+ pairs(my.data, col=GetColorSchema(mSetObj$dataSet$cls), pch=as.numeric(mSetObj$dataSet$cls)+1, labels=pclabels)
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+#'Plot PLS score plot
+#'@description Plot PLS score plot
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@param inx1 Numeric, indicate the number of the principal component for the x-axis of the loading plot.
+#'@param inx2 Numeric, indicate the number of the principal component for the y-axis of the loading plot.
+#'@param reg Numeric, default is 0.95
+#'@param show Show labels, 1 or 0
+#'@param grey.scale Numeric, use a grey scale (0) or not (1)
+#'@param use.sparse Logical, use a sparse algorithm (T) or not (F)
+#'@export
+#'
+PlotPLS2DScore <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA, inx1, inx2, reg=0.95, show=1, grey.scale=0, use.sparse=FALSE){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- 9;
+ }else if(width == 0){
+ w <- 7.2;
+ }else{
+ w <- width;
+ }
+ h <- w;
+
+ mSetObj$imgSet$pls.score2d <- imgName;
+
+ lv1 <- mSetObj$analSet$plsr$scores[,inx1];
+ lv2 <- mSetObj$analSet$plsr$scores[,inx2];
+ xlabel <- paste("Component", inx1, "(", round(100*mSetObj$analSet$plsr$Xvar[inx1]/mSetObj$analSet$plsr$Xtotvar,1), "%)");
+ ylabel <- paste("Component", inx2, "(", round(100*mSetObj$analSet$plsr$Xvar[inx2]/mSetObj$analSet$plsr$Xtotvar,1), "%)");
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ par(mar=c(5,5,3,3));
+ text.lbls <- substr(rownames(mSetObj$dataSet$norm),1,12) # some names may be too long
+
+ # obtain ellipse points to the scatter plot for each category
+
+ if(mSetObj$dataSet$type.cls.lbl=="integer"){
+ cls <- as.factor(as.numeric(levels(mSetObj$dataSet$cls))[mSetObj$dataSet$cls]);
+ }else{
+ cls <- mSetObj$dataSet$cls;
+ }
+
+ lvs <- levels(cls);
+ pts.array <- array(0, dim=c(100,2,length(lvs)));
+ for(i in 1:length(lvs)){
+ inx <- mSetObj$dataSet$cls == lvs[i];
+ groupVar <- var(cbind(lv1[inx],lv2[inx]), na.rm=T);
+ groupMean <- cbind(mean(lv1[inx], na.rm=T),mean(lv2[inx], na.rm=T));
+ pts.array[,,i] <- ellipse::ellipse(groupVar, centre = groupMean, level = reg, npoints=100);
+ }
+
+ xrg <- range(lv1, pts.array[,1,]);
+ yrg <- range(lv2, pts.array[,2,]);
+ x.ext<-(xrg[2]-xrg[1])/12;
+ y.ext<-(yrg[2]-yrg[1])/12;
+ xlims<-c(xrg[1]-x.ext, xrg[2]+x.ext);
+ ylims<-c(yrg[1]-y.ext, yrg[2]+y.ext);
+
+ ## cols = as.numeric(dataSet$cls)+1;
+ cols <- GetColorSchema(cls, grey.scale==1);
+ uniq.cols <- unique(cols);
+
+ plot(lv1, lv2, xlab=xlabel, xlim=xlims, ylim=ylims, ylab=ylabel, type='n', main="Scores Plot");
+ grid(col = "lightgray", lty = "dotted", lwd = 1);
+
+ # make sure name and number of the same order DO NOT USE levels, which may be different
+ legend.nm <- unique(as.character(sort(cls)));
+ ## uniq.cols <- unique(cols);
+
+ ## BHAN: when same color is choosen for black/white; it makes an error
+ # names(uniq.cols) <- legend.nm;
+ if (length(uniq.cols) > 1) {
+ names(uniq.cols) <- legend.nm;
+ }
+ # draw ellipse
+ for(i in 1:length(lvs)){
+ if ( length(uniq.cols) > 1) {
+ polygon(pts.array[,,i], col=adjustcolor(uniq.cols[lvs[i]], alpha=0.2), border=NA);
+ } else {
+ polygon(pts.array[,,i], col=adjustcolor(uniq.cols, alpha=0.2), border=NA);
+ }
+ if(grey.scale) {
+ lines(pts.array[,,i], col=adjustcolor("black", alpha=0.5), lty=2);
+ }
+ }
+
+ pchs <- GetShapeSchema(mSetObj, show, grey.scale);
+ if(grey.scale) {
+ cols <- rep("black", length(cols));
+ }
+ if(show==1){ # display sample name set on
+ text(lv1, lv2, label=text.lbls, pos=4, xpd=T, cex=0.75);
+ points(lv1, lv2, pch=pchs, col=cols);
+ }else{
+ if (length(uniq.cols) == 1) {
+ points(lv1, lv2, pch=pchs, col=cols, cex=1.0);
+ } else {
+ if(grey.scale == 1 | (exists("shapeVec") && all(shapeVec>=0))){
+ my.cols <- adjustcolor(cols, alpha.f = 0.4);
+ my.cols[pchs == 21] <- "black";
+ points(lv1, lv2, pch=pchs, col=my.cols, bg=adjustcolor(cols, alpha.f = 0.4), cex=1.8);
+ }else{
+ points(lv1, lv2, pch=21, bg=adjustcolor(cols, alpha.f = 0.4), cex=2);
+ }
+ }
+ }
+
+ uniq.pchs <- unique(pchs);
+ if(grey.scale) {
+ uniq.cols <- "black";
+ }
+ legend("topright", legend = legend.nm, pch=uniq.pchs, col=uniq.cols);
+
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+#'Plot PLS 3D score plot
+#'@description Plot PLS 3D score plot
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param inx1 Numeric, indicate the number of the principal component for the x-axis of the loading plot.
+#'@param inx2 Numeric, indicate the number of the principal component for the y-axis of the loading plot.
+#'@param inx3 Numeric, indicate the number of the principal component for the z-axis of the loading plot.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotPLS3DScore <- function(mSetObj=NA, imgName, format="json", inx1, inx2, inx3){
+ mSetObj <- .get.mSet(mSetObj);
+
+ pls3d <- list();
+ pls3d$score$axis <- paste("Component", c(inx1, inx2, inx3), " (", round(100*mSetObj$analSet$plsr$Xvar[c(inx1, inx2, inx3)]/mSetObj$analSet$plsr$Xtotvar, 1), "%)", sep="");
+ coords <- data.frame(t(signif(mSetObj$analSet$plsr$score[,c(inx1, inx2, inx3)], 5)));
+ colnames(coords) <- NULL;
+ pls3d$score$xyz <- coords;
+ pls3d$score$name <- rownames(mSetObj$dataSet$norm);
+
+ if(mSetObj$dataSet$type.cls.lbl=="integer"){
+ cls <- as.character(sort(as.factor(as.numeric(levels(mSetObj$dataSet$cls))[mSetObj$dataSet$cls])));
+ }else{
+ cls <- as.character(mSetObj$dataSet$cls);
+ }
+
+ if(all.numeric(cls)){
+ cls <- paste("Group", cls);
+ }
+
+ pls3d$score$facA <- cls;
+
+ # now set color for each group
+ cols <- unique(GetColorSchema(mSetObj$dataSet$cls));
+ pls3d$score$colors <- my.col2rgb(cols);
+
+ imgName = paste(imgName, ".", format, sep="");
+ json.obj <- RJSONIO::toJSON(pls3d, .na='null');
+ sink(imgName);
+ cat(json.obj);
+ sink();
+ mSet$imgSet$pls.score3d <- imgName;
+ return(.set.mSet(mSetObj));
+}
+
+#'@export
+PlotPLS3DLoading <- function(mSetObj=NA, imgName, format="json", inx1, inx2, inx3){
+ mSetObj <- .get.mSet(mSetObj);
+ pls = mSetObj$analSet$plsr
+ coords<-signif(as.matrix(cbind(pls$loadings[,inx1],pls$loadings[,inx2],pls$loadings[,inx3])),5);
+ pls3d <- list();
+
+ pls3d$loading$axis <- paste("Loading ", c(inx1, inx2, inx3), sep="");
+ coords <- data.frame(t(signif(pls$loadings[,c(inx1, inx2, inx3)], 5)));
+
+ colnames(coords) <- NULL;
+ pls3d$loading$xyz <- coords;
+ pls3d$loading$name <- rownames(pls$loadings);
+ pls3d$loading$entrez <-rownames(pls$loadings);
+
+ if(mSetObj$dataSet$type.cls.lbl=="integer"){
+ cls <- as.character(sort(as.factor(as.numeric(levels(mSetObj$dataSet$cls))[mSetObj$dataSet$cls])));
+ }else{
+ cls <- as.character(mSetObj$dataSet$cls);
+ }
+
+ if(all.numeric(cls)){
+ cls <- paste("Group", cls);
+ }
+
+ pls3d$cls = cls;
+ # see if there is secondary
+
+ require(RJSONIO);
+ imgName = paste(imgName, ".", format, sep="");
+ json.mat <- RJSONIO::toJSON(pls3d, .na='null');
+ sink(imgName);
+ cat(json.mat);
+ sink();
+ current.msg <<- "Annotated data is now ready for PCA 3D visualization!";
+
+ if(.on.public.web){
+ return(1);
+ }else{
+ return(.set.mSet(mSetObj));
+ }
+
+}
+
+#'Update PLS loadings
+#'@description Update the PLS loadings
+#'@param mSetObj Input name of the created mSet Object
+#'@param plotType Set annotation type, "all" to label all variables and
+#'"none" to label no variables.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+UpdatePLS.Loading<- function(mSetObj=NA, plotType){
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$analSet$plsr$loading.type <- plotType;
+ mSetObj$custom.cmpds <- c();
+ return(.set.mSet(mSetObj));
+}
+
+
+#'Plot PLS loading plot, also set the loading matrix for display
+#'@description Plot PLS loading plot, also set the loading matrix for display
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images, the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5. The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@param inx1 Numeric, indicate the number of the principal component for the x-axis of the loading plot.
+#'@param inx2 Numeric, indicate the number of the principal component for the y-axis of the loading plot.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotPLSLoading <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA, inx1, inx2){
+
+ mSetObj <- .get.mSet(mSetObj);
+ # named vector
+ load1<-mSetObj$analSet$plsr$loadings[,inx1];
+ load2<-mSetObj$analSet$plsr$loadings[,inx2];
+ loadings = as.matrix(cbind(load1, load2));
+ # sort based on absolute values of 1, 2
+ ord.inx <- order(-abs(loadings[,1]), -abs(loadings[,2]));
+ loadings <- signif(loadings[ord.inx,],5);
+
+ ldName1<-paste("Loadings", inx1);
+ ldName2<-paste("Loadings", inx2)
+ colnames(loadings)<-c(ldName1, ldName2);
+ mSetObj$analSet$plsr$imp.loads<-loadings; # set up loading matrix
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- 9;
+ }else if(width == 0){
+ w <- 7.2;
+ }else{
+ w <- width;
+ }
+ h <- w;
+
+ mSetObj$imgSet$pls.loading <- imgName;
+ plotType <- mSetObj$analSet$plsr$loading.type;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+
+ par(mar=c(6,4,4,5));
+ plot(loadings[,1],loadings[,2], las=2, xlab=ldName1, ylab=ldName2);
+
+ mSetObj$pls.axis.lims <- par("usr"); # x1, x2, y1 ,y2
+ grid(col = "lightgray", lty = "dotted", lwd = 1);
+ points(loadings[,1],loadings[,2], pch=19, col=adjustcolor("magenta", alpha.f = 0.4));
+
+ if(plotType=="all"){
+ text(loadings[,1],loadings[,2], labels=substr(rownames(loadings), 1, 16), pos=4, col="blue", xpd=T);
+ }else if(plotType == "custom"){
+ if(length(mSetObj$custom.cmpds) > 0){
+ hit.inx <- colnames(mSetObj$dataSet$norm) %in% mSetObj$custom.cmpds;
+ text(loadings[hit.inx,1],loadings[hit.inx,2], labels=rownames(loadings)[hit.inx], pos=4, col="blue", xpd=T);
+ }
+ }else{
+ # do nothing
+ }
+
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+#'PLS-DA classification and feature selection
+#'@description PLS-DA classification and feature selection
+#'@param mSetObj Input name of the created mSet Object
+#'@param methodName Logical, by default set to TRUE
+#'@param compNum GetDefaultPLSCVComp()
+#'@param choice Input the choice, by default it is Q2
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+PLSDA.CV <- function(mSetObj=NA, methodName="T", compNum=GetDefaultPLSCVComp(mSetObj), choice="Q2"){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(.on.public.web){
+ load_caret()
+ }
+
+ # get classification accuracy using caret
+ plsda.cls <- caret::train(mSetObj$dataSet$norm, mSetObj$dataSet$cls, "pls", trControl=caret::trainControl(method=ifelse(methodName == 'L', "LOOCV", 'CV')), tuneLength=compNum);
+
+ # note, for regression, use model matrix
+ if(mSetObj$analSet$plsr$reg){
+ cls<-cls<-scale(as.numeric(mSetObj$dataSet$cls))[,1];
+ }else{
+ cls<-model.matrix(~mSetObj$dataSet$cls-1);
+ }
+
+ datmat <- as.matrix(mSetObj$dataSet$norm);
+
+ # use the classifical regression to get R2 and Q2 measure
+ plsda.reg <- pls::plsr(cls~datmat,method ='oscorespls', ncomp=compNum, validation= ifelse(methodName == 'L', "LOO", 'CV'));
+ fit.info <- pls::R2(plsda.reg, estimate = "all")$val[,1,];
+
+ # combine accuracy, R2 and Q2
+ accu <- plsda.cls$results[,2]
+ all.info <- rbind(accu, fit.info[,-1]);
+
+ rownames(all.info) <- c("Accuracy", "R2", "Q2");
+
+ # default use best number determined by Q2
+ if(choice == 'Q2'){
+ best.num <- which(all.info[3,] == max(all.info[3,]));
+ }else if(choice == "R2"){
+ best.num <- which(all.info[2,] == max(all.info[2,]));
+ }else{
+ best.num <- which(all.info[1,] == max(all.info[1,]));
+ }
+
+ # get coef. table, this can be error when class is very unbalanced
+ coef.mat <- try(caret::varImp(plsda.cls, scale=T)$importance);
+ if(class(coef.mat) == "try-error") {
+ coef.mat <- NULL;
+ }else{
+ if(mSetObj$dataSet$cls.num > 2){ # add an average coef for multiple class
+ coef.mean <- apply(coef.mat, 1, mean);
+ coef.mat <- cbind(coef.mean = coef.mean, coef.mat);
+ }
+ # rearange in decreasing order, keep as matrix, prevent dimesion dropping if only 1 col
+ inx.ord <- order(coef.mat[,1], decreasing=T);
+ coef.mat <- data.matrix(coef.mat[inx.ord, ,drop=FALSE]);
+ fast.write.csv(signif(coef.mat,5), file="plsda_coef.csv"); # added 27 Jan 2014
+ }
+ # calculate VIP http://mevik.net/work/software/VIP.R
+ pls <- mSetObj$analSet$plsr;
+ b <- c(pls$Yloadings)[1:compNum];
+ T <- pls$scores[,1:compNum, drop = FALSE]
+ SS <- b^2 * colSums(T^2)
+ W <- pls$loading.weights[,1:compNum, drop = FALSE]
+ Wnorm2 <- colSums(W^2);
+ SSW <- sweep(W^2, 2, SS / Wnorm2, "*")
+ vips <- sqrt(nrow(SSW) * apply(SSW, 1, cumsum) / cumsum(SS));
+ if(compNum > 1){
+ vip.mat <- as.matrix(t(vips));
+ ord.inx <- order(-abs(vip.mat[,1]), -abs(vip.mat[,2]));
+ }else{
+ vip.mat <- as.matrix(vips);
+ ord.inx <- order(-abs(vip.mat[,1]));
+ }
+ vip.mat <- vip.mat[ord.inx,];
+ colnames(vip.mat) <- paste("Comp.", 1:ncol(vip.mat));
+
+ fast.write.csv(signif(vip.mat,5),file="plsda_vip.csv");
+
+ mSetObj$analSet$plsda<-list(best.num=best.num, choice=choice, coef.mat=coef.mat, vip.mat=vip.mat, fit.info=all.info);
+ return(.set.mSet(mSetObj));
+}
+
+#'Perform PLS-DA permutation
+#'@description Perform PLS-DA permutation using training classification accuracy as
+#'indicator, for two or multi-groups
+#'@param mSetObj Input name of the created mSet Object
+#'@param num Numeric, input the number of permutations
+#'@param type Type of accuracy, if "accu" indicate prediction accuracy, else "sep" is separation distance
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PLSDA.Permut <- function(mSetObj=NA, num=100, type="accu"){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ orig.cls <- cls <- as.numeric(mSetObj$dataSet$cls);
+ datmat <- as.matrix(mSetObj$dataSet$norm);
+ best.num <- mSetObj$analSet$plsda$best.num;
+
+ # dummy is not used, for the purpose to maintain lapply API
+ Get.pls.bw <- function(dummy){
+ cls <- cls[order(runif(length(cls)))];
+ pls <- caret::plsda(datmat, as.factor(cls), ncomp=best.num);
+ pred <- predict(pls, datmat);
+ Get.bwss(pred, cls);
+ }
+
+ Get.pls.accu <- function(dummy){
+ cls <- cls[order(runif(length(cls)))];
+ pls <- caret::plsda(datmat, as.factor(cls), ncomp=best.num);
+ pred <- predict(pls, datmat);
+ sum(pred == cls)/length(cls);
+ }
+
+ # first calculate the bw values with original labels
+ pls <- caret::plsda(datmat, as.factor(orig.cls), ncomp=best.num);
+ pred.orig <- predict(pls, datmat);
+ if(type=="accu"){
+ perm.type = "prediction accuracy";
+ res.orig <- sum(pred.orig == orig.cls)/length(orig.cls);
+ res.perm <- Perform.permutation(num, Get.pls.accu);
+ }else{
+ perm.type = "separation distance";
+ res.orig <- Get.bwss(pred.orig, orig.cls);
+ res.perm <- Perform.permutation(num, Get.pls.bw);
+ }
+ # perm.num may be adjusted on public server
+ perm.num <- res.perm$perm.num;
+ perm.res <- res.perm$perm.res;
+ perm.vec <- c(res.orig, unlist(perm.res, use.names=FALSE));
+ # check for infinite since with group variance could be zero for perfect classification
+ inf.found = TRUE;
+ if(sum(is.finite(perm.vec))==length(perm.vec)){
+ inf.found = FALSE;
+ }else {
+ if(sum(is.finite(perm.vec))==0){ # all are infinite, give a random number 10
+ perm.vec<-rep(10, length(perm.vec));
+ }else{ # if not all inf, replace with the 10 fold of non-inf values
+ perm.vec[!is.finite(perm.vec)]<-10*max(perm.vec[is.finite(perm.vec)]);
+ }
+ }
+
+ # calculate the significant p value as the proportion of sampled permutations better than or equal to original one
+ # note, the precision is determined by the permutation number i.e. for 100 time, no better than original
+ # p value is < 0.01, we can not say it is zero
+ better.hits <- sum(perm.vec[-1]>=perm.vec[1]);
+ if(better.hits == 0) {
+ p <- paste("p < ", 1/perm.num, " (", better.hits, "/", perm.num, ")", sep="");
+ }else{
+ p <- better.hits/perm.num;
+ p <- paste("p = ", signif(p, digits=5), " (", better.hits, "/", perm.num, ")", sep="");
+ }
+
+ mSetObj$analSet$plsda$permut.p <- p;
+ mSetObj$analSet$plsda$permut.inf <- F;
+ mSetObj$analSet$plsda$permut.type <- perm.type;
+ mSetObj$analSet$plsda$permut <- perm.vec;
+
+ msg <- paste("Empirical p value:", p);
+ if(.on.public.web){
+ .set.mSet(mSetObj)
+ return(msg)
+ }else{
+ print(msg);
+ return(.set.mSet(mSetObj));
+ }
+}
+
+#'Plot PLS important features
+#'@description Plot PLS important features, BHan: added bgcolor parameter for B/W color
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@param type Indicate the type variables of importance to use, "vip" to use VIp scores, or "type"
+#'for coefficients
+#'@param feat.nm Feature name
+#'@param feat.num Feature numbers
+#'@param color.BW Logical, true to use black and white, or false to not
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotPLS.Imp <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA, type, feat.nm, feat.num, color.BW=FALSE){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- 8;
+ }else if(width == 0){
+ w <- 7;
+ }else{
+ w <- width;
+ }
+ h <- w;
+
+ mSetObj$imgSet$pls.imp<-imgName;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+
+ if(type=="vip"){
+ mSetObj$analSet$plsda$imp.type <- "vip";
+ vips <- mSetObj$analSet$plsda$vip.mat[,feat.nm];
+ PlotImpVar(mSetObj, vips, "VIP scores", feat.num, color.BW);
+ }else{
+ mSetObj$analSet$plsda$imp.type <- "coef";
+ data<-mSetObj$analSet$plsda$coef.mat[,feat.nm];
+ PlotImpVar(mSetObj, data, "Coefficients", feat.num, color.BW);
+ }
+ dev.off();
+
+ return(.set.mSet(mSetObj));
+}
+
+#'Plot PLS important variables,
+#'@description Plot PLS important variables, BHan: added bgcolor parameter for B/W color
+#'@param mSetObj Input name of the created mSet Object
+#'@param imp.vec Input the vector of important variables
+#'@param xlbl Input the x-label
+#'@param feat.num Numeric, set the feature numbers, default is set to 15
+#'@param color.BW Use black-white for plot (T) or colors (F)
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotImpVar <- function(mSetObj=NA, imp.vec, xlbl, feat.num=15, color.BW=FALSE){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ cls.len <- length(levels(mSetObj$dataSet$cls));
+ if(cls.len == 2){
+ rt.mrg <- 5;
+ }else if(cls.len == 3){
+ rt.mrg <- 6;
+ }else if(cls.len == 4){
+ rt.mrg <- 7;
+ }else if(cls.len == 5){
+ rt.mrg <- 8;
+ }else if(cls.len == 6){
+ rt.mrg <- 9;
+ }else{
+ rt.mrg <- 11;
+ }
+ op <- par(mar=c(5,7,3,rt.mrg)); # set right side margin with the number of class
+
+ if(feat.num <= 0){
+ feat.num = 15;
+ }
+
+ if(feat.num > length(imp.vec)){
+ feat.num <- length(imp.vec);
+ }
+
+ # first get the top subset
+ imp.vec <- rev(sort(imp.vec))[1:feat.num];
+
+ # reverser the order for display
+ imp.vec <- sort(imp.vec);
+
+ # as data should already be normalized, use mean/median should be the same
+ # mns is a list contains means of all vars at each level
+ # conver the list into a matrix with each row contains var averages across different lvls
+ mns <- by(mSetObj$dataSet$norm[, names(imp.vec)], mSetObj$dataSet$cls,
+ function(x){ # inner function note, by send a subset of dataframe
+ apply(x, 2, mean, trim=0.1)
+ });
+ mns <- t(matrix(unlist(mns), ncol=feat.num, byrow=TRUE));
+
+ # vip.nms <-substr(names(imp.vec), 1, 12);
+ vip.nms <- substr(names(imp.vec), 1, 14);
+ names(imp.vec) <- NULL;
+
+ # modified for B/W color
+ dotcolor <- ifelse(color.BW, "darkgrey", "#585855");
+ dotchart(imp.vec, bg=dotcolor, xlab= xlbl, cex=1.3);
+
+ mtext(side=2, at=1:feat.num, vip.nms, las=2, line=1)
+
+ axis.lims <- par("usr"); # x1, x2, y1 ,y2
+
+ # get character width
+ shift <- 2*par("cxy")[1];
+ lgd.x <- axis.lims[2] + shift;
+
+ x <- rep(lgd.x, feat.num);
+ y <- 1:feat.num;
+ par(xpd=T);
+
+ nc <- ncol(mns);
+
+ # modified for B/W color
+ colorpalette <- ifelse(color.BW, "Greys", "RdYlBu");
+ col <- colorRampPalette(RColorBrewer::brewer.pal(10, colorpalette))(nc); # set colors for each class
+ if(color.BW) col <- rev(col);
+
+ # calculate background
+ bg <- matrix("", nrow(mns), nc);
+ for (m in 1:nrow(mns)){
+ bg[m,] <- (col[nc:1])[rank(mns[m,])];
+ }
+
+ if(mSetObj$dataSet$type.cls.lbl=="integer"){
+ cls <- as.factor(as.numeric(levels(mSetObj$dataSet$cls))[mSetObj$dataSet$cls]);
+ }else{
+ cls <- mSetObj$dataSet$cls;
+ }
+
+ cls.lbl <- levels(cls);
+
+ for (n in 1:ncol(mns)){
+ points(x,y, bty="n", pch=22, bg=bg[,n], cex=3);
+ # now add label
+ text(x[1], axis.lims[4], cls.lbl[n], srt=45, adj=c(0.2,0.5));
+ # shift x, note, this is good for current size
+ x <- x + shift/1.25;
+ }
+
+ # now add color key, padding with more intermediate colors for contiuous band
+ col <- colorRampPalette(RColorBrewer::brewer.pal(25, colorpalette))(50)
+ if(color.BW) col <- rev(col);
+
+ nc <- length(col);
+ x <- rep(x[1] + shift, nc);
+
+ shifty <- (axis.lims[4]-axis.lims[3])/3;
+ starty <- axis.lims[3] + shifty;
+ endy <- axis.lims[3] + 2*shifty;
+ y <- seq(from = starty, to = endy, length = nc);
+
+ points(x,y, bty="n", pch=15, col=rev(col), cex=2);
+
+ text(x[1], endy+shifty/8, "High");
+ text(x[1], starty-shifty/8, "Low");
+
+ par(op);
+}
+
+#'Plot PLS-DA classification performance using different components
+#'@description Plot plsda classification performance using different components
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotPLS.Classification <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ res <- mSetObj$analSet$plsda$fit.info;
+ colnames(res) <- 1:ncol(res);
+ best.num <- mSetObj$analSet$plsda$best.num;
+ choice <- mSetObj$analSet$plsda$choice;
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+
+ if(is.na(width)){
+ w <- 7;
+ }else if(width == 0){
+ w <- 7;
+ }else{
+ w <- width;
+ }
+ h <- w*5/7;
+
+ mSetObj$imgSet$pls.class <- imgName;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ par(mar=c(5,5,2,7)); # put legend on the right outside
+ barplot(res, beside = TRUE, col = c("lightblue", "mistyrose","lightcyan"), ylim= c(0,1.05), xlab="Number of components", ylab="Performance");
+
+ if(choice == "Q2"){
+ text((best.num-1)*3 + best.num + 2.5, res[3,best.num]+ 0.02, labels = "*", cex=2.5, col="red");
+ }else if(choice == "R2"){
+ text((best.num-1)*3 + best.num + 1.5, res[2,best.num]+ 0.02, labels = "*", cex=2.5, col="red");
+ }else{
+ text((best.num-1)*3 + best.num + 0.5, res[1,best.num]+ 0.02, labels = "*", cex=2.5, col="red");
+ }
+
+ # calculate the maximum y position, each bar is 1, place one space between the group
+ xpos <- ncol(res)*3 + ncol(res) + 1;
+ legend(xpos, 1.0, rownames(res), fill = c("lightblue", "mistyrose","lightcyan"), xpd=T);
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+
+#'Plot PLS-DA classification performance using different components, permutation
+#'@description Plot plsda classification performance using different components
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotPLS.Permutation <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ bw.vec <- mSetObj$analSet$plsda$permut;
+ len <- length(bw.vec);
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- 8;
+ }else if(width == 0){
+ w <- 7;
+ }else{
+ w <- width;
+ }
+ h <- w*6/8;
+
+ mSetObj$imgSet$pls.permut <- imgName;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ par(mar=c(5,5,2,4));
+ hst <- hist(bw.vec, breaks = "FD", freq=T,
+ ylab="Frequency", xlab= 'Permutation test statistics', col="lightblue", main="");
+
+ # add the indicator using original label
+ h <- max(hst$counts)
+ arrows(bw.vec[1], h/5, bw.vec[1], 0, col="red", lwd=2);
+ text(bw.vec[1], h/3.5, paste('Observed \n statistic \n', mSetObj$analSet$plsda$permut.p), xpd=T);
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+#'Perform OPLS-DA
+#'@description Orthogonal PLS-DA (from ropls)
+#'Add reg (regression i.e. if class order matters)
+#'@param mSetObj Input name of the created mSet Object
+#'@param reg Logical
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+OPLSR.Anal<-function(mSetObj=NA, reg=FALSE){
+ .prepare.oplsr.anal(mSetObj, reg);
+ .perform.computing();
+ .save.oplsr.anal(mSetObj);
+}
+
+.prepare.oplsr.anal <-function(mSetObj=NA, reg=FALSE){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ mSetObj$analSet$opls.reg <- reg;
+
+ # default options for feature labels on splot
+ mSetObj$custom.cmpds <- c();
+ mSetObj$analSet$oplsda$splot.type <- "all";
+
+ if(reg==TRUE){
+ cls<-scale(as.numeric(mSetObj$dataSet$cls))[,1];
+ }else{
+ cls<-model.matrix(~mSetObj$dataSet$cls-1);
+ }
+
+ datmat <- as.matrix(mSetObj$dataSet$norm);
+ cv.num <- min(7, dim(mSetObj$dataSet$norm)[1]-1);
+
+ my.fun <- function(){
+ if(!exists("perform_opls")){ # public web on same user dir
+ compiler::loadcmp("../../rscripts/metaboanalystr/stats_opls.Rc");
+ }
+ my.res <- perform_opls(dat.in$data, dat.in$cls, predI=1, permI=0, orthoI=NA, crossvalI=dat.in$cv.num);
+ return(my.res);
+ }
+
+ dat.in <- list(data=datmat, cls=cls, cv.num=cv.num, my.fun=my.fun);
+
+ qs::qsave(dat.in, file="dat.in.qs");
+ return(.set.mSet(mSetObj));
+}
+
+.save.oplsr.anal <- function(mSetObj = NA){
+ mSetObj <- .get.mSet(mSetObj);
+ dat.in <- qs::qread("dat.in.qs");
+ mSetObj$analSet$oplsda <- dat.in$my.res;
+ score.mat <- cbind(mSetObj$analSet$oplsda$scoreMN[,1], mSetObj$analSet$oplsda$orthoScoreMN[,1]);
+ colnames(score.mat) <- c("Score (t1)","OrthoScore (to1)");
+ fast.write.csv(signif(score.mat,5), row.names=rownames(mSetObj$dataSet$norm), file="oplsda_score.csv");
+ load.mat <- cbind(mSetObj$analSet$oplsda$loadingMN[,1], mSetObj$analSet$oplsda$orthoLoadingMN[,1]);
+ colnames(load.mat) <- c("Loading (t1)","OrthoLoading (to1)");
+ fast.write.csv(signif(load.mat,5), file="oplsda_loadings.csv");
+ return(.set.mSet(mSetObj));
+}
+
+#'Create OPLS-DA score plot
+#'@description Orthogonal PLS-DA (from ropls) score plot
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@param inx1 Numeric, indicate the number of the principal component for the x-axis of the loading plot.
+#'@param inx2 Numeric, indicate the number of the principal component for the y-axis of the loading plot.
+#'@param reg Numeric
+#'@param show Show variable labels, 1 or O
+#'@param grey.scale Numeric, indicate grey-scale, 0 for no, and 1 for yes
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotOPLS2DScore<-function(mSetObj=NA, imgName, format="png", dpi=72, width=NA, inx1, inx2, reg=0.95, show=1, grey.scale=0){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- 9;
+ }else if(width == 0){
+ w <- 7.2;
+
+ }else{
+ w <- width;
+ }
+ h <- w;
+
+ mSetObj$imgSet$opls.score2d <- imgName;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ par(mar=c(5,5,3,3));
+ lv1 <- mSetObj$analSet$oplsda$scoreMN[,1];
+ lv2 <- mSetObj$analSet$oplsda$orthoScoreMN[,1];
+ xlabel <- paste("T score [1]", "(", round(100*mSetObj$analSet$oplsda$modelDF["p1", "R2X"],1), "%)");
+ ylabel <- paste("Orthogonal T score [1]", "(", round(100*mSetObj$analSet$oplsda$modelDF["o1", "R2X"],1), "%)");
+
+ text.lbls <- substr(rownames(mSetObj$dataSet$norm),1,12) # some names may be too long
+
+ # obtain ellipse points to the scatter plot for each category
+ lvs <- levels(mSetObj$dataSet$cls);
+ pts.array <- array(0, dim=c(100,2,length(lvs)));
+ for(i in 1:length(lvs)){
+ inx <- mSetObj$dataSet$cls == lvs[i];
+ groupVar <- var(cbind(lv1[inx],lv2[inx]), na.rm=T);
+ groupMean <- cbind(mean(lv1[inx], na.rm=T),mean(lv2[inx], na.rm=T));
+ pts.array[,,i] <- ellipse::ellipse(groupVar, centre = groupMean, level = reg, npoints=100);
+ }
+
+ xrg <- range(lv1, pts.array[,1,]);
+ yrg <- range(lv2, pts.array[,2,]);
+ x.ext<-(xrg[2]-xrg[1])/12;
+ y.ext<-(yrg[2]-yrg[1])/12;
+ xlims<-c(xrg[1]-x.ext, xrg[2]+x.ext);
+ ylims<-c(yrg[1]-y.ext, yrg[2]+y.ext);
+
+ cols <- GetColorSchema(mSetObj$dataSet$cls, grey.scale==1);
+ uniq.cols <- unique(cols);
+
+ plot(lv1, lv2, xlab=xlabel, xlim=xlims, ylim=ylims, ylab=ylabel, type='n', main="Scores Plot");
+ grid(col = "lightgray", lty = "dotted", lwd = 1);
+
+ # make sure name and number of the same order DO NOT USE levels, which may be different
+ legend.nm <- unique(as.character(mSetObj$dataSet$cls));
+ ## uniq.cols <- unique(cols);
+
+ if (length(uniq.cols) > 1 ) {
+ names(uniq.cols) <- legend.nm;
+ }
+ # draw ellipse
+ for(i in 1:length(lvs)){
+ if ( length(uniq.cols) > 1) {
+ polygon(pts.array[,,i], col=adjustcolor(uniq.cols[lvs[i]], alpha=0.2), border=NA);
+ } else {
+ polygon(pts.array[,,i], col=adjustcolor(uniq.cols, alpha=0.2), border=NA);
+ }
+ if(grey.scale) {
+ lines(pts.array[,,i], col=adjustcolor("black", alpha=0.5), lty=2);
+ }
+ }
+
+ pchs <- GetShapeSchema(mSetObj, show, grey.scale);
+ if(grey.scale) {
+ cols <- rep("black", length(cols));
+ }
+ if(show==1){ # display sample name set on
+ text(lv1, lv2, label=text.lbls, pos=4, xpd=T, cex=0.75);
+ points(lv1, lv2, pch=pchs, col=cols);
+ }else{
+ if (length(uniq.cols) == 1) {
+ points(lv1, lv2, pch=pchs, col=cols, cex=1.0);
+ } else {
+ if(grey.scale == 1 | (exists("shapeVec") && all(shapeVec>=0))){
+ my.cols <- adjustcolor(cols, alpha.f = 0.4);
+ my.cols[pchs == 21] <- "black";
+ points(lv1, lv2, pch=pchs, col=my.cols, bg=adjustcolor(cols, alpha.f = 0.4), cex=1.8);
+ }else{
+ points(lv1, lv2, pch=21, bg=adjustcolor(cols, alpha.f = 0.4), cex=2);
+ }
+ }
+ }
+
+ uniq.pchs <- unique(pchs);
+ if(grey.scale) {
+ uniq.cols <- "black";
+ }
+ legend("topright", legend = legend.nm, pch=uniq.pchs, col=uniq.cols);
+
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+#'Update OPLS loadings
+#'@description Update the OPLS loadings
+#'@param mSetObj Input name of the created mSet Object
+#'@param plotType Set annotation type, "all" to label all variables and
+#'"none" to label no variables.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+UpdateOPLS.Splot<- function(mSetObj=NA, plotType){
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$analSet$oplsda$splot.type <- plotType;
+ mSetObj$custom.cmpds <- c();
+ return(.set.mSet(mSetObj));
+}
+
+#'S-plot for OPLS-DA
+#'@description Orthogonal PLS-DA (from ropls)
+#'S-plot for important features from OPLS-DA
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotOPLS.Splot <- function(mSetObj=NA, imgName, plotType="all", format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ s <- as.matrix(mSetObj$dataSet$norm);
+ T <- as.matrix(mSetObj$analSet$oplsda$scoreMN)
+ p1 <- c()
+ for (i in 1:ncol(s)) {
+ scov <- cov(s[,i], T)
+ p1 <- matrix(c(p1, scov), ncol=1)
+ }
+ pcorr1 <- c()
+ for (i in 1:nrow(p1)) {
+ den <- apply(T, 2, sd)*sd(s[,i])
+ corr1 <- p1[i,]/den
+ pcorr1 <- matrix(c(pcorr1, corr1), ncol=1)
+ }
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- h <- 8;
+ }else if(width == 0){
+
+ }else{
+ w <- h <- width;
+ }
+
+ mSetObj$imgSet$opls.loading<-imgName;
+ mSetObj$analSet$oplsda$splot.type <- plotType;
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ par(mar=c(5,5,4,7))
+ plot(p1, pcorr1, type="n", xlab="p[1]", ylab ="p(corr)[1]", main = "Feature Importance");
+ grid(col="lightgrey", lty=3, lwd = 1);
+ points(p1, pcorr1, pch=19, col=adjustcolor("magenta", alpha.f = 0.4));
+ opls.axis.lims <- par("usr");
+ if(plotType=="all"){
+ text(p1, pcorr1, labels=colnames(s), cex=0.8, pos=4, xpd=TRUE, col="blue");
+ }else if(plotType == "custom"){
+ if(length(mSetObj$custom.cmpds) > 0){
+ hit.inx <- colnames(mSetObj$dataSet$norm) %in% mSetObj$custom.cmpds;
+ text(p1[hit.inx], pcorr1[hit.inx], labels=colnames(s)[hit.inx], pos=4, xpd=TRUE, col="blue");
+ }
+ }else{
+ # do nothing
+ }
+ dev.off();
+ splot.mat <- cbind(jitter(p1),p1, pcorr1);
+ rownames(splot.mat) <- colnames(s);
+ colnames(splot.mat) <- c("jitter", "p[1]","p(corr)[1]");
+
+ ord.inx <- order(-splot.mat[,2], -splot.mat[,3]);
+ splot.mat <- signif(splot.mat[ord.inx,],5);
+
+ fast.write.csv(signif(splot.mat[,2:3],5), file="oplsda_splot.csv");
+ mSetObj$analSet$oplsda$splot.mat <- splot.mat;
+ mSetObj$analSet$oplsda$opls.axis.lims <- opls.axis.lims;
+ return(.set.mSet(mSetObj));
+}
+
+#'Plot loading compounds
+#'@description Plot loading compounds
+#'@param mSetObj Input name of the created mSet Object
+#'@param cmpdNm Input the name of the selected compound
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@export
+#'
+PlotLoadingCmpd<-function(mSetObj=NA, cmpdNm, format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # need to record the clicked compounds
+ mSetObj$custom.cmpds <- c(mSetObj$custom.cmpds, cmpdNm);
+ .set.mSet(mSetObj);
+
+ return(PlotCmpdView(mSetObj, cmpdNm, format, dpi, width));
+}
+
+#'Plot OPLS
+#'@description Plot OPLS
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@export
+#'
+PlotOPLS.MDL <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- 9;
+ }else if(width == 0){
+ w <- 9;
+
+ }else{
+ w <- width;
+ }
+ h <- w*6/9;
+
+ mSetObj$imgSet$opls.class <- imgName;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ # the model R2Y and Q2Y
+ par(mar=c(5,5,4,8)); # put legend on the right outside
+ modBarDF <- mSetObj$analSet$oplsda$modelDF[!(rownames(mSetObj$analSet$oplsda$modelDF) %in% c("rot")), ];
+ mod.dat <- data.matrix(modBarDF[!rownames(modBarDF)%in% ("sum"), c("R2X", "R2Y", "Q2")]);
+ mod.dat <- t(mod.dat);
+ bplt <- barplot(mod.dat,beside=TRUE, names.arg = colnames(mod.dat),xlab = "");
+ axis(2, lwd.ticks=1);
+ barplot(mod.dat,add = TRUE, beside = TRUE, col = c("lightblue", "mistyrose", "lavender"));
+ text(x=bplt, y=mod.dat+max(mod.dat)/25, labels=as.character(mod.dat), xpd=TRUE)
+ xpos <- nrow(mod.dat)*ncol(mod.dat) + ncol(mod.dat) + 0.5
+ ypos <- max(mod.dat)/2;
+ legend(xpos, ypos, legend = c("R2X", "R2Y", "Q2"), pch=15, col=c("lightblue", "mistyrose", "lavender"), xpd=T, bty="n");
+ dev.off();
+
+ fast.write.csv(mod.dat, file="oplsda_model.csv");
+
+ return(.set.mSet(mSetObj));
+}
+
+#'Perform OPLS-DA permutation
+#'@description Orthogonal PLS-DA (from ropls)
+#'perform permutation, using training classification accuracy as
+#'indicator, for two or multi-groups
+#'@param mSetObj Input name of the created mSet Object
+#'@param num Input the number of permutations, default is set to 100.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+OPLSDA.Permut<-function(mSetObj=NA, num=100){
+ .prepare.oplsda.permut(mSetObj, num);
+ .perform.computing();
+ .save.oplsda.permut(mSetObj);
+}
+
+.prepare.oplsda.permut <-function(mSetObj=NA, num=100){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(mSetObj$analSet$opls.reg){
+ cls<-scale(as.numeric(mSetObj$dataSet$cls))[,1];
+ }else{
+ cls<-model.matrix(~mSetObj$dataSet$cls-1);
+ }
+
+ datmat <- as.matrix(mSetObj$dataSet$norm);
+ cv.num <- min(7, dim(mSetObj$dataSet$norm)[1]-1);
+ my.fun <- function(){
+ if(!exists("perform_opls")){ # public web on same user dir
+ compiler::loadcmp("../../rscripts/metaboanalystr/stats_opls.Rc");
+ }
+ my.res <- perform_opls(dat.in$data, dat.in$cls, predI=1, permI=dat.in$perm.num, orthoI=NA, crossvalI=dat.in$cv.num);
+ }
+ dat.in <- list(data=datmat, cls=cls, perm.num=num, cv.num=cv.num, my.fun=my.fun);
+
+ qs::qsave(dat.in, file="dat.in.qs");
+ return(.set.mSet(mSetObj));
+}
+
+.save.oplsda.permut <- function(mSetObj = NA){
+ mSetObj <- .get.mSet(mSetObj);
+ dat.in <- qs::qread("dat.in.qs");
+ my.res <- dat.in$my.res;
+
+ r.vec <- my.res$suppLs[["permMN"]][, "R2Y(cum)"];
+ q.vec <- my.res$suppLs[["permMN"]][, "Q2(cum)"];
+
+ # note, actual permutation number may be adjusted in public server
+ perm.num <- my.res$suppLs[["permI"]];
+
+ mSetObj$analSet$oplsda$perm.res <- list(r.vec=r.vec, q.vec=q.vec, perm.num=perm.num);
+ return(.set.mSet(mSetObj));
+}
+
+#'Plot OPLS-DA permutation
+#'@description Orthogonal PLS-DA (from ropls)
+#'perform permutation, using training classification accuracy as
+#'indicator, for two or multi-groups
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+PlotOPLS.Permutation<-function(mSetObj=NA, imgName, format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ perm.res <- mSetObj$analSet$oplsda$perm.res;
+
+ r.vec <- perm.res$r.vec;
+ q.vec <- perm.res$q.vec;
+ perm.num <- perm.res$perm.num;
+
+ better.rhits <- sum(r.vec[-1]>=r.vec[1]);
+
+ if(better.rhits == 0) {
+ pr <- paste("p < ", 1/perm.num, " (", better.rhits, "/", perm.num, ")", sep="");
+ }else{
+ p <- better.rhits/perm.num;
+ pr <- paste("p = ", signif(p, digits=5), " (", better.rhits, "/", perm.num, ")", sep="");
+ }
+ better.qhits <- sum(q.vec[-1]>=q.vec[1]);
+ if(better.qhits == 0) {
+ pq <- paste("p < ", 1/perm.num, " (", better.qhits, "/", perm.num, ")", sep="");
+ }else{
+ p <- better.qhits/perm.num;
+ pq <- paste("p = ", signif(p, digits=5), " (", better.qhits, "/", perm.num, ")", sep="");
+ }
+
+ rng <- range(c(r.vec, q.vec, 1));
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- 8;
+ }else if(width == 0){
+ w <- 8;
+ }else{
+ w <- width;
+ }
+ h <- w*6/8;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ par(mar=c(5,5,2,7));
+ rhst <- hist(r.vec[-1], plot=FALSE);
+ qhst <- hist(q.vec[-1], plot=FALSE);
+ h <- max(c(rhst$counts, qhst$counts))+1;
+ bin.size <- min(c(rhst$breaks[2]-rhst$breaks[1], qhst$breaks[2]-qhst$breaks[1]));
+ rbins <- seq(min(rhst$breaks),max(rhst$breaks),bin.size);
+ qbins <- seq(min(qhst$breaks),max(qhst$breaks),bin.size);
+ hist(r.vec[-1], xlim=rng, ylim=c(0, h), breaks=rbins, border=F, ylab="Frequency", xlab= 'Permutations',
+ col=adjustcolor("lightblue", alpha=0.6), main="");
+ hist(q.vec[-1], add=TRUE,breaks=qbins, border=F, col=adjustcolor("mistyrose", alpha=0.6));
+
+ arrows(r.vec[1], h/3, r.vec[1], 0, length=0.1,angle=30,lwd=2);
+ text(r.vec[1], h/2.5, paste('R2Y:', r.vec[1], "\n", pr), xpd=TRUE);
+
+ arrows(q.vec[1], h/2, q.vec[1], 0, length=0.1,angle=30,lwd=2);
+ text(q.vec[1], h/1.8, paste('Q2:', q.vec[1], "\n", pq), xpd=TRUE);
+
+ legend(1, h/3, legend = c("Perm R2Y", "Perm Q2"), pch=15, col=c("lightblue", "mistyrose"), xpd=T, bty="n");
+
+ dev.off();
+
+ mSetObj$imgSet$opls.permut <- imgName;
+
+ msg <- paste("Empirical p-values Q2: ", pq, " and R2Y: ", pr);
+ if(.on.public.web){
+ .set.mSet(mSetObj)
+ return(msg);
+ }else{
+ print(msg);
+ return(.set.mSet(mSetObj));
+ }
+}
+
+#'Perform SPLS-DA
+#'@description Sparse PLS-DA (from mixOmics)
+#'@param mSetObj Input name of the created mSet Object
+#'@param comp.num Input the number of computations to run
+#'@param var.num Input the number of variables
+#'@param compVarOpt Input the option to perform SPLS-DA
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+SPLSR.Anal <- function(mSetObj=NA, comp.num, var.num, compVarOpt, validOpt="Mfold"){
+ .prepare.splsr.anal(mSetObj, comp.num, var.num, compVarOpt, validOpt);
+ .perform.computing();
+ .save.splsr.anal(mSetObj);
+}
+
+.prepare.splsr.anal <- function(mSetObj=NA, comp.num, var.num, compVarOpt, validOpt="Mfold"){
+
+ if(compVarOpt == "same"){
+ comp.var.nums <- rep(var.num, comp.num);
+ }else{
+ if(exists("comp.var.nums") && all(comp.var.nums > 0)){
+ comp.var.nums <- ceiling(comp.var.nums);
+ }else{
+ msg <- c("All values need to be positive integers!");
+ return(0);
+ }
+ }
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # note, standardize the cls, to minimize the impact of categorical to numerical impact
+ cls <- scale(as.numeric(mSetObj$dataSet$cls))[,1];
+ datmat <- as.matrix(mSetObj$dataSet$norm);
+
+ my.fun <- function(){
+ if(!exists("splsda")){ # public web on same user dir
+ compiler::loadcmp("../../rscripts/metaboanalystr/stats_spls.Rc");
+ }
+ my.res <- splsda(dat.in$data, dat.in$cls, ncomp=dat.in$comp.num, keepX=dat.in$comp.var.nums);
+
+ # perform validation
+ perf.res <- perf.splsda(my.res, dist= "centroids.dist", validation=validOpt, folds = 5);
+ my.res$error.rate <- perf.res$error.rate$overall;
+ return(my.res);
+ }
+
+ dat.in <- list(data=datmat, cls=cls, comp.num=comp.num, comp.var.nums=comp.var.nums, my.fun=my.fun);
+
+ qs::qsave(dat.in, file="dat.in.qs");
+ return(.set.mSet(mSetObj));
+}
+
+.save.splsr.anal <- function(mSetObj = NA){
+ mSetObj <- .get.mSet(mSetObj);
+ dat.in <- qs::qread("dat.in.qs");
+ mSetObj$analSet$splsr <- dat.in$my.res;
+ score.mat <- mSetObj$analSet$splsr$variates$X;
+ fast.write.csv(signif(score.mat,5), row.names=rownames(mSetObj$dataSet$norm), file="splsda_score.csv");
+ load.mat <- mSetObj$analSet$splsr$loadings$X;
+
+ # sort based on absolute values of 1, 2
+ ord.inx <- order(-abs(load.mat[,1]), -abs(load.mat[,2]));
+ load.mat <- signif(load.mat[ord.inx,],5);
+ fast.write.csv(load.mat, file="splsda_loadings.csv");
+
+ mSetObj$analSet$splsr$loadings$X <- load.mat;
+ return(.set.mSet(mSetObj));
+}
+
+#'Plot SPLS-DA
+#'@description Sparse PLS-DA (from mixOmics) pairwise summary plot
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@param pc.num Numeric, indicate the number of principle components
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotSPLSPairSummary<-function(mSetObj=NA, imgName, format="png", dpi=72, width=NA, pc.num){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- 9;
+ }else if(width == 0){
+ w <- 7.2;
+ }else{
+ w <- width;
+ }
+ h <- w;
+
+ mSetObj$imgSet$spls.pair <- imgName;
+
+ if(pc.num > mSetObj$analSet$splsr$ncomp){
+ pc.num <- mSetObj$analSet$splsr$ncomp;
+ }
+ vars <- round(100*mSetObj$analSet$splsr$explained_variance$X,1);
+ my.data <- mSetObj$analSet$splsr$variates$X[,1:pc.num];
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ pclabels <- paste("Component", 1:pc.num, "\n", vars, "%");
+ ellipse::pairs(my.data, col=GetColorSchema(mSetObj$dataSet$cls), pch=as.numeric(mSetObj$dataSet$cls)+1, labels=pclabels)
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+#'Score Plot SPLS-DA
+#'@description Sparse PLS-DA (from mixOmics) score plot
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@param inx1 Numeric, indicate the number of the principal component for the x-axis of the loading plot.
+#'@param inx2 Numeric, indicate the number of the principal component for the y-axis of the loading plot.
+#'@param reg Numeric, between 1 and 0
+#'@param show Numeric, 1 or 0
+#'@param grey.scale Numeric, use grey-scale, 0 for no, and 1 for yes.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotSPLS2DScore <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA, inx1, inx2, reg=0.95, show=1, grey.scale=0){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- 9;
+ }else if(width == 0){
+ w <- 7.2;
+ }else{
+ w <- width;
+ }
+ h <- w;
+
+ mSetObj$imgSet$spls.score2d <- imgName;
+
+ lv1 <- mSetObj$analSet$splsr$variates$X[,inx1];
+ lv2 <- mSetObj$analSet$splsr$variates$X[,inx2];
+ xlabel <- paste("Component", inx1, "(", round(100*mSetObj$analSet$splsr$explained_variance$X[inx1],1), "%)");
+ ylabel <- paste("Component", inx2, "(", round(100*mSetObj$analSet$splsr$explained_variance$X[inx2],1), "%)");
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ par(mar=c(5,5,3,3));
+ text.lbls <- substr(rownames(mSetObj$dataSet$norm),1,12) # some names may be too long
+
+ # obtain ellipse points to the scatter plot for each category
+
+ if(mSetObj$dataSet$type.cls.lbl=="integer"){
+ cls <- as.factor(as.numeric(levels(mSetObj$dataSet$cls))[mSetObj$dataSet$cls]);
+ }else{
+ cls <- mSetObj$dataSet$cls;
+ }
+
+ lvs <- levels(cls);
+ pts.array <- array(0, dim=c(100,2,length(lvs)));
+ for(i in 1:length(lvs)){
+ inx <- mSetObj$dataSet$cls == lvs[i];
+ groupVar <- var(cbind(lv1[inx],lv2[inx]), na.rm=T);
+ groupMean <- cbind(mean(lv1[inx], na.rm=T),mean(lv2[inx], na.rm=T));
+ pts.array[,,i] <- ellipse::ellipse(groupVar, centre = groupMean, level = reg, npoints=100);
+ }
+
+ xrg <- range(lv1, pts.array[,1,]);
+ yrg <- range(lv2, pts.array[,2,]);
+ x.ext <- (xrg[2]-xrg[1])/12;
+ y.ext <- (yrg[2]-yrg[1])/12;
+ xlims <- c(xrg[1]-x.ext, xrg[2]+x.ext);
+ ylims <- c(yrg[1]-y.ext, yrg[2]+y.ext);
+
+ cols <- GetColorSchema(mSetObj$dataSet$cls, grey.scale==1);
+ uniq.cols <- unique(cols);
+
+ plot(lv1, lv2, xlab=xlabel, xlim=xlims, ylim=ylims, ylab=ylabel, type='n', main="Scores Plot");
+ grid(col = "lightgray", lty = "dotted", lwd = 1);
+
+ # make sure name and number of the same order DO NOT USE levels, which may be different
+ legend.nm <- unique(as.character(sort(cls)));
+ ## uniq.cols <- unique(cols);
+
+ ## BHAN: when same color is choosen for black/white; it makes an error
+ # names(uniq.cols) <- legend.nm;
+ if (length(uniq.cols) > 1) {
+ names(uniq.cols) <- legend.nm;
+ }
+ # draw ellipse
+ for(i in 1:length(lvs)){
+ if (length(uniq.cols) > 1) {
+ polygon(pts.array[,,i], col=adjustcolor(uniq.cols[lvs[i]], alpha=0.25), border=NA);
+ } else {
+ polygon(pts.array[,,i], col=adjustcolor(uniq.cols, alpha=0.25), border=NA);
+ }
+ if(grey.scale) {
+ lines(pts.array[,,i], col=adjustcolor("black", alpha=0.5), lty=2);
+ }
+ }
+
+ pchs <- GetShapeSchema(mSetObj, show, grey.scale);
+ if(grey.scale) {
+ cols <- rep("black", length(cols));
+ }
+ if(show==1){ # display sample name set on
+ text(lv1, lv2, label=text.lbls, pos=4, xpd=T, cex=0.75);
+ points(lv1, lv2, pch=pchs, col=cols);
+ }else{
+ if (length(uniq.cols) == 1) {
+ points(lv1, lv2, pch=pchs, col=cols, cex=1.0);
+ } else {
+ if(grey.scale == 1 | (exists("shapeVec") && all(shapeVec>=0))){
+ my.cols <- adjustcolor(cols, alpha.f = 0.4);
+ my.cols[pchs == 21] <- "black";
+ points(lv1, lv2, pch=pchs, col=my.cols, bg=adjustcolor(cols, alpha.f = 0.4), cex=1.8);
+ }else{
+ points(lv1, lv2, pch=21, bg=adjustcolor(cols, alpha.f = 0.4), cex=2);
+ }
+ }
+ }
+
+ uniq.pchs <- unique(pchs);
+ if(grey.scale) {
+ uniq.cols <- "black";
+ }
+ legend("topright", legend = legend.nm, pch=uniq.pchs, col=uniq.cols);
+
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+#'3D SPLS-DA score plot
+#'@description Sparse PLS-DA (from mixOmics) 3D score plot
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param inx1 Numeric, indicate the number of the principal component for the x-axis of the loading plot.
+#'@param inx2 Numeric, indicate the number of the principal component for the y-axis of the loading plot.
+#'@param inx3 Numeric, indicate the number of the principal component for the z-axis of the loading plot.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotSPLS3DScore <- function(mSetObj=NA, imgName, format="json", inx1=1, inx2=2, inx3=3){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ spls3d <- list();
+ # need to check if only two components are generated
+ if(length(mSetObj$analSet$splsr$explained_variance$X)==2){
+ spls3d$score$axis <- paste("Component", c(inx1, inx2), " (", round(100*mSetObj$analSet$splsr$explained_variance$X[c(inx1, inx2)], 1), "%)", sep="");
+ coords <- data.frame(t(signif(mSetObj$analSet$splsr$variates$X[,c(inx1, inx2)], 5)));
+ spls3d$score$axis <- c(spls3d$score$axis, "Component3 (NA)");
+ coords <- rbind(coords, "comp 3"=rep (0, ncol(coords)));
+ }else{
+ spls3d$score$axis <- paste("Component", c(inx1, inx2, inx3), " (", round(100*mSetObj$analSet$splsr$explained_variance$X[c(inx1, inx2, inx3)], 1), "%)", sep="");
+ coords <- data.frame(t(signif(mSetObj$analSet$splsr$variates$X[,c(inx1, inx2, inx3)], 5)));
+ }
+ colnames(coords) <- NULL;
+ spls3d$score$xyz <- coords;
+ spls3d$score$name <- rownames(mSetObj$dataSet$norm);
+
+ if(mSetObj$dataSet$type.cls.lbl=="integer"){
+ cls <- as.character(sort(as.factor(as.numeric(levels(mSetObj$dataSet$cls))[mSetObj$dataSet$cls])));
+ }else{
+ cls <- as.character(mSetObj$dataSet$cls);
+ }
+
+ if(all.numeric(cls)){
+ cls <- paste("Group", cls);
+ }
+ spls3d$score$facA <- cls;
+
+ # now set color for each group
+ cols <- unique(GetColorSchema(mSetObj$dataSet$cls));
+ spls3d$score$colors <- my.col2rgb(cols);
+
+ imgName = paste(imgName, ".", format, sep="");
+ json.obj <- RJSONIO::toJSON(spls3d, .na='null');
+ sink(imgName);
+ cat(json.obj);
+ sink();
+ mSetObj$imgSet$spls.score3d <- imgName;
+ return(.set.mSet(mSetObj));
+}
+
+#'@export
+PlotSPLS3DLoading <- function(mSetObj=NA, imgName, format="json", inx1, inx2, inx3){
+ mSetObj <- .get.mSet(mSetObj);
+ spls = mSetObj$analSet$splsr
+ spls3d <- list();
+
+ if(length(mSetObj$analSet$splsr$explained_variance$X)==2){
+ spls3d$loading$axis <- paste("Loading ", c(inx1, inx2), sep="");
+ coords <- data.frame(t(signif(mSetObj$analSet$splsr$loadings$X[,c(inx1, inx2)], 5)));
+ spls3d$loading$axis <- c(spls3d$loading$axis, "Loading 3");
+ coords <- rbind(coords, "comp 3"=rep (0, ncol(coords)));
+ }else{
+ spls3d$loading$axis <- paste("Loading ", c(inx1, inx2, inx3), sep="");
+ coords <- data.frame(t(signif(mSetObj$analSet$splsr$loadings$X[,c(inx1, inx2, inx3)], 5)));
+ }
+
+ colnames(coords) <- NULL;
+ spls3d$loading$xyz <- coords;
+ spls3d$loading$name <- rownames(spls$loadings$X);
+ spls3d$loading$entrez <-rownames(spls$loadings$X);
+
+ if(mSetObj$dataSet$type.cls.lbl=="integer"){
+ cls <- as.character(sort(as.factor(as.numeric(levels(mSetObj$dataSet$cls))[mSetObj$dataSet$cls])));
+ }else{
+ cls <- as.character(mSetObj$dataSet$cls);
+ }
+
+ if(all.numeric(cls)){
+ cls <- paste("Group", cls);
+ }
+
+ spls3d$cls = cls;
+ # see if there is secondary
+
+ require(RJSONIO);
+ imgName = paste(imgName, ".", format, sep="");
+ json.mat <- RJSONIO::toJSON(spls3d, .na='null');
+ sink(imgName);
+ cat(json.mat);
+ sink();
+ current.msg <<- "Annotated data is now ready for PCA 3D visualization!";
+
+ if(.on.public.web){
+ return(1);
+ }else{
+ return(.set.mSet(mSetObj));
+ }
+
+}
+
+
+#'Create SPLS-DA loading plot
+#'@description Sparse PLS-DA (from mixOmics) loading plot
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@param inx Input the model index
+#'@param viewOpt Detailed view "detail"
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotSPLSLoading <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA, inx, viewOpt="detail"){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ imp.vec <- abs(mSetObj$analSet$splsr$loadings$X[,inx]);
+ imp.vec <- imp.vec[imp.vec > 0];
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- 8;
+ }else if(width == 0){
+ w <- 7;
+
+ }else{
+ w <- width;
+ }
+ h <- w;
+
+ mSetObj$imgSet$spls.imp <- imgName;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ PlotImpVar(mSetObj, imp.vec, paste ("Loadings", inx), 999, FALSE);
+ dev.off();
+
+ return(.set.mSet(mSetObj));
+}
+
+#'Create SPLS-DA classification plot
+#'@description Sparse PLS-DA (from mixOmics) plot of
+#'classification performance using different components
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param validOpt "Mfold"
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'@import caret
+PlotSPLSDA.Classification <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ res <- mSetObj$analSet$splsr$error.rate;
+
+ edge <- (max(res)-min(res))/100; # expand y uplimit for text
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- 8;
+ }else if(width == 0){
+ w <- 7;
+ }else{
+ w <- width;
+ }
+ h <- w*6/8;
+
+ mSetObj$imgSet$splsda.class <- imgName;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ plot(res, type='l', xlab='Number of Components', ylab='Error Rate',
+ ylim = c(min(res)-5*edge, max(res)+18*edge), axes=F,
+ main="Sparse PLS-DA Classification Error Rates")
+ text(res, labels = paste(100*round(res,3),'%'), adj=c(-0.3, -0.5), srt=45, xpd=T)
+ axis(2);
+ axis(1, 1:length(res), names(res));
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+##############################################
+##############################################
+########## Utilities for web-server ##########
+##############################################
+##############################################
+
+# get which number of components give best performance
+GetPLSBestTune<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ if(is.null(mSetObj$analSet$plsda$best.num)){
+ return(0);
+ }
+ mSetObj$analSet$plsda$best.num;
+}
+
+# obtain VIP score
+GetPLSSigMat<-function(mSetObj=NA, type){
+ mSetObj <- .get.mSet(mSetObj);
+ if(type == "vip"){
+ sig.mat <- mSetObj$analSet$plsda$vip.mat;
+ }else if(type == "coef"){
+ sig.mat <- mSetObj$analSet$plsda$coef.mat;
+ }else{
+ sig.mat <- mSetObj$analSet$plsr$imp.loads;
+ }
+ return(CleanNumber(signif(as.matrix(sig.mat),5)));
+}
+
+GetPLSSigRowNames<-function(mSetObj=NA, type){
+ mSetObj <- .get.mSet(mSetObj);
+ if(type == "vip"){
+ return(rownames(mSetObj$analSet$plsda$vip.mat));
+ }else if(type == "coef"){
+ return(rownames(mSetObj$analSet$plsda$coef.mat));
+ }else{
+ return(rownames(mSetObj$analSet$plsr$imp.loads))
+ }
+}
+
+GetPLSSigColNames<-function(mSetObj=NA, type){
+ mSetObj <- .get.mSet(mSetObj);
+ if(type == "vip"){
+ return(colnames(mSetObj$analSet$plsda$vip.mat));
+ }else if(type == "coef"){
+ return(colnames(mSetObj$analSet$plsda$coef.mat));
+ }else{
+ return(colnames(mSetObj$analSet$plsr$imp.loads));
+ }
+}
+
+GetPLS_CVRowNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ rownames(mSetObj$analSet$plsda$fit.info);
+}
+
+GetPLS_CVColNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ colnames(mSetObj$analSet$plsda$fit.info);
+}
+
+GetPLS_CVMat<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(signif(mSetObj$analSet$plsda$fit.info, 5));
+}
+
+GetMaxPLSPairComp<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(min(dim(mSetObj$dataSet$norm)[1]-1, dim(mSetObj$dataSet$norm)[2]));
+}
+
+GetMaxPLSCVComp<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(min(dim(mSetObj$dataSet$norm)[1]-2, dim(mSetObj$dataSet$norm)[2]));
+}
+
+GetDefaultPLSPairComp<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(min(5, dim(mSetObj$dataSet$norm)[1]-1, dim(mSetObj$dataSet$norm)[2]));
+}
+
+GetDefaultPLSCVComp<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(min(5, dim(mSetObj$dataSet$norm)[1]-2, dim(mSetObj$dataSet$norm)[2], mSetObj$dataSet$min.grp.size));
+}
+
+GetPLSLoadAxesSpec<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$pls.axis.lims;
+}
+
+GetPLSLoadCmpds <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ rownames(mSetObj$analSet$plsr$imp.loads);
+}
+
+GetPLSLoadMat <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ as.matrix(mSetObj$analSet$plsr$imp.loads[,c(1:2)]);
+}
+
+GetPCALoadAxesSpec <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$pca.axis.lims;
+}
+
+GetPCALoadCmpds <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ rownames(mSetObj$analSet$pca$imp.loads);
+}
+
+GetPCALoadMat <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ as.matrix(mSetObj$analSet$pca$imp.loads[,c(1:2)]);
+}
+
+#'For plotting PCA, selects max top 9 components
+#'@description Rotate PCA analysis
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'
+GetMaxPCAComp <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(min(9, dim(mSetObj$dataSet$norm)-1));
+}
+
+GetOPLSLoadAxesSpec <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$analSet$oplsda$opls.axis.lims);
+}
+
+GetOPLSLoadCmpds <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ rownames(mSetObj$analSet$oplsda$splot.mat);
+}
+
+GetOPLSLoadColNames <- function(mSetObj=NA){
+ return(c("p[1]","p(corr)[1]"));
+}
+
+GetOPLSLoadMat <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ as.matrix(mSetObj$analSet$oplsda$splot.mat[,c(1,3)]);
+}
+
+GetDefaultSPLSCVComp <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return (min(5, dim(mSetObj$dataSet$norm)[1]-2, dim(mSetObj$dataSet$norm)[2], mSetObj$dataSet$min.grp.size));
+}
+
+GetDefaultSPLSPairComp <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return (min(5, dim(mSetObj$dataSet$norm)[1]-1, dim(mSetObj$dataSet$norm)[2]));
+}
+
+GetSPLS_CVRowNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ rownames(mSetObj$analSet$splsda$fit.info);
+}
+
+GetSPLS_CVColNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ colnames(mSetObj$analSet$splsda$fit.info);
+}
+
+GetSPLS_CVMat <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(signif(mSetObj$analSet$splsda$fit.info, 5));
+}
+
+GetSPLSLoadAxesSpec <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$pls.axis.lims;
+}
+
+GetSPLSLoadCmpds <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ rownames(mSetObj$analSet$splsr$loadings$X);
+}
+
+GetSPLSLoadMat <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ as.matrix(signif(mSetObj$analSet$splsr$loadings$X, 5));
+}
+
+GetSPLSSigColNames <- function(mSetObj=NA, type){
+ mSetObj <- .get.mSet(mSetObj);
+ if(type == "vip"){
+ return (colnames(mSetObj$analSet$splsda$vip.mat));
+ }else if(type == "coef"){
+ return (colnames(mSetObj$analSet$splsda$coef.mat));
+ }else{
+ return (colnames(mSetObj$analSet$splsr$loadings$X));
+ }
+}
+
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/stats_classification.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/stats_classification.R
new file mode 100755
index 0000000000000000000000000000000000000000..7c5ce8c75704e2f37b636fba4ea51d8f3a3f8452
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/stats_classification.R
@@ -0,0 +1,633 @@
+#'Perform Random Forest Analysis
+#'@description Perform Random Forest
+#'@param mSetObj Input name of the created mSet Object
+#'@param treeNum Input the number of trees to create, default is set to 500
+#'@param tryNum Set number of tries, default is 7
+#'@param randomOn Set random, default is 1
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+RF.Anal <- function(mSetObj=NA, treeNum=500, tryNum=7, randomOn=1){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # set up random numbers
+ if(is.null(mSetObj$dataSet$random.seeds)){
+ mSetObj$dataSet$random.seeds <- GetRandomNumbers();
+ mSetObj$dataSet$cur.inx <- 0;
+ mSetObj$dataSet$rn.seed <- mSetObj$dataSet$random.seeds[1];
+ }
+
+ if(randomOn == -1){
+ rn.sd <- 123456;
+ }else if(randomOn == 0){ # keep current
+ rn.sd <- mSetObj$dataSet$rn.seed;
+ }else{ # random on
+ cur.inx <- mSetObj$dataSet$cur.inx + 1;
+ rn.sd <- mSetObj$dataSet$random.seeds[cur.inx];
+ mSetObj$dataSet$cur.inx <- cur.inx;
+ }
+ set.seed(rn.sd);
+ # save the
+ mSetObj$dataSet$rn.seed <- rn.sd;
+
+ rf_out <- randomForest::randomForest(mSetObj$dataSet$norm, mSetObj$dataSet$cls, ntree = treeNum, mtry = tryNum, importance = TRUE, proximity = TRUE);
+
+ # set up named sig table for display
+ impmat <- rf_out$importance;
+ impmat <- impmat[rev(order(impmat[,"MeanDecreaseAccuracy"])),]
+ sigmat <- impmat[,"MeanDecreaseAccuracy", drop=F];
+ sigmat <- signif(sigmat, 5);
+
+ fast.write.csv(sigmat, file="randomforests_sigfeatures.csv");
+ mSetObj$analSet$rf <- rf_out;
+ mSetObj$analSet$rf.sigmat <- sigmat;
+ return(.set.mSet(mSetObj));
+}
+
+GetRandomNumbers <- function(){
+ rm(.Random.seed);
+ runif(1);
+ return(.Random.seed[3:626]);
+}
+
+#'Plot Random Forest
+#'@description Random Forest plot
+#'@usage PlotRF.Classify(mSetObj, imgName, format, dpi, width)
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotRF.Classify <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+
+ if(is.na(width)){
+ w <- 8;
+ }else if(width == 0){
+ w <- 8;
+ }else{
+ w <- width;
+ }
+ h <- w*5/8;
+
+ mSetObj$imgSet$rf.cls <- imgName;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ #par(mfrow=c(2,1));
+ par(mar=c(4,4,3,2));
+ cols <- rainbow(length(levels(mSetObj$dataSet$cls))+1);
+ plot(mSetObj$analSet$rf, main="Random Forest classification", col=cols);
+
+ if(mSetObj$dataSet$type.cls.lbl=="integer"){
+ cls <- as.factor(as.numeric(levels(mSetObj$dataSet$cls))[mSetObj$dataSet$cls]);
+ }else{
+ cls <- mSetObj$dataSet$cls;
+ }
+
+ legend("topright", legend = c("Overall", levels(cls)), lty=2, lwd=1, col=cols);
+
+ #PlotConfusion(analSet$rf$confusion);
+
+ dev.off();
+ return(.set.mSet(mSetObj));
+
+}
+
+#'Plot Random Forest variable importance
+#'@description Random Forest plot of variable importance ranked by MeanDecreaseAccuracy
+#'@usage PlotRF.VIP(mSetObj=NA, imgName, format, dpi, width)
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotRF.VIP <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ vip.score <- rev(sort(mSetObj$analSet$rf$importance[,"MeanDecreaseAccuracy"]));
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- 8;
+ }else if(width == 0){
+ w <- 7;
+
+ }else{
+ w <- width;
+ }
+ h <- w*7/8;
+ mSetObj$imgSet$rf.imp <- imgName;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ PlotImpVar(mSetObj, vip.score, "MeanDecreaseAccuracy");
+ dev.off();
+
+ return(.set.mSet(mSetObj));
+}
+
+#'Plot Random Forest outliers
+#'@description Random Forest plot of outliers
+#'@usage PlotRF.Outlier(mSetObj=NA, imgName, format="png", dpi=72, width=NA)
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotRF.Outlier <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(mSetObj$dataSet$type.cls.lbl=="integer"){
+ cls <- as.factor(as.numeric(levels(mSetObj$dataSet$cls))[mSetObj$dataSet$cls]);
+ }else{
+ cls <- mSetObj$dataSet$cls;
+ }
+ cols <- GetColorSchema(cls);
+ uniq.cols <- unique(cols);
+
+ legend.nm <- unique(as.character(sort(cls)));
+ dist.res <- randomForest::outlier(mSetObj$analSet$rf);
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- 9;
+ }else if(width == 0){
+ w <- 7.2;
+ }else{
+ w <- width;
+ }
+ h <- w*7/9;
+
+ mSetObj$imgSet$rf.outlier <- imgName;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ layout(matrix(c(1,2), 1, 2, byrow = TRUE), width=c(4,1));
+
+ op <- par(mar=c(5,5,4,0));
+ plot(dist.res, type="h", col=cols, xlab="Samples", xaxt="n", ylab="Outlying Measures", bty="n");
+
+ # add sample names to top 5
+ rankres <- rank(-abs(dist.res), ties.method="random");
+
+ inx.x <- which(rankres < 6);
+ inx.y <- dist.res[inx.x];
+ nms <- names(dist.res)[inx.x];
+ text(inx.x, inx.y, nms, pos=ifelse(inx.y >= 0, 3, 1), xpd=T)
+ op <- par(mar=c(5,0,4,1));
+ plot.new();
+ plot.window(c(0,1), c(0,1));
+
+ legend("center", legend =legend.nm, pch=15, col=uniq.cols);
+
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+#'Recursive Support Vector Machine (R-SVM)
+#'@description recursive SVM for feature selection and classification
+#'@param mSetObj Input name of the created mSet Object
+#'@param cvType Cross-validation type
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+RSVM.Anal <- function(mSetObj=NA, cvType){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ ladder = CreateLadder(ncol(mSetObj$dataSet$norm));
+ svm.out <- RSVM(mSetObj$dataSet$norm, mSetObj$dataSet$cls, ladder, CVtype=cvType);
+
+ # calculate important features
+ ERInd <- max(which(svm.out$Error == min(svm.out$Error)))
+ MinLevel <- svm.out$ladder[ERInd]
+ FreqVec <- svm.out$SelFreq[, ERInd]
+ SelInd <- which(rank(FreqVec) >= (svm.out$ladder[1]-MinLevel));
+ FreqInd <- svm.out$SelFreq[SelInd, ERInd]
+ names(FreqInd) <- names(mSetObj$dataSet$norm)[SelInd];
+
+ #create a sig table for display
+ sig.var <- rev(sort(FreqInd));
+ sig.var <- as.matrix(sig.var); # 1-column matrix
+ colnames(sig.var) <- "Freqency";
+
+ fast.write.csv(sig.var, file="svm_sigfeatures.csv");
+
+ # add sorted features frequencies as importance indicator
+ svm.out <- append(svm.out, list(sig.mat=sig.var, best.inx=ERInd));
+ mSetObj$analSet$svm <- svm.out;
+ return(.set.mSet(mSetObj));
+}
+
+#'Recursive Support Vector Machine (R-SVM) plot
+#'@description Plot recursive SVM classification
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@usage PlotRSVM.Classification(mSetObj, imgName, format, dpi, width)
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotRSVM.Classification <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ res <- mSetObj$analSet$svm$Error;
+ edge <- (max(res)-min(res))/100; # expand y uplimit for text
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- 8;
+ }else if(width == 0){
+ w <- 7;
+ }else{
+ w <- width;
+ }
+ h <- w*6/8;
+
+ mSetObj$imgSet$svm.class <- imgName;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ plot(res,type='l',xlab='Number of variables (levels)',ylab='Error Rate',
+ ylim = c(min(res)-5*edge, max(res)+18*edge), axes=F,
+ main="Recursive SVM classification")
+ text(res,labels =paste(100*round(res,3),'%'), adj=c(-0.3, -0.5), srt=45, xpd=T)
+
+ points(res, col=ifelse(1:length(res)==mSetObj$analSet$svm$best.inx,"red","blue"));
+ axis(2);
+ axis(1, 1:length(res), names(res));
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+#'Recursive Support Vector Machine (R-SVM) plot of important variables
+#'@description Plot recursive SVM variables of importance
+#'if too many, plot top 15
+#'@usage PlotRSVM.Cmpd(mSetObj=NA, imgName, format="png", dpi=72, width=NA)
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotRSVM.Cmpd <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ sigs <- mSetObj$analSet$svm$sig.mat;
+ data <- sigs[,1];
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- 8;
+ }else if(width == 0){
+ w <- 7;
+ }else{
+ w <- width;
+ }
+ h <- w*7/8;
+
+ mSetObj$imgSet$svm <- imgName;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ PlotImpVar(mSetObj, data, "Frequency");
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+#'R-code for R-SVM
+#'@description use leave-one-out / Nfold or bootstrape to permute data for external CV
+#'build SVM model and use mean-balanced weight to sort genes on training set
+#'and recursive elimination of least important genes
+#'@param Ntotal Total number
+#'@param Nmin Minimum number, default set to 5
+#'@author Dr. Xin Lu, Research Scientist
+#'Biostatistics Department, Harvard School of Public Health
+#'create a decreasing ladder for recursive feature elimination
+#'
+CreateLadder <- function(Ntotal, Nmin=5){
+ x <- vector()
+ x[1] <- Ntotal
+ # note SVM is very computationally intensive, large step first
+ # first descend with 0.5 -> 50 var left
+ # then descend with 0.6 -> 25 var left
+ # then desend with 0.75 -> 5 var
+
+ for( i in 1:100 ){
+ if(x[i]>200){
+ pRatio = 0.4
+ }else if(x[i]>50){
+ pRatio = 0.5
+ }else if(x[i]>25){
+ pRatio = 0.6
+ }else{
+ pRatio = 0.75
+ }
+ pp <- round(x[i] * pRatio)
+ if( pp == x[i] ){
+ pp <- pp-1
+ }
+ if( pp >= Nmin ) {
+ x[i+1] <- pp
+ } else{
+ break
+ }
+ }
+ x
+}
+
+#'R-SVM core code
+#'@description Core code to perform R-SVM
+#'@param x Row matrix of data
+#'@param y Class label: 1 / -1 for 2 classes
+#'@param ladder Input the ladder
+#'@param CVtype Integer (N fold CV), "LOO" leave-one-out CV, "bootstrape" bootstrape CV
+#'@param CVnum Number of CVs, LOO: defined as sample size, Nfold and bootstrape: user defined, default as sample size
+#'outputs a named list
+#'Error: a vector of CV error on each level
+#'SelFreq: a matrix for the frequency of each gene being selected in each level
+#'with each column corresponds to a level of selection
+#'and each row for a gene
+#'The top important gene in each level are those high-freqent ones
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+RSVM <- function(x, y, ladder, CVtype, CVnum=0){
+ ## check if y is binary response
+ Ytype <- names(table(y))
+ if(length(Ytype) != 2){
+ print("ERROR!! RSVM can only deal with 2-class problem")
+ return(0)
+ }
+
+ ## class mean
+ m1 <- apply(x[ which(y==Ytype[1]), ], 2, mean)
+ m2 <- apply(x[ which(y==Ytype[2]), ], 2, mean)
+ md <- m1-m2
+
+ yy <- vector(length=length(y))
+ yy[which(y==Ytype[1])] <- 1
+ yy[which(y==Ytype[2])] <- -1
+ y <- yy
+
+ ## check ladder
+ if(min(diff(ladder)) >= 0){
+ print("ERROR!! ladder must be monotonously decreasing")
+ return(0);
+ }
+
+ if(ladder[1] != ncol(x) ){
+ ladder <- c(ncol(x), ladder)
+ }
+
+ nSample <- nrow(x)
+ nGene <- ncol(x)
+ SampInd <- seq(1, nSample)
+
+ if(CVtype == "LOO"){
+ CVnum <- nSample
+ }else{
+ if(CVnum == 0 ){
+ CVnum <- nSample
+ }
+ }
+
+ ## vector for test error and number of tests
+ ErrVec <- vector(length=length(ladder))
+ names(ErrVec) <- as.character(ladder);
+ nTests <- 0
+
+ SelFreq <- matrix(0, nrow=nGene, ncol=length(ladder))
+ colnames(SelFreq) <- paste("Level", ladder);
+
+ ## for each CV
+ for(i in 1:CVnum){
+ ## split data
+ if(CVtype == "LOO"){
+ TestInd <- i
+ TrainInd <- SampInd[ -TestInd]
+ }else{
+ if(CVtype == "bootstrape"){
+ TrainInd <- sample(SampInd, nSample, replace=T);
+ TestInd <- SampInd[ which(!(SampInd %in% TrainInd ))];
+ }else{
+ ## Nfold
+ TrainInd <- sample(SampInd, nSample*(CVtype-1)/CVtype);
+ TestInd <- SampInd[ which(!(SampInd %in% TrainInd ))];
+ }
+ }
+
+ nTests <- nTests + length(TestInd)
+
+ ## in each level, train a SVM model and record test error
+ xTrain <- x[TrainInd, ]
+ yTrain <- y[TrainInd]
+
+ xTest <- x[TestInd,]
+ yTest <- y[TestInd]
+
+ ## index of the genes used in the
+ SelInd <- seq(1, nGene)
+ for(gLevel in 1:length(ladder))
+ {
+ ## record the genes selected in this ladder
+ SelFreq[SelInd, gLevel] <- SelFreq[SelInd, gLevel] +1
+
+ ## train SVM model and test error
+ ###################################################################################
+ ## note the scale is changed to T or it never returns sometime for unscaled data ###
+ ## note: the classification performance is idenpendent of about scale is T/F #####
+ ## for "LOO", the test data should be as.data.frame, matrxi will trigger error #####
+ ###################################################################################
+ svmres <- e1071::svm(xTrain[, SelInd], yTrain, scale=T, type="C-classification", kernel="linear" )
+ if( CVtype == "LOO" ){
+ svmpred <- predict(svmres, as.data.frame(xTest[SelInd], nrow=1) )
+ }else{
+ svmpred <- predict(svmres, xTest[, SelInd] )
+ }
+ ErrVec[gLevel] <- ErrVec[gLevel] + sum(svmpred != yTest )
+
+ ## weight vector
+ W <- t(svmres$coefs*yTrain[svmres$index]) %*% svmres$SV * md[SelInd]
+ rkW <- rank(W)
+
+ if( gLevel < length(ladder) ){
+ SelInd <- SelInd[which(rkW > (ladder[gLevel] - ladder[gLevel+1]))]
+ }
+ }
+ }
+ ret <- list(ladder=ladder, Error=ErrVec/nTests, SelFreq=SelFreq);
+ ret;
+}
+
+PlotConfusion <- function(clsConf){
+ prior(clsConf) <- 100
+ # The above rescales the confusion matrix such that columns sum to 100.
+ opar <- par(mar=c(5.1, 6.1, 2, 2))
+ x <- x.orig <- unclass(clsConf)
+ x <- log(x + 0.5) * 2.33
+ x[x < 0] <- NA
+ x[x > 10] <- 10
+ diag(x) <- -diag(x)
+ image(1:ncol(x), 1:ncol(x),
+ -(x[, nrow(x):1]), xlab='Actual', ylab='',
+ col=colorRampPalette(c(hsv(h = 0, s = 0.9, v = 0.9, alpha = 1),
+ hsv(h = 0, s = 0, v = 0.9, alpha = 1),
+ hsv(h = 2/6, s = 0.9, v = 0.9, alpha = 1)))(41),
+ xaxt='n', yaxt='n', zlim=c(-10, 10))
+ axis(1, at=1:ncol(x), labels=colnames(x), cex.axis=0.8)
+ axis(2, at=ncol(x):1, labels=colnames(x), las=1, cex.axis=0.8)
+ title(ylab='Predicted', line=4.5)
+ abline(h = 0:ncol(x) + 0.5, col = 'gray')
+ abline(v = 0:ncol(x) + 0.5, col = 'gray')
+ text(1:6, rep(6:1, each=6), labels = sub('^0$', '', round(c(x.orig), 0)))
+ box(lwd=2)
+ par(opar) # reset par
+}
+
+##############################################
+##############################################
+########## Utilities for web-server ##########
+##############################################
+##############################################
+
+#'Random Forest OOB
+#'@description Get the OOB error for the last signif
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+GetRFOOB <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ errors = mSetObj$analSet$rf$err.rate;
+ nrow = dim(errors)[1];
+ signif(errors[nrow, 1],3);
+}
+
+#'Sig table for random forest analysis
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@export
+GetSigTable.RF <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ GetSigTable(mSetObj$analSet$rf.sigmat, "Random Forest", mSetObj$dataSet$type);
+}
+
+#'Random Forest Significance matrix
+#'@description Significance measure, double brackets
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+GetRFSigMat <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(CleanNumber(mSetObj$analSet$rf.sigmat))
+}
+
+GetRFSigRowNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ rownames(mSetObj$analSet$rf.sigmat);
+}
+
+GetRFSigColNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ colnames(mSetObj$analSet$rf.sigmat);
+}
+
+#'Classification performance table for random forest analysis
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@export
+GetRFConf.Table <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ print(xtable::xtable(mSetObj$analSet$rf$confusion,
+ caption="Random Forest Classification Performance"), size="\\scriptsize");
+}
+
+#'Random Forest Confusion Matrix
+#'@description Return double confusion matrix
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+GetRFConfMat <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ signif(mSetObj$analSet$rf$confusion,3);
+}
+
+GetRFConfRowNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ rownames(mSetObj$analSet$rf$confusion);
+}
+
+GetRFConfColNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ colnames(mSetObj$analSet$rf$confusion);
+}
+
+#'Recursive Support Vector Machine (R-SVM) Significance Measure
+#'@description Return significance measure, double[][]
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+GetSVMSigMat <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(CleanNumber(mSetObj$analSet$svm$sig.mat));
+}
+
+GetSVMSigRowNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ rownames(mSetObj$analSet$svm$sig.mat);
+}
+
+GetSVMSigColNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ colnames(mSetObj$analSet$svm$sig.mat);
+}
+
+#'Sig table for SVM
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@export
+GetSigTable.SVM <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ GetSigTable(mSetObj$analSet$svm$sig.mat, "Recursive SVM", mSetObj$dataSet$type);
+}
\ No newline at end of file
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/stats_clustering.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/stats_clustering.R
new file mode 100755
index 0000000000000000000000000000000000000000..4f0af66cc4e3784b97a352079116135b2b1c7692
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/stats_clustering.R
@@ -0,0 +1,822 @@
+#'Plot Dendrogram
+#'@description Dendogram
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@param smplDist Method to calculate sample distance
+#'@param clstDist Method to calculate clustering distance
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotHCTree <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA, smplDist, clstDist){
+
+ mSetObj <- .get.mSet(mSetObj);
+ # set up data set
+ hc.dat <- as.matrix(mSetObj$dataSet$norm);
+ colnames(hc.dat) <- substr(colnames(hc.dat), 1, 18) # some names are too long
+ # set up distance matrix
+ if(smplDist == 'euclidean'){
+ dist.mat <- dist(hc.dat, method = smplDist);
+ }else{
+ dist.mat <- dist(1-cor(t(hc.dat), method = smplDist));
+ }
+
+ # record the paramters
+ mSetObj$analSet$tree <- list(dist.par=smplDist, clust.par=clstDist);
+ # build the tree
+ hc_tree <- hclust(dist.mat, method=clstDist);
+
+ # plot the tree
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- minH <- 630;
+ myH <- nrow(hc.dat)*10 + 150;
+ if(myH < minH){
+ myH <- minH;
+ }
+ w <- round(w/72,2);
+ h <- round(myH/72,2);
+ }else if(width == 0){
+ w <- h <- 7.2;
+ }else{
+ w <- h <- 7.2;
+ }
+
+ mSetObj$imgSet$tree <- imgName;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ par(cex=0.8, mar=c(4,2,2,8));
+ if(mSetObj$dataSet$cls.type == "disc"){
+ clusDendro <- as.dendrogram(hc_tree);
+ cols <- GetColorSchema(mSetObj$dataSet$cls);
+ names(cols) <- rownames(hc.dat);
+ labelColors <- cols[hc_tree$order];
+ colLab <- function(n){
+ if(is.leaf(n)) {
+ a <- attributes(n)
+ labCol <- labelColors[a$label];
+ attr(n, "nodePar") <-
+ if(is.list(a$nodePar)) c(a$nodePar, lab.col = labCol,pch=NA) else
+ list(lab.col = labCol,pch=NA)
+ }
+ n
+ }
+ clusDendro <- dendrapply(clusDendro, colLab)
+ plot(clusDendro,horiz=T,axes=T);
+ par(cex=1);
+
+ if(mSetObj$dataSet$type.cls.lbl=="integer"){
+ legend.nm <- as.character(sort(as.factor(as.numeric(levels(mSetObj$dataSet$cls))[mSetObj$dataSet$cls])));
+ }else{
+ legend.nm <- as.character(mSetObj$dataSet$cls);
+ }
+
+ legend("topleft", legend = unique(legend.nm), pch=15, col=unique(cols), bty = "n");
+
+ }else{
+ plot(as.dendrogram(hc_tree), hang=-1, main=paste("Cluster with", clstDist, "method"), xlab=NULL, sub=NULL, horiz=TRUE);
+ }
+ dev.off();
+
+ return(.set.mSet(mSetObj));
+}
+
+#'SOM analysis
+#'@description SOM analysis
+#'@param mSetObj Input name of the created mSet Object
+#'@param x.dim Input X dimension for SOM analysis
+#'@param y.dim Input Y dimension for SOM analysis
+#'@param initMethod Input the method
+#'@param neigb Default is set to 'gaussian'
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+SOM.Anal <- function(mSetObj=NA, x.dim, y.dim, initMethod, neigb = 'gaussian'){
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$analSet$som <- som::som(as.matrix(mSetObj$dataSet$norm), xdim=x.dim, ydim=y.dim, init=initMethod, neigh=neigb);
+ return(.set.mSet(mSetObj));
+}
+
+#'SOM Plot
+#'@description Plot SOM map for less than 20 clusters
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@param colpal Character, input "default" to use the default ggplot color scheme or "colblind" to use
+#'the color-blind friendly palette.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@import ggplot2
+#'@export
+#'
+PlotSOM <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA, colpal = "default", facet=TRUE){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(.on.public.web){
+ load_ggplot()
+ load_data.table()
+ }
+
+ xdim <- mSetObj$analSet$som$xdim;
+ ydim <- mSetObj$analSet$som$ydim;
+
+ total<-xdim*ydim;
+ if(total>20) { return();}
+
+ ylabel<-GetAbundanceLabel(mSetObj$dataSet$type);
+ clust<-mSetObj$analSet$som$visual;
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+
+ if(is.na(width)){
+ w <- 9;
+ }else if(width == 0){
+ w <- 7;
+ }else{
+ w <- width;
+ }
+ h <- w*8/9;
+
+ if(xdim > 5){
+ w <- w + 7.5
+ }else if(xdim > 3){
+ w <- w + 5
+ }else if(xdim > 1){
+ w <- w + 3
+ }
+
+ mSetObj$imgSet$som <- imgName;
+
+ ### NEW PLOTS
+ group <- paste(clust[,1], clust[,2], sep = "_")
+ clust.num <- length(unique(group))
+
+ df <- data.frame(Samples = as.factor(rownames(mSetObj$dataSet$norm)), Cluster = group, clust[,-3], mSetObj$dataSet$norm, check.names = F)
+ long <- melt(setDT(df), id.vars = c("Samples", "Cluster", "x", "y"), variable.name = "Feature")
+ long.dt <- setDT(long)[, ymax:= max(value), by=list(Feature, Cluster)]
+ long.dt <- setDT(long.dt)[, ymin:= min(value), by=list(Feature, Cluster)]
+ long.dt <- setDT(long.dt)[, median:= median(value), by=list(Feature, Cluster)]
+ long.dt <- setDF(long.dt)
+
+ p <- ggplot(long.dt, aes(x = Feature, y = median, group = Cluster, color = Cluster)) +
+ geom_ribbon(aes(ymin=ymin, ymax=ymax, fill=Cluster), linetype=0, alpha = 0.25) +
+ geom_line() + xlab("") + ylab("Concentration") + guides(x = guide_axis(angle = 90)) +
+ theme(
+ # Remove panel border
+ panel.border = element_blank(),
+ # Remove panel grid lines
+ panel.grid.major = element_blank(),
+ panel.grid.minor = element_blank(),
+ # Remove panel background
+ panel.background = element_blank(),
+ # Add axis line
+ axis.line = element_line(colour = "grey"))
+
+ if(facet){
+ p <- p + facet_grid(y ~ x)
+ }
+
+ if(colpal == "colblind"){
+ if(clust.num <= 18){ # update color and respect default
+ dist.cols <- cb_pal_18[1:clust.num];
+ }else{
+ dist.cols <- colorRampPalette(cb_pal_18)(clust.num);
+ }
+ p <- p + scale_fill_manual(values=dist.cols) + scale_color_manual(values=dist.cols)
+ }
+
+ if(xdim < 3){
+ p <- p + theme(text = element_text(size=10))
+ }else{
+ p <- p + theme(text = element_text(size=8))
+ }
+
+ ggsave(p, filename = imgName, dpi=dpi, width=w, height=h, limitsize = FALSE)
+
+ return(.set.mSet(mSetObj));
+}
+
+#'K-means analysis
+#'@description Perform K-means analysis
+#'@param mSetObj Input name of the created mSet Object
+#'@param clust.num Numeric, input the number of clusters for K-means analysis
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+Kmeans.Anal <- function(mSetObj=NA, clust.num){
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$analSet$kmeans <- kmeans(mSetObj$dataSet$norm, clust.num, nstart=100);
+ return(.set.mSet(mSetObj));
+}
+
+#'Plot K-means analysis
+#'@description Plot K-means analysis
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@param colpal Character, input "default" to use the default ggplot color scheme or "colblind" to use
+#'the color-blind friendly palette.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+PlotKmeans <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA, colpal="default", facet=FALSE){
+
+ if(.on.public.web){
+ load_ggplot()
+ load_data.table()
+ }
+
+ mSetObj <- .get.mSet(mSetObj);
+ clust.num <- max(mSetObj$analSet$kmeans$cluster);
+
+ if(clust.num>20) return();
+ # calculate arrangement of panel
+ ylabel<- GetAbundanceLabel(mSetObj$dataSet$type);
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- 9;
+ }else if(width == 0){
+ w <- 7;
+ }else{
+ w <- width;
+ }
+ h <- w*8/9;
+
+ mSetObj$imgSet$kmeans <- imgName;
+
+ df <- data.frame(Samples = as.factor(rownames(mSetObj$dataSet$norm)), Cluster = as.factor(mSetObj$analSet$kmeans$cluster), mSetObj$dataSet$norm, check.names = F)
+ long <- melt(setDT(df), id.vars = c("Samples","Cluster"), variable.name = "Feature")
+ long.dt <- setDT(long)[, ymax:= max(value), by=list(Feature, Cluster)]
+ long.dt <- setDT(long.dt)[, ymin:= min(value), by=list(Feature, Cluster)]
+ long.dt <- setDT(long.dt)[, median:= median(value), by=list(Feature, Cluster)]
+ long.dt <- setDF(long.dt)
+
+ p <- ggplot(long.dt, aes(x = Feature, y = median, group = Cluster, color = Cluster)) +
+ geom_ribbon(aes(ymin=ymin, ymax=ymax, fill=Cluster), linetype=0, alpha = 0.25) +
+ geom_line() + xlab("") + ylab("Concentration") + guides(x = guide_axis(angle = 90)) +
+ theme(
+ # Remove panel border
+ panel.border = element_blank(),
+ # Remove panel grid lines
+ panel.grid.major = element_blank(),
+ panel.grid.minor = element_blank(),
+ # Remove panel background
+ panel.background = element_blank(),
+ # Add axis line
+ axis.line = element_line(colour = "grey")
+ )
+
+ if(facet){
+ p <- p + facet_grid(Cluster ~ .)
+ }
+
+ if(colpal == "colblind"){
+ if(clust.num <= 18){ # update color and respect default
+ dist.cols <- cb_pal_18[1:clust.num];
+ }else{
+ dist.cols <- colorRampPalette(cb_pal_18)(clust.num);
+ }
+ p <- p + scale_fill_manual(values=dist.cols) + scale_color_manual(values=dist.cols)
+ }
+
+ ggsave(p, filename = imgName, dpi=dpi, width=w, height=h, limitsize = FALSE)
+
+ return(.set.mSet(mSetObj));
+}
+
+#'Plot K-means summary PCA plot
+#'@description Plot K-means summary PCA plot
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@import ggplot2
+#'@export
+
+PlotClustPCA <- function(mSetObj, imgName, format="png", dpi=72, width=NA, colpal="default", anal="km",
+ labels = "T"){
+
+ if(.on.public.web){
+ load_ggplot()
+ load_data.table()
+ }
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(anal == "km"){
+ clust.num <- max(mSetObj$analSet$kmeans$cluster);
+ clusters <- as.factor(mSetObj$analSet$kmeans$cluster)
+ mSetObj$imgSet$kmeans.pca <- imgName;
+ }else{
+ clust<-mSetObj$analSet$som$visual;
+ clusters <- paste(clust[,1], clust[,2], sep = "_")
+ clust.num <- length(unique(clusters))
+ mSetObj$imgSet$som.pca <- imgName;
+ }
+
+ if(clust.num>20) return();
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+
+ if(is.na(width)){
+ w <- 9;
+ }else if(width == 0){
+ w <- 7;
+ }else{
+ w <- width;
+ }
+ h <- w*8/9;
+
+ data <- mSetObj$dataSet$norm
+
+ # Set class labels
+ if(mSetObj$dataSet$type.cls.lbl=="integer"){
+ cls <- as.factor(as.numeric(levels(mSetObj$dataSet$cls))[mSetObj$dataSet$cls]);
+ }else{
+ cls <- mSetObj$dataSet$cls;
+ }
+
+ res.pca <- stats::prcomp(data, scale = FALSE, center = TRUE)
+
+ sum.pca <- summary(res.pca);
+ imp.pca <- sum.pca$importance;
+ var.pca <- imp.pca[2,];
+
+ df_out <- as.data.frame(res.pca$x)
+ df_out$Cluster <- clusters
+ df_out$Class <- cls
+
+ text.lbls <- substr(names(res.pca$x[,1]), 1, 14)
+
+ xlabel = paste("PC",1, "(", round(100*var.pca[1],1), "%)");
+ ylabel = paste("PC",2, "(", round(100*var.pca[2],1), "%)");
+
+ p <- ggplot(df_out, aes(x=PC1, y=PC2, color=Class))
+ p <- p + geom_point(size = 5) + xlab(xlabel) + ylab(ylabel) + theme_bw()
+ p <- p + stat_ellipse(geom = "polygon", alpha = 0.15, aes(group = Cluster, fill = Cluster))
+
+ if(colpal == "colblind"){
+ if(clust.num <= 18){ # update color and respect default
+ dist.cols <- cb_pal_18[1:clust.num];
+ }else{
+ dist.cols <- colorRampPalette(cb_pal_18)(clust.num);
+ }
+ p <- p + scale_fill_manual(values = dist.cols) + scale_color_manual(values = dist.cols)
+ }
+
+ if(labels == "T"){
+ p <- p + geom_text(aes(label = text.lbls), vjust="inward", hjust="inward")
+ }
+
+ ggsave(p, filename = imgName, dpi=dpi, width=w, height=h, limitsize = FALSE)
+ return(.set.mSet(mSetObj));
+}
+
+#'Create Sub Heat Map Plot
+#'@description Plot a sub heatmap based on results from t-tests/ANOVA, VIP or randomforest
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@param dataOpt Set data options
+#'@param scaleOpt Set the image scale
+#'@param smplDist Input the sample distance method
+#'@param clstDist Input the clustering distance method
+#'@param palette Input color palette choice
+#'@param method.nm Input the method for sub-heat map
+#'@param top.num Input the top number
+#'@param viewOpt Set heatmap options, default is set to "detail"
+#'@param rowV Default is set to T
+#'@param colV Default is set to T
+#'@param border Indicate whether or not to show cell-borders, default is set to T
+#'@param grp.ave Logical, default is set to F
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotSubHeatMap <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA, dataOpt, scaleOpt,
+ smplDist, clstDist, palette, method.nm, top.num, viewOpt, rowV=T, colV=T, border=T, grp.ave=F){
+
+ mSetObj <- .get.mSet(mSetObj);
+ var.nms = colnames(mSetObj$dataSet$norm);
+ if(top.num < length(var.nms)){
+ if(method.nm == 'tanova'){
+ if(GetGroupNumber(mSetObj) == 2){
+ if(is.null(mSetObj$analSet$tt)){
+ Ttests.Anal(mSetObj);
+ mSetObj <- .get.mSet(mSetObj);
+ }
+ var.nms <- names(sort(mSetObj$analSet$tt$p.value))[1:top.num];
+ }else{
+ if(is.null(mSetObj$analSet$aov)){
+ ANOVA.Anal(mSetObj);
+ mSetObj <- .get.mSet(mSetObj);
+ }
+ var.nms <- names(sort(mSetObj$analSet$aov$p.value))[1:top.num];
+ }
+ }else if(method.nm == 'cor'){
+ if(is.null(mSetObj$analSet$cor.res)){
+ Match.Pattern(mSetObj);
+ mSetObj <- .get.mSet(mSetObj);
+ }
+
+ # re-order for pretty view
+ cor.res <- mSetObj$analSet$cor.res;
+
+ ord.inx<-order(cor.res[,3]);
+ cor.res <- cor.res[ord.inx, ];
+
+ ord.inx<-order(cor.res[,1]);
+ cor.res <- cor.res[ord.inx, ];
+
+ var.nms <- rownames(cor.res)[1:top.num];
+ }else if(method.nm == 'vip'){
+ if(is.null(mSetObj$analSet$plsda)){
+ PLSR.Anal(mSetObj);
+ PLSDA.CV(mSetObj);
+ mSetObj <- .get.mSet(mSetObj);
+ }
+ vip.vars <- mSetObj$analSet$plsda$vip.mat[,1];# use the first component
+ var.nms <- names(rev(sort(vip.vars)))[1:top.num];
+ }else if(method.nm == 'rf'){
+ if(is.null(analSet$rf)){
+ RF.Anal(mSetObj);
+ mSetObj <- .get.mSet(mSetObj);
+ }
+ var.nms <- GetRFSigRowNames()[1:top.num];
+ }
+ }
+ var.inx <- match(var.nms, colnames(mSetObj$dataSet$norm));
+ PlotHeatMap(mSetObj, imgName, format, dpi, width, dataOpt, scaleOpt, smplDist, clstDist, palette, viewOpt, rowV, colV, var.inx, border, grp.ave);
+}
+
+#'Create Heat Map Plot
+#'@description Plot a heatmap based on results from t-tests/ANOVA, VIP or randomforest
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@param dataOpt Set data options
+#'@param scaleOpt Set the image scale
+#'@param smplDist Input the sample distance method
+#'@param clstDist Input the clustering distance method
+#'@param palette Input color palette choice
+#'@param viewOpt Set heatmap options, default is set to "detail"
+#'@param rowV Default is set to T
+#'@param colV Default is set to T
+#'@param var.inx Default is set to NA
+#'@param border Indicate whether or not to show cell-borders, default is set to T
+#'@param grp.ave Logical, default is set to F
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@import qs
+#'@export
+#'
+PlotHeatMap <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA, dataOpt, scaleOpt, smplDist,
+ clstDist, palette, viewOpt="detail", rowV=T, colV=T, var.inx=NULL, border=T, grp.ave=F){
+ filenm = paste0(imgName, ".json")
+ mSetObj <- .get.mSet(mSetObj);
+
+ # record the paramters
+ mSetObj$analSet$htmap <- list(dist.par=smplDist, clust.par=clstDist);
+
+ # set up data set
+ if(dataOpt=="norm"){
+ my.data <- mSetObj$dataSet$norm;
+ }else{
+ my.data <- qs::qread("prenorm.qs");
+ }
+
+ if(is.null(var.inx)){
+ hc.dat<-as.matrix(my.data);
+ }else{
+ hc.dat<-as.matrix(my.data[,var.inx]);
+ }
+
+ colnames(hc.dat) <- substr(colnames(hc.dat),1,18) # some names are too long
+
+ if(mSetObj$dataSet$type.cls.lbl=="integer"){
+ hc.cls <- as.factor(as.numeric(levels(mSetObj$dataSet$cls))[mSetObj$dataSet$cls]);
+ }else{
+ hc.cls <- mSetObj$dataSet$cls;
+ }
+
+ if(grp.ave){ # only use group average
+ lvs <- levels(hc.cls);
+ my.mns <- matrix(ncol=ncol(hc.dat),nrow=length(lvs));
+ for(i in 1:length(lvs)){
+ inx <-hc.cls == lvs[i];
+ my.mns[i,]<- apply(hc.dat[inx, ], 2, mean);
+ }
+ rownames(my.mns) <- lvs;
+ colnames(my.mns) <- colnames(hc.dat);
+ hc.dat <- my.mns;
+ hc.cls <- as.factor(lvs);
+ }
+
+ # set up colors for heatmap
+ if(palette=="gbr"){
+ colors <- colorRampPalette(c("green", "black", "red"), space="rgb")(256);
+ }else if(palette == "heat"){
+ colors <- heat.colors(256);
+ }else if(palette == "topo"){
+ colors <- topo.colors(256);
+ }else if(palette == "gray"){
+ colors <- colorRampPalette(c("grey90", "grey10"), space="rgb")(256);
+ }else{
+ colors <- rev(colorRampPalette(RColorBrewer::brewer.pal(10, "RdBu"))(256));
+ }
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+
+ if(is.na(width)){
+ minW <- 630;
+ myW <- nrow(hc.dat)*18 + 150;
+
+ if(myW < minW){
+ myW <- minW;
+ }
+ w <- round(myW/72,2);
+ }else if(width == 0){
+ w <- 7.2;
+ }else{
+ w <- 7.2;
+ }
+
+ mSetObj$imgSet$heatmap <- imgName;
+
+ myH <- ncol(hc.dat)*18 + 150;
+ h <- round(myH/72,2);
+
+ if(viewOpt == "overview"){
+ if(is.na(width)){
+ if(w > 9){
+ w <- 9;
+ }
+ }else if(width == 0){
+ if(w > 7.2){
+ w <- 7.2;
+ }
+
+ }else{
+ w <- 7.2;
+ }
+ if(h > w){
+ h <- w;
+ }
+
+ mSetObj$imgSet$heatmap <- imgName;
+ }
+
+ # make the width smaller fro group average
+ if(grp.ave){
+ w <- nrow(hc.dat)*25 + 300;
+ w <- round(w/72,2);
+ }
+
+ if(border){
+ border.col<-"grey60";
+ }else{
+ border.col <- NA;
+ }
+ if(format=="pdf"){
+ pdf(file = imgName, width=w, height=h, bg="white", onefile=FALSE);
+ }else{
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ }
+ if(mSetObj$dataSet$cls.type == "disc"){
+ annotation <- data.frame(class = hc.cls);
+ rownames(annotation) <- rownames(hc.dat);
+
+ # set up color schema for samples
+ cols <- GetColorSchema(mSetObj$dataSet$cls, palette == "gray");
+ uniq.cols <- unique(cols);
+
+ if(mSetObj$dataSet$type.cls.lbl=="integer"){
+ cls <- as.factor(as.numeric(levels(mSetObj$dataSet$cls))[mSetObj$dataSet$cls]);
+ }else{
+ cls <- mSetObj$dataSet$cls;
+ }
+
+ names(uniq.cols) <- unique(as.character(sort(cls)));
+ ann_colors <- list(class= uniq.cols);
+
+ pheatmap::pheatmap(t(hc.dat),
+ annotation=annotation,
+ fontsize=8, fontsize_row=8,
+ clustering_distance_rows = smplDist,
+ clustering_distance_cols = smplDist,
+ clustering_method = clstDist,
+ border_color = border.col,
+ cluster_rows = colV,
+ cluster_cols = rowV,
+ scale = scaleOpt,
+ color = colors,
+ annotation_colors = ann_colors);
+ dat = t(hc.dat)
+ if(scaleOpt == "row"){
+ res <- t(apply(dat, 1, function(x){as.numeric(cut(x, breaks=30))}));
+ }else{
+ res <- t(apply(dat, 2, function(x){as.numeric(cut(x, breaks=30))}));
+ }
+ colnames(dat) = NULL
+ netData <- list(data=res, annotation=annotation, smp.nms = colnames(t(hc.dat)), met.nms = rownames(t(hc.dat)), colors = colors);
+ sink(filenm);
+ cat(RJSONIO::toJSON(netData));
+ sink();
+ }else{
+ heatmap(hc.dat, Rowv = rowTree, Colv=colTree, col = colors, scale="column");
+ dat = t(hc.dat)
+if(scaleOpt == "row"){
+ res <- t(apply(dat, 1, function(x){as.numeric(cut(x, breaks=30))}));
+}else{
+ res <- t(apply(dat, 2, function(x){as.numeric(cut(x, breaks=30))}));
+}
+ colnames(dat) = NULL
+ netData <- list(data=res, annotation="NA", smp.nms = colnames(t(hc.dat)), met.nms = rownames(t(hc.dat)), colors = colors);
+ sink(filenm);
+ cat(RJSONIO::toJSON(netData));
+ sink();
+ }
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+##############################################
+##############################################
+########## Utilities for web-server ##########
+##############################################
+##############################################
+
+#'SOM analysis
+#'@description Get members for given cluster index, return a character string
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param i Index of X
+#'@param j Index of Y
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+GetSOMClusterMembers <- function(mSetObj=NA, i, j){
+ mSetObj <- .get.mSet(mSetObj);
+ clust <- mSetObj$analSet$som$visual;
+ xTrue <- clust$x == i;
+ yTrue <- clust$y == j;
+ hit.inx <- xTrue & yTrue;
+
+ all.cols <- GetColorSchema(mSetObj$dataSet$cls);
+ paste("<font color=\"", all.cols[hit.inx], "\">", rownames(mSetObj$dataSet$norm)[hit.inx], "</font>",collapse =", ");
+}
+
+#'SOM analysis
+#'@description Get members for given cluster index, return a character string
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+GetAllSOMClusterMembers <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+ clust <- mSetObj$analSet$som$visual;
+ xdim <- mSetObj$analSet$som$xdim;
+ ydim <- mSetObj$analSet$som$ydim;
+
+ clust.df = data.frame();
+ rowNameVec = c();
+ i = 0;
+ while(i < xdim){
+ j = 0;
+ while(j < ydim){
+ xTrue<-clust$x == i;
+ yTrue<-clust$y == j;
+ if(i==0 & j==0){ # bug in R, the first one need to be different
+ clust.df <- rbind(paste(rownames(mSetObj$dataSet$norm)[xTrue & yTrue], collapse = " "));
+ rowNameVec <- c(paste("Cluster(", i, ",", j,")"));
+ }else{
+ clust.df <- rbind(clust.df, paste(rownames(mSetObj$dataSet$norm)[xTrue & yTrue], collapse=" "));
+ rowNameVec <- c(rowNameVec, paste("Cluster(", i, ",", j,")"));
+ }
+ j = j+1;
+ }
+ i = i+1;
+ }
+ row.names(clust.df) <- rowNameVec;
+ colnames(clust.df) <- "Samples in each cluster";
+ print(xtable::xtable(clust.df, align="l|p{8cm}", caption="Clustering result using SOM"),caption.placement="top", size="\\scriptsize");
+}
+
+
+# inx has to be 1 or 2
+GetClassLabel<-function(mSetObj=NA, inx){
+ mSetObj <- .get.mSet(mSetObj);
+ levels(mSetObj$dataSet$cls)[inx]
+}
+
+
+#'K-means analysis - cluster
+#'@description Get the cluster members for given index
+#'add HTML color to the names based on its group membership
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param i Input the cluster index
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+GetKMClusterMembers <- function(mSetObj=NA, i){
+ mSetObj <- .get.mSet(mSetObj);
+ all.cols <- GetColorSchema(mSetObj$dataSet$cls);
+ hit.inx <- mSetObj$analSet$kmeans$cluster== i;
+
+ paste("<font color=\"", all.cols[hit.inx], "\">", rownames(mSetObj$dataSet$norm)[hit.inx], "</font>",collapse =", ");
+ # paste(all.cols[hit.inx], rownames(dataSet$norm)[hit.inx], collapse =", ");
+}
+
+#'K-means analysis - cluster
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@export
+GetAllKMClusterMembers <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ clust.df = data.frame();
+ rowNameVec = c();
+ i = 1;
+ clust.num<-max(mSetObj$analSet$kmeans$cluster);
+ while(i<=clust.num){
+ if(i==1){
+ clust.df <- rbind(paste(rownames(mSetObj$dataSet$norm)[mSetObj$analSet$kmeans$cluster== i], collapse = " "));
+ }else{
+ clust.df <- rbind(clust.df,paste(rownames(mSetObj$dataSet$norm)[mSetObj$analSet$kmeans$cluster== i], collapse = " "));
+ }
+ rowNameVec <- c(rowNameVec, paste("Cluster(", i, ")"));
+ i = i+1;
+ }
+ row.names(clust.df) <- rowNameVec;
+ colnames(clust.df) <-"Samples in each cluster";
+ print(xtable::xtable(clust.df, align="l|p{8cm}", caption="Clustering result using K-means"), caption.placement="top", size="\\scriptsize");
+}
+
+########## Utility Functions ##############
+#'Determine row/column number for plotting
+#'@description Determine the number of rows and columns for a given total
+#'number of plots (used by Kmeans and SOM plots)
+#'@param total Input the total
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'
+GetXYCluster<-function(total){
+ if(total>16){
+ ncol<-4;
+ nrow<-5;
+ }else if(total>12){
+ ncol<-4;
+ nrow<-4;
+ }else if(total>9){
+ ncol<-3;
+ nrow<-4;
+ }else if(total>6){
+ ncol<-3;
+ nrow<-3;
+ }else if(total>4){
+ ncol<-2;
+ nrow<-3;
+ }else{
+ ncol<-1;
+ nrow<-total;
+ }
+ c(nrow, ncol);
+}
\ No newline at end of file
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/stats_correlations.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/stats_correlations.R
new file mode 100755
index 0000000000000000000000000000000000000000..3d32f7ff2902a544469ceff8aeb6c42578f4757a
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/stats_correlations.R
@@ -0,0 +1,413 @@
+#'Pattern hunter
+#'@description Run template on all the high region effect genes
+#'@param x Input data
+#'@param template Input template
+#'@param dist.name Input distance method
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'
+template.match <- function(x, template, dist.name) {
+ k <- cor.test(x,template, method=dist.name);
+ c(k$estimate, k$stat, k$p.value)
+}
+
+#'Match pattern for correlation analysis
+#'@param mSetObj Input the name of the created mSetObj
+#'@param dist.name Input the distance method, default is set to pearson
+#'@param pattern Set the pattern, default is set to NULL
+#'@export
+#'
+Match.Pattern <- function(mSetObj=NA, dist.name="pearson", pattern=NULL){
+ mSetObj <- .get.mSet(mSetObj);
+ if(is.null(pattern)){
+ pattern <- paste(1:length(levels(mSetObj$dataSet$cls)), collapse="-");
+ }
+ templ <- as.numeric(ClearStrings(strsplit(pattern, "-", fixed=TRUE)[[1]]));
+
+ if(all(templ==templ[1])){
+ AddErrMsg("Cannot calculate correlation on constant values!");
+ return(0);
+ }
+
+ new.template <- vector(mode="numeric", length=length(mSetObj$dataSet$cls))
+ # expand to match each levels in the dataSet$cls
+ all.lvls <- levels(mSetObj$dataSet$cls);
+
+ if(length(templ)!=length(all.lvls)){
+ AddErrMsg("Wrong template - must the same length as the group number!");
+ return(0);
+ }
+
+ for(i in 1:length(templ)){
+ hit.inx <- mSetObj$dataSet$cls == all.lvls[i]
+ new.template[hit.inx] = templ[i];
+ }
+
+ cbtempl.results <- apply(mSetObj$dataSet$norm, 2, template.match, new.template, dist.name);
+
+ cor.res <- t(cbtempl.results);
+
+ fdr.col <- p.adjust(cor.res[,3], "fdr");
+ cor.res <- cbind(cor.res, fdr.col);
+ colnames(cor.res)<-c("correlation", "t-stat", "p-value", "FDR");
+ ord.inx<-order(cor.res[,3]);
+
+ sig.mat <- signif(cor.res[ord.inx,],5);
+
+ fileName <- "correlation_pattern.csv";
+ fast.write.csv(sig.mat,file=fileName);
+
+ mSetObj$analSet$corr$sig.nm <- fileName;
+ mSetObj$analSet$corr$cor.mat <- sig.mat;
+ mSetObj$analSet$corr$pattern <- pattern;
+ return(.set.mSet(mSetObj));
+}
+
+#'Pattern hunter, correlation plot
+#'@description Plot correlation
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotCorr <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+ cor.res <- mSetObj$analSet$corr$cor.mat;
+ pattern <- mSetObj$analSet$corr$pattern;
+ title <- paste(GetVariableLabel(mSetObj$dataSet$type), "correlated with the", pattern);
+ if(nrow(cor.res) > 25){
+
+ # first get most signficant ones (p value)
+ ord.inx<-order(cor.res[,3]);
+ cor.res <- cor.res[ord.inx, ];
+ cor.res <- cor.res[1:25, ];
+
+ # then order by their direction (correlation)
+ ord.inx<-order(cor.res[,1]);
+ if(sum(cor.res[,1] > 0) == 0){ # all negative correlation
+ ord.inx <- rev(ord.inx);
+ }
+ cor.res <- cor.res[ord.inx, ];
+ title <- paste("Top 25", tolower(GetVariableLabel(mSetObj$dataSet$type)), "correlated with the", pattern);
+ }
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- h <- 7.2;
+ }else if(width == 0){
+ w <- 7.2;
+ }else{
+ w <- h <- width;
+ }
+ mSetObj$imgSet$corr <- imgName;
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ par(mar=c(5,6,4,3))
+ rownames(cor.res)<-substr(rownames(cor.res), 1, 18);
+ cols <- ifelse(cor.res[,1] >0, "mistyrose","lightblue");
+
+ dotchart(cor.res[,1], pch="", xlim=c(-1,1), xlab="Correlation coefficients", main=title);
+ rownames(cor.res) <- NULL;
+ barplot(cor.res[,1], space=c(0.5, rep(0, nrow(cor.res)-1)), xlim=c(-1,1), xaxt="n", col = cols, add=T,horiz=T);
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+#'Pattern hunter, corr heatmap
+#'@description Plot correlation heatmap
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'@param mSetObj Input name of the created mSet Object.
+#'@param imgName Input the name of the image to create
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@param target Input "row" to select features, or "col" to select samples.
+#'@param cor.method Indicate the correlation method, 'pearson', 'spearman', or 'kendall'.
+#'@param colors Indicate the colors for the heatmap, "bwm" for default, "gbr" for red/green, "heat" for heat colors,
+#'"topo" for topo colors, and "gray" for gray scale.
+#'@param viewOpt Indicate "overview" to get an overview of the heatmap, and "detail" to get a detailed view of the heatmap.
+#'@param fix.col Logical, fix colors (TRUE) or not (FALSE).
+#'@param no.clst Logical, indicate if the correlations should be clustered (TRUE) or not (FALSE).
+#'@param top View top
+#'@param topNum Numeric, view top
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'@import gplots
+#'
+PlotCorrHeatMap<-function(mSetObj=NA, imgName, format="png", dpi=72, width=NA, target, cor.method,
+ colors, viewOpt, fix.col, no.clst, corrCutoff=0){
+
+ mSetObj <- .get.mSet(mSetObj);
+ main <- xlab <- ylab <- NULL;
+ data <- mSetObj$dataSet$norm;
+ corrCutoff <- as.numeric(corrCutoff)
+
+ if(target == 'row'){
+ data <- t(data);
+ }
+
+ if(ncol(data) > 1000){
+ filter.val <- apply(data.matrix(data), 2, IQR, na.rm=T);
+ rk <- rank(-filter.val, ties.method='random');
+ data <- as.data.frame(data[,rk <=1000]);
+
+ print("Data is reduced to 1000 vars ..");
+ }
+
+ # compare p-values w. hmisc + cor.test
+ colnames(data) <- substr(colnames(data), 1, 18);
+ corr.mat <- cor(data, method=cor.method);
+
+ # NA gives error w. hclust
+ corr.mat[abs(corr.mat) < corrCutoff] <- 0;
+
+ # save data for lazy pval computing
+ mSetObj$analSet$pwcor <- list();
+ mSetObj$analSet$pwcor$data <- data;
+ mSetObj$analSet$pwcor$cor.method <- cor.method;
+ mSetObj$analSet$pwcor$no.clst <- no.clst;
+
+ if(.on.public.web){
+ load_gplots()
+ load_rcolorbrewer()
+ }
+
+ # set up parameter for heatmap
+ if(colors=="gbr"){
+ colors <- colorRampPalette(c("green", "black", "red"), space="rgb")(256);
+ }else if(colors == "heat"){
+ colors <- heat.colors(256);
+ }else if(colors == "topo"){
+ colors <- topo.colors(256);
+ }else if(colors == "gray"){
+ colors <- colorRampPalette(c("grey90", "grey10"))(256);
+ }else{
+ colors <- rev(colorRampPalette(c(RColorBrewer::brewer.pal(10, "RdBu"), "#001833"))(256));
+ }
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+
+ if(viewOpt == "overview"){
+ if(is.na(width)){
+ w <- 9;
+ }else if(width == 0){
+ w <- 7.2;
+ }else{
+ w <- 7.2;
+ }
+ h <- w;
+ mSetObj$imgSet$corr.heatmap <- imgName;
+
+ }else{
+ if(ncol(corr.mat) > 50){
+ myH <- ncol(corr.mat)*12 + 40;
+ }else if(ncol(corr.mat) > 20){
+ myH <- ncol(corr.mat)*12 + 60;
+ }else{
+ myH <- ncol(corr.mat)*12 + 120;
+ }
+ h <- round(myH/72,2);
+
+ if(is.na(width)){
+ w <- h;
+ }else if(width == 0){
+ w <- h <- 7.2;
+
+ }else{
+ w <- h <- 7.2;
+ }
+ mSetObj$imgSet$corr.heatmap <- imgName;
+ }
+
+ if(format=="pdf"){
+ pdf(file = imgName, width=w, height=h, bg="white", onefile=FALSE);
+ }else{
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ }
+
+ if(no.clst){
+ rowv=FALSE;
+ colv=FALSE;
+ dendro= "none";
+ }else{
+ rowv=TRUE;
+ colv=TRUE;
+ dendro= "both";
+ }
+
+ if(fix.col){
+ breaks <- seq(from = -1, to = 1, length = 257);
+ res <- pheatmap::pheatmap(corr.mat,
+ fontsize=8, fontsize_row=8,
+ cluster_rows = colv,
+ cluster_cols = rowv,
+ color = colors,
+ breaks = breaks
+ );
+ }else{
+ res <- pheatmap::pheatmap(corr.mat,
+ fontsize=8, fontsize_row=8,
+ cluster_rows = colv,
+ cluster_cols = rowv,
+ color = colors
+ );
+ }
+
+ dev.off();
+
+ if(!no.clst){ # when no clustering, tree_row is NA
+ new.ord <- res$tree_row$order;
+ corr.mat <- corr.mat[new.ord, new.ord];
+ mSetObj$analSet$pwcor$new.ord <- new.ord;
+ }
+
+ fast.write.csv(signif(corr.mat, 5), file="correlation_table.csv");
+ return(.set.mSet(mSetObj));
+}
+
+# this is for p values for correlation heatmap (all pair-wise).
+# use Hmisc for fast but lazy computing
+ComputeCorrP <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+
+ data <- mSetObj$analSet$pwcor$data;
+ cor.method <- mSetObj$analSet$pwcor$cor.method;
+ pval.mat <- Hmisc::rcorr(as.matrix(data), type=cor.method)$P;
+
+ if(!mSetObj$analSet$pwcor$no.clst){
+ new.ord <- mSetObj$analSet$pwcor$new.ord;
+ pval.mat <- pval.mat[new.ord, new.ord];
+ }
+ fast.write.csv(signif(pval.mat,5), file="pval_corr_table.csv");
+ return(1);
+}
+
+##############################################
+##############################################
+########## Utilities for web-server ##########
+##############################################
+##############################################
+
+GetCorrSigFileName <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$analSet$corr$sig.nm;
+}
+
+GetCorSigMat <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ as.matrix(CleanNumber(mSetObj$analSet$corr$cor.mat));
+}
+
+GetCorSigRowNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ rownames(mSetObj$analSet$corr$cor.mat);
+}
+
+GetCorSigColNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ colnames(mSetObj$analSet$corr$cor.mat);
+}
+
+#'Sig table for Correlation Analysis
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@export
+GetSigTable.Corr <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ GetSigTable(mSetObj$analSet$corr$cor.mat, "Pattern search using correlation analysis", mSetObj$dataSet$type);
+}
+
+GenerateTemplates <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+ level.len <- length(levels(mSetObj$dataSet$cls));
+
+ # only specify 4: increasing, decreasing, mid high, mid low, constant
+ incs <- 1:level.len;
+ desc <- level.len:1;
+
+ if(level.len > 2){
+ # use ceiling, so that the peak will be right for even length
+ mid.pos <- ceiling((level.len+1)/2);
+ mid.high <- c(1:mid.pos, seq(mid.pos-1,by=-1,length.out=level.len-mid.pos));
+ mid.low <- c(mid.pos:1, seq(2, length.out=level.len-mid.pos));
+
+ res <- rbind(incs, desc, mid.high, mid.low); # add the constant one
+ }else{
+ res <- rbind(incs, desc);
+ }
+ # turn into string
+ res <- apply(res, 1, paste, collapse="-");
+
+ # add the legends
+ res <- c(paste(levels(mSetObj$dataSet$cls), collapse="-"), res);
+ return(res);
+}
+
+#'Pattern hunter
+#'@description Calculate correlation of all other feature to a given feature name
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param dist.name Input the name of the distance measure
+#'@param varName Input the variable name
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+FeatureCorrelation <- function(mSetObj=NA, dist.name, varName){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # test if varName is valid
+ if(!varName %in% colnames(mSetObj$dataSet$norm)){
+ AddErrMsg("Invalid feature name - not found!");
+ return(0);
+ }
+
+ cbtempl.results <- apply(mSetObj$dataSet$norm, 2, template.match, mSetObj$dataSet$norm[,varName], dist.name);
+ cor.res<-t(cbtempl.results);
+
+ fdr.col <- p.adjust(cor.res[,3], "fdr");
+ cor.res <- cbind(cor.res, fdr.col);
+ colnames(cor.res)<-c("correlation", "t-stat", "p-value", "FDR");
+ ord.inx<-order(cor.res[,3])
+ sig.mat <-signif(cor.res[ord.inx,],5);
+
+ fileName <- "correlation_feature.csv";
+ fast.write.csv(sig.mat,file=fileName);
+
+ mSetObj$analSet$corr$sig.nm <- fileName;
+ mSetObj$analSet$corr$cor.mat <- sig.mat;
+ mSetObj$analSet$corr$pattern <- varName;
+
+ return(.set.mSet(mSetObj));
+}
+
+###########################################
+############ Utility Functions ############
+###########################################
+
+# Set of functions to perform cor.test
+PearsonCorrFunc <- function(var1, var2, data){
+ result <- cor.test(data[,var1], data[,var2])
+ data.frame(var1, var2, result[c("estimate", "p.value", "statistic")], stringsAsFactors = FALSE)
+}
+
+SpearmanCorrFunc <- function(var1, var2, data){
+ result <- cor.test(data[,var1], data[,var2], method = "spearman", exact = FALSE)
+ data.frame(var1, var2, result[c("estimate", "p.value", "statistic")], stringsAsFactors = FALSE)
+}
+
+KendallCorrFunc <- function(var1, var2, data){
+ result <- cor.test(data[,var1], data[,var2], method = "kendall", exact = FALSE)
+ data.frame(var1, var2, result[c("estimate", "p.value", "statistic")], stringsAsFactors = FALSE)
+}
\ No newline at end of file
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/stats_opls.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/stats_opls.R
new file mode 100755
index 0000000000000000000000000000000000000000..c9743889670f1c16f3ca5b9104c087be62446680
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/stats_opls.R
@@ -0,0 +1,482 @@
+# Perform OPLS
+# Orthogonal PLS functions (adapted from ropls package for web-based usage)
+# Turn off the .on.public.web for local usage
+# Jeff Xia \email{jeff.xia@mcgill.ca}
+# McGill University, Canada
+# License: GNU GPL (>= 2)
+perform_opls <- function (x, y = NULL, predI = NA, orthoI = 0, crossvalI = 7, log10L = FALSE, permI = 20, .on.public.web = TRUE,
+ scaleC = c("none", "center", "pareto", "standard")[4], ...) {
+ xMN <- x;
+ if(class(y) == "matrix"){
+ yMCN <- y;
+ }else{
+ yMCN <- matrix(y, ncol = 1);
+ }
+ rownames(yMCN) <- rownames(xMN)
+ colnames(yMCN) <- paste0("y", 1:ncol(yMCN))
+ yLevelVc <- NULL;
+ xZeroVarVi <- NULL;
+ epsN <- .Machine[["double.eps"]]
+
+ opl <- .coreOPLS(xMN = xMN, yMCN = yMCN, orthoI = orthoI, predI = predI,
+ scaleC = scaleC, crossvalI = crossvalI);
+
+ opl$suppLs[["y"]] <- y
+ opl$typeC <- "OPLS-DA";
+
+ ## Permutation testing (Szymanska et al, 2012)
+
+ if(permI > 0) {
+
+ modSumVc <- colnames(opl$summaryDF)
+ permMN <- matrix(0,
+ nrow = 1 + permI,
+ ncol = length(modSumVc),
+ dimnames = list(NULL, modSumVc))
+
+ perSimVn <- numeric(1 + permI)
+ perSimVn[1] <- 1
+
+ permMN[1, ] <- as.matrix(opl$summaryDF);
+
+ # do initial evaluation time for 10 permutations
+ start.time <- Sys.time();
+ for(k in 1:10) {
+ yVcn <- drop(opl$suppLs[["yMCN"]])
+ yPerVcn <- sample(yVcn)
+ yPerMCN <- matrix(yPerVcn, ncol = 1)
+ perOpl <- .coreOPLS(xMN = xMN,
+ yMCN = yPerMCN,
+ orthoI = opl$summaryDF[, "ort"],
+ predI = opl$summaryDF[, "pre"],
+ scaleC = scaleC,
+ crossvalI = crossvalI)
+
+ permMN[1 + k, ] <- as.matrix(perOpl$summaryDF);
+ perSimVn[1 + k] <- .similarityF(opl$suppLs[["yMCN"]], yPerMCN)
+ }
+ end.time <- Sys.time();
+ time.taken <- end.time - start.time;
+ print(paste("time taken for 10 permutations: ", time.taken));
+
+ if(.on.public.web){
+ if(time.taken > 60){
+ permI <- 20;
+ }else if(time.taken > 30){
+ permI <- 100;
+ }
+ permMN <- permMN[1:(1+permI),];
+ perSimVn <- perSimVn[1:(1+permI)];
+ }
+ # continue
+ for(k in 11:permI) {
+ yVcn <- drop(opl$suppLs[["yMCN"]])
+ yPerVcn <- sample(yVcn)
+ yPerMCN <- matrix(yPerVcn, ncol = 1)
+ perOpl <- .coreOPLS(xMN = xMN,
+ yMCN = yPerMCN,
+ orthoI = opl$summaryDF[, "ort"],
+ predI = opl$summaryDF[, "pre"],
+ scaleC = scaleC,
+ crossvalI = crossvalI)
+
+ permMN[1 + k, ] <- as.matrix(perOpl$summaryDF);
+ perSimVn[1 + k] <- .similarityF(opl$suppLs[["yMCN"]], yPerMCN)
+ }
+
+ permMN <- cbind(permMN, sim = perSimVn);
+ perPvaVn <- c(pR2Y = (1 + length(which(permMN[-1, "R2Y(cum)"] >= permMN[1, "R2Y(cum)"]))) / (nrow(permMN) - 1),
+ pQ2 = (1 + length(which(permMN[-1, "Q2(cum)"] >= permMN[1, "Q2(cum)"]))) / (nrow(permMN) - 1));
+ opl$summaryDF[, "pR2Y"] <- perPvaVn["pR2Y"];
+ opl$summaryDF[, "pQ2"] <- perPvaVn["pQ2"];
+ opl$suppLs[["permMN"]] <- permMN;
+ opl$suppLs[["permI"]] <- permI;
+ }
+
+ ##------------------------------------
+ ## Numerical results
+ ##------------------------------------
+
+ totN <- length(c(xMN))
+ nasN <- sum(is.na(c(xMN)))
+
+ if(!is.null(opl$suppLs[["yMCN"]])) {
+ totN <- totN + length(c(opl$suppLs[["yMCN"]]))
+ nasN <- nasN + sum(is.na(c(opl$suppLs[["yMCN"]])))
+ }
+
+ ## Raw summary
+ ##------------
+
+ opl$suppLs[["topLoadI"]] <- 3
+
+ if(ncol(xMN) > opl$suppLs[["topLoadI"]]) {
+ xVarVn <- apply(xMN, 2, var)
+ names(xVarVn) <- 1:length(xVarVn)
+ xVarVn <- sort(xVarVn)
+ xVarSorVin <- as.numeric(names(xVarVn[seq(1, length(xVarVn), length = opl$suppLs[["topLoadI"]])]))
+ opl$suppLs[["xSubIncVarMN"]] <- xMN[, xVarSorVin, drop = FALSE]
+ } else{
+ opl$suppLs[["xSubIncVarMN"]] <- xMN
+ }
+
+ if(ncol(xMN) <= 100) {
+ xCorMN <- cor(xMN, use = "pairwise.complete.obs")
+ xCorMN[lower.tri(xCorMN, diag = TRUE)] <- 0
+
+ if(ncol(xMN) > opl$suppLs[["topLoadI"]]) {
+ xCorNexDF <- which(abs(xCorMN) >= sort(abs(xCorMN), decreasing = TRUE)[opl$suppLs[["topLoadI"]] + 1],
+ arr.ind = TRUE);
+ xCorDisMN <- matrix(0,
+ nrow = nrow(xCorNexDF),
+ ncol = nrow(xCorNexDF),
+ dimnames = list(colnames(xMN)[xCorNexDF[, "row"]],
+ colnames(xMN)[xCorNexDF[, "col"]]))
+
+ for(k in 1:nrow(xCorDisMN)){
+ xCorDisMN[k, k] <- xCorMN[xCorNexDF[k, "row"], xCorNexDF[k, "col"]]
+ }
+ } else {
+ xCorDisMN <- xCorMN
+ }
+ opl$suppLs[["xCorMN"]] <- xCorDisMN
+ rm(xCorDisMN)
+ }
+ return(invisible(opl))
+}
+
+.coreOPLS <- function (xMN, yMCN, orthoI, predI, scaleC, crossvalI) {
+ epsN <- .Machine[["double.eps"]]
+ varVn <- NULL
+ yMeanVn <- NULL
+ ySdVn <- NULL
+ wMN <- NULL
+ cMN <- NULL
+ uMN <- NULL
+ rMN <- NULL
+ bMN <- NULL
+ vipVn <- NULL
+ yPreMN <- NULL
+ yTesMN <- NULL
+ toMN <- NULL
+ poMN <- NULL
+ woMN <- NULL
+ coMN <- NULL
+ orthoVipVn <- NULL
+ naxVi <- which(is.na(c(xMN)))
+ naxL <- length(naxVi) > 0
+ nayVi <- integer()
+ nayL <- FALSE;
+ yMN <- yMCN;
+
+ obsNamVc <- rownames(xMN)
+
+ autNcoL <- autNcpL <- FALSE
+ autMaxN <- min(c(10, dim(xMN)))
+ if (is.na(orthoI)) {
+ if (autMaxN == 1) {
+ orthoI <- 0
+ predI <- 1
+ warning("The data contain a single variable (or sample): A PLS model with a single component will be built",
+ call. = FALSE)
+ }
+ else {
+ orthoI <- autMaxN - 1
+ predI <- 1
+ autNcoL <- TRUE
+ }
+ }
+ if (is.na(predI)) {
+ if (orthoI > 0) {
+ if (autMaxN == 1) {
+ orthoI <- 0
+ warning("The data contain a single variable (or sample): A PLS model with a single component will be built",
+ call. = FALSE)
+ }
+ else warning("OPLS(-DA): The number of predictive component is set to 1 for a single response model",
+ call. = FALSE)
+ predI <- 1
+ if ((predI + orthoI) > min(dim(xMN)))
+ stop("The sum of 'predI' (", predI, ") and 'orthoI' (",
+ orthoI, ") exceeds the minimum dimension of the 'x' data matrix (",
+ min(dim(xMN)), ")", call. = FALSE)
+ }
+ else {
+ predI <- autMaxN
+ autNcpL <- TRUE
+ }
+ }
+ xVarVn <- apply(xMN, 2, function(colVn) var(colVn, na.rm = TRUE))
+ xMeanVn <- apply(xMN, 2, function(colVn) mean(colVn, na.rm = TRUE))
+ switch(scaleC, none = {
+ xMeanVn <- rep(0, ncol(xMN))
+ xSdVn <- rep(1, times = ncol(xMN))
+ }, center = {
+ xSdVn <- rep(1, times = ncol(xMN))
+ }, pareto = {
+ xSdVn <- apply(xMN, 2, function(colVn) sqrt(sd(colVn,
+ na.rm = TRUE)))
+ }, standard = {
+ xSdVn <- apply(xMN, 2, function(colVn) sd(colVn, na.rm = TRUE))
+ })
+ xMN <- scale(xMN, center = xMeanVn, scale = xSdVn)
+ if (!is.null(colnames(xMN))) {
+ xvaNamVc <- colnames(xMN)
+ }
+ else xvaNamVc <- paste("x", 1:ncol(xMN), sep = "")
+ preNamVc <- paste("p", 1:predI, sep = "")
+ pMN <- matrix(0, nrow = ncol(xMN), ncol = predI, dimnames = list(xvaNamVc,
+ preNamVc))
+ tMN <- uMN <- matrix(0, nrow = nrow(xMN), ncol = predI, dimnames = list(obsNamVc,
+ preNamVc))
+ ssxTotN <- sum(xMN^2, na.rm = TRUE)
+
+ yMeanVn <- apply(yMN, 2, function(colVn) mean(colVn,na.rm = TRUE))
+
+ yMeanVn <- rep(0, times = ncol(yMN))
+ ySdVn <- rep(1, times = ncol(yMN))
+ yMN <- scale(yMN, center = yMeanVn, scale = ySdVn)
+ yvaNamVc <- paste("y", 1:ncol(yMN), sep = "")
+ wMN <- pMN
+ uMN <- tMN
+ cMN <- matrix(0, nrow = ncol(yMN), ncol = predI, dimnames = list(yvaNamVc, preNamVc))
+ cvfNamVc <- paste("cv", 1:crossvalI, sep = "")
+ cvfOutLs <- split(1:nrow(xMN), rep(1:crossvalI, length = nrow(xMN)))
+ prkVn <- numeric(crossvalI)
+ ru1ThrN <- ifelse(orthoI == 0, ifelse(nrow(xMN) > 100, yes = 0, no = 0.05), 0.01)
+ ssyTotN <- rs0N <- sum(yMN^2, na.rm = TRUE)
+ hN <- 1
+
+ orthoNamVc <- paste("o", 1:orthoI, sep = "");
+ toMN <- matrix(0, nrow = nrow(xMN), ncol = orthoI,
+ dimnames = list(obsNamVc, orthoNamVc));
+ woMN <- poMN <- matrix(0, nrow = ncol(xMN), ncol = orthoI,
+ dimnames = list(xvaNamVc, orthoNamVc));
+ coMN <- matrix(0, nrow = ncol(yMN), ncol = orthoI,
+ dimnames = list(yvaNamVc, orthoNamVc));
+ modelDF <- as.data.frame(matrix(NA, nrow = 1 + orthoI +
+ 1, ncol = 7, dimnames = list(c("p1", orthoNamVc,
+ "sum"), c("R2X", "R2X(cum)", "R2Y", "R2Y(cum)",
+ "Q2", "Q2(cum)", "Signif."))));
+ for (j in 1:ncol(modelDF)){
+ mode(modelDF[, j]) <- ifelse(colnames(modelDF)[j] == "Signif.", "character", "numeric")
+ }
+ xcvTraLs <- lapply(cvfOutLs, function(obsVi) xMN[-obsVi, , drop = FALSE])
+ xcvTesLs <- lapply(cvfOutLs, function(obsVi) xMN[obsVi, , drop = FALSE])
+ ycvTraLs <- lapply(cvfOutLs, function(obsVi) yMN[-obsVi, , drop = FALSE])
+ ycvTesLs <- lapply(cvfOutLs, function(obsVi) yMN[obsVi, , drop = FALSE])
+ xcvTraLs <- c(xcvTraLs, list(xMN))
+ ycvTraLs <- c(ycvTraLs, list(yMN))
+ breL <- FALSE
+
+ for (noN in 1:(orthoI + 1)) {
+ if (breL){
+ break
+ }
+ for (cvN in 1:length(xcvTraLs)) {
+
+ xcvTraMN <- xcvTraLs[[cvN]]
+ ycvTraMN <- ycvTraLs[[cvN]]
+ if (ncol(ycvTraMN) > 1) {
+ wwMN <- apply(ycvTraMN, 2, function(colVn) crossprod(xcvTraMN, colVn)/drop(crossprod(colVn)))
+ wwSvdLs <- svd(wwMN)
+ wwNcpVin <- which(wwSvdLs[["d"]]^2 > epsN * sum(wwSvdLs[["d"]]^2))
+ twMN <- wwSvdLs[["u"]][, wwNcpVin, drop = FALSE] %*% diag(wwSvdLs[["d"]][wwNcpVin], nrow = length(wwNcpVin))
+ }
+ uOldVn <- ycvTraMN[, 1, drop = FALSE]
+ repeat {
+ wVn <- crossprod(xcvTraMN, uOldVn)/drop(crossprod(uOldVn))
+ wVn <- wVn/sqrt(drop(crossprod(wVn)))
+ tVn <- xcvTraMN %*% wVn
+ cVn <- crossprod(ycvTraMN, tVn)/drop(crossprod(tVn))
+ uVn <- ycvTraMN %*% cVn/drop(crossprod(cVn))
+ dscN <- drop(sqrt(crossprod((uVn - uOldVn)/uVn)))
+ if (ncol(ycvTraMN) == 1 || dscN < 1e-10) {
+ break
+ }else {
+ uOldVn <- uVn
+ }
+ }
+ pVn <- crossprod(xcvTraMN, tVn)/drop(crossprod(tVn))
+ if (ncol(ycvTraMN) > 1){
+ for (j in 1:ncol(twMN)) {
+ woVn <- pVn - drop(crossprod(twMN[,
+ j, drop = FALSE], pVn))/drop(crossprod(twMN[,
+ j, drop = FALSE])) * twMN[, j, drop = FALSE];
+ }
+ } else {
+ woVn <- pVn - drop(crossprod(wVn, pVn))/drop(crossprod(wVn)) * wVn
+ }
+ woVn <- woVn/sqrt(drop(crossprod(woVn)))
+ toVn <- xcvTraMN %*% woVn
+ coVn <- crossprod(ycvTraMN, toVn)/drop(crossprod(toVn))
+ poVn <- crossprod(xcvTraMN, toVn)/drop(crossprod(toVn))
+
+ if (cvN <= crossvalI) {
+ xcvTesMN <- xcvTesLs[[cvN]]
+ ycvTesMN <- ycvTesLs[[cvN]]
+ if (any(is.na(xcvTesMN))) {
+ prxVn <- numeric(nrow(xcvTesMN))
+ for (r in 1:length(prxVn)) {
+ comVl <- complete.cases(xcvTesMN[r, ])
+ prxVn[r] <- crossprod(xcvTesMN[r, comVl], wVn[comVl])/drop(crossprod(wVn[comVl]))
+ }
+ prkVn[cvN] <- sum((ycvTesMN - prxVn %*% t(cVn))^2, na.rm = TRUE)
+ } else {
+ prkVn[cvN] <- sum((ycvTesMN - xcvTesMN %*% wVn %*% t(cVn))^2, na.rm = TRUE)
+ }
+ toTesVn <- xcvTesMN %*% woVn
+ xcvTesLs[[cvN]] <- xcvTesMN - tcrossprod(toTesVn, poVn)
+ if (cvN == crossvalI) {
+ q2N <- 1 - sum(prkVn)/rs0N
+ if (noN == 1) {
+ modelDF["p1", "Q2(cum)"] <- modelDF["p1", "Q2"] <- q2N
+ } else {
+ modelDF[noN, "Q2(cum)"] <- q2N - modelDF["p1", "Q2"]
+ modelDF[noN, "Q2"] <- q2N - sum(modelDF[1:(noN - 1), "Q2"], na.rm = TRUE)
+ }
+ }
+ } else {
+ r2yN <- sum(tcrossprod(tVn, cVn)^2)/ssyTotN
+ if (noN == 1) {
+ modelDF["p1", "R2Y(cum)"] <- modelDF["p1", "R2Y"] <- r2yN
+ } else {
+ modelDF[noN, "R2Y(cum)"] <- r2yN - modelDF["p1", "R2Y"]
+ modelDF[noN, "R2Y"] <- r2yN - sum(modelDF[1:(noN - 1), "R2Y"], na.rm = TRUE)
+ }
+ if (noN <= orthoI) {
+ modelDF[paste0("o", noN), "R2X"] <- sum(tcrossprod(toVn,poVn)^2)/ssxTotN
+ poMN[, noN] <- poVn
+ toMN[, noN] <- toVn
+ woMN[, noN] <- woVn
+ coMN[, noN] <- coVn
+ }
+
+ if (!is.na(modelDF[noN, "R2Y"]) & modelDF[noN, "R2Y"] < 0.01) {
+ modelDF[noN, "Signif."] <- "N4"
+ } else if (!is.na(modelDF[noN, "Q2"]) & modelDF[noN, "Q2"] < ru1ThrN) {
+ modelDF[noN, "Signif."] <- "NS"
+ } else {
+ modelDF[noN, "Signif."] <- "R1"
+ }
+
+ if (autNcoL && modelDF[noN, "Signif."] != "R1" && noN > 2) {
+ breL <- TRUE
+ break
+ } else {
+ cMN[, 1] <- cVn
+ pMN[, 1] <- pVn
+ tMN[, 1] <- tVn
+ uMN[, 1] <- uVn
+ wMN[, 1] <- wVn
+ }
+ }
+ if (breL) {
+ break;
+ }
+ if (noN < orthoI + 1){
+ xcvTraLs[[cvN]] <- xcvTraMN - tcrossprod(toVn, poVn);
+ }
+ }
+ }
+
+ rm(xcvTraLs)
+ rm(xcvTesLs)
+ rm(ycvTraLs)
+
+ modelDF["p1", "R2X(cum)"] <- modelDF["p1", "R2X"] <- sum(tcrossprod(tMN, pMN)^2)/ssxTotN
+ modelDF[1:(1 + orthoI), "R2X(cum)"] <- cumsum(modelDF[1:(1 + orthoI), "R2X"]);
+
+ if (autNcoL) {
+ if (all(modelDF[, "Signif."] == "R1", na.rm = TRUE)) {
+ orthoI <- noN - 1
+ }else{
+ orthoI <- noN - 3
+ }
+
+ if (orthoI == autMaxN - 1){
+ warning("The maximum number of orthogonal components in the automated mode (",
+ autMaxN - 1, ") has been reached whereas R2Y (",
+ round(modelDF[1 + orthoI, "R2Y"] * 100),
+ "%) is above 1% and Q2Y (", round(modelDF[1 +
+ orthoI, "Q2"] * 100), "%) is still above ",
+ round(ru1ThrN * 100), "%.", call. = FALSE)
+ }
+ poMN <- poMN[, 1:orthoI, drop = FALSE]
+ toMN <- toMN[, 1:orthoI, drop = FALSE]
+ woMN <- woMN[, 1:orthoI, drop = FALSE]
+ coMN <- coMN[, 1:orthoI, drop = FALSE]
+ orthoNamVc <- orthoNamVc[1:orthoI]
+ modelDF <- modelDF[c(1:(orthoI + 1), nrow(modelDF)), ]
+ }
+
+ modelDF["sum", "R2X(cum)"] <- modelDF[1 + orthoI, "R2X(cum)"]
+ modelDF["sum", "R2Y(cum)"] <- sum(modelDF[, "R2Y"], na.rm = TRUE)
+ modelDF["sum", "Q2(cum)"] <- sum(modelDF[, "Q2"], na.rm = TRUE)
+ summaryDF <- modelDF["sum", c("R2X(cum)", "R2Y(cum)", "Q2(cum)")]
+ rMN <- wMN
+ bMN <- tcrossprod(rMN, cMN)
+ yPreScaMN <- tcrossprod(tMN, cMN)
+ yPreMN <- scale(scale(yPreScaMN, FALSE, 1/ySdVn), -yMeanVn, FALSE)
+ attr(yPreMN, "scaled:center") <- NULL
+ attr(yPreMN, "scaled:scale") <- NULL
+
+ yActMCN <- yMCN
+ yActMN <- yActMCN
+ summaryDF[, "RMSEE"] <- sqrt(.errorF(yActMN, yPreMN)^2 * nrow(yActMN)/(nrow(yActMN) - (1 + predI + orthoI)))
+ yTestMCN <- NULL
+
+ sxpVn <- sapply(1:ncol(tMN), function(h) sum(drop(tcrossprod(tMN[, h], pMN[, h])^2)))
+ sxpCumN <- sum(sxpVn)
+ sxoVn <- sapply(1:ncol(toMN), function(h) sum(drop(tcrossprod(toMN[, h], poMN[, h])^2)))
+ sxoCumN <- sum(sxoVn)
+ ssxCumN <- sxpCumN + sxoCumN
+ sypVn <- sapply(1:ncol(tMN), function(h) sum(drop(tcrossprod(tMN[, h], cMN[, h])^2)))
+ sypCumN <- sum(sypVn)
+ syoVn <- sapply(1:ncol(toMN), function(h) sum(drop(tcrossprod(toMN[,
+ h], coMN[, h])^2)))
+ syoCumN <- sum(syoVn)
+ ssyCumN <- sypCumN + syoCumN
+ kpN <- nrow(wMN)/(sxpCumN/ssxCumN + sypCumN/ssyCumN)
+ pNorMN <- sweep(pMN, 2, sqrt(colSums(pMN^2)), "/")
+ vipVn <- sqrt(kpN * (rowSums(sweep(pNorMN^2, 2, sxpVn,
+ "*"))/ssxCumN + rowSums(sweep(pNorMN^2, 2, sypVn,
+ "*"))/ssyCumN))
+ koN <- nrow(wMN)/(sxoCumN/ssxCumN + syoCumN/ssyCumN)
+ poNorMN <- sweep(poMN, 2, sqrt(colSums(poMN^2)),"/")
+ orthoVipVn <- sqrt(koN * (rowSums(sweep(poNorMN^2,
+ 2, sxoVn, "*"))/ssxCumN + rowSums(sweep(poNorMN^2,
+ 2, syoVn, "*"))/ssyCumN))
+
+ summaryDF[, "pre"] <- predI
+ summaryDF[, "ort"] <- orthoI
+ rownames(summaryDF) <- "Total"
+ sigNamVc <- c("R2X", "R2X(cum)", "R2Y", "R2Y(cum)", "Q2",
+ "Q2(cum)", "RMSEE", "RMSEP")
+ for (namC in intersect(colnames(modelDF), sigNamVc)) modelDF[,
+ namC] <- signif(modelDF[, namC], 3)
+ for (namC in intersect(colnames(summaryDF), sigNamVc)) summaryDF[,
+ namC] <- signif(summaryDF[, namC], 3)
+ retLs <- list(typeC = NULL, modelDF = modelDF,
+ summaryDF = summaryDF, pcaVarVn = varVn,
+ vipVn = vipVn, orthoVipVn = orthoVipVn, fitted = NULL,
+ tested = NULL, coefficients = bMN, residuals = NULL,
+ xMeanVn = xMeanVn, xSdVn = xSdVn, yMeanVn = yMeanVn,
+ ySdVn = ySdVn, xZeroVarVi = NULL, scoreMN = tMN, loadingMN = pMN,
+ weightMN = wMN, orthoScoreMN = toMN, orthoLoadingMN = poMN,
+ orthoWeightMN = woMN, cMN = cMN, uMN = uMN, weightStarMN = rMN,
+ coMN = coMN, suppLs = list(yLevelVc = NULL, naxL = naxL, nayL = nayL, nayVi = nayVi,
+ permMN = NULL, scaleC = scaleC, topLoadI = NULL,
+ yMCN = yMCN, xSubIncVarMN = NULL, xCorMN = NULL,
+ xModelMN = xMN, yModelMN = yMN, yPreMN = yPreMN,
+ yTesMN = yTesMN))
+}
+
+.errorF <- function(x, y){
+ sqrt(mean(drop((x - y)^2), na.rm = TRUE))
+}
+
+.similarityF <- function(x, y) {
+ return(cor(x, y, use = "pairwise.complete.obs"))
+}
+
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/stats_peaks.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/stats_peaks.R
new file mode 100755
index 0000000000000000000000000000000000000000..3bf35b047a0d1855a85a7e2cc9d59731ac751f0b
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/stats_peaks.R
@@ -0,0 +1,623 @@
+#'Read peak list files
+#'@description This function reads peak list files and fills the data into a dataSet object.
+#'For NMR peak lists, the input should be formatted as two-columns containing numeric values (ppm, int).
+#'Further, this function will change ppm to mz, and add a dummy 'rt'.
+#'For MS peak data, the lists can be formatted as two-columns (mz, int), in which case the function will add a dummy 'rt', or
+#'the lists can be formatted as three-columns (mz, rt, int).
+#'@usage Read.PeakList(mSetObj=NA, foldername)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects).
+#'@param foldername Name of the folder containing the NMR or MS peak list files to read.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@import qs
+#'@export
+
+Read.PeakList<-function(mSetObj=NA, foldername="upload"){
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(.on.public.web){
+ dyn.load(.getDynLoadPath());
+ }
+
+ msg <- c("The uploaded files are peak lists and intensities data.");
+
+ # the "upload" folder should contain several subfolders (groups)
+ # each of the subfolder contains samples (.csv files)
+ files<-dir(foldername, pattern=".[Cc][Ss][Vv]$", recursive=T, full.name=TRUE)
+ if (length(files) == 0) {
+ AddErrMsg("No peak list files (.csv) were found.");
+ return(0);
+ }
+
+ snames <- gsub("\\.[^.]*$", "", basename(files));
+ msg<-c(msg, paste("A total of ", length(files), "samples were found."));
+
+ sclass <- gsub("^\\.$", "sample", dirname(files));
+
+ scomp <- strsplit(substr(sclass, 1, min(nchar(sclass))), "", fixed=TRUE);
+ scomp <- matrix(c(scomp, recursive = TRUE), ncol = length(scomp));
+ i <- 1
+ while(all(scomp[i,1] == scomp[i,-1]) && i < nrow(scomp)){
+ i <- i + 1;
+ }
+ i <- min(i, tail(c(0, which(scomp[1:i,1] == .Platform$file.sep)), n = 1) + 1)
+ if (i > 1 && i <= nrow(scomp)){
+ sclass <- substr(sclass, i, max(nchar(sclass)))
+ }
+
+ # some sanity check before proceeds
+ sclass <- as.factor(sclass);
+ if(length(levels(sclass))<2){
+ AddErrMsg("You must provide classes labels (at least two classes)!");
+ return(0);
+ }
+
+ # check for class labels at least three replicates per class
+ if(min(table(sclass)) < 3){
+ AddErrMsg("At least three replicates are required in each group!");
+ return(0);
+ }
+
+ # check for unique sample names
+ if(length(unique(snames))!=length(snames)){
+ AddErrMsg("Duplcate sample names are not allowed!");
+ dup.nm <- paste(snames[duplicated(snames)], collapse=" ");
+ AddErrMsg("Duplicate sample names are not allowed!");
+ AddErrMsg(dup.nm);
+ return(0);
+ }
+
+ # change sample names to numbers
+ samp.num<-seq(1:length(snames));
+ names(samp.num)<-snames;
+
+ # create a matrix "all.peaks" which is compatible with the xcmsSet@peaks matrix, so that the grouping algorithm can be used directly
+ # the matrix should have "mz", "rt", "into", "sample" - 4 columns used for grouping
+ # check 2 or 3 column
+
+ ############## use try block to catch any error ##############
+ pks<- .readDataTable(files[1]);
+ if(class(pks) == "try-error") {
+ AddErrMsg("The CSV file is not formatted correctly!");
+ return(0);
+ };
+ pks <- as.matrix(pks);
+ ########################################################
+
+ n.col<-ncol(pks);
+ if(n.col==2){
+ add=TRUE;
+ }else if(n.col==3){
+ add=FALSE;
+ }else{
+ AddErrMsg("The peak list file can only contain 2 or 3 columns.");
+ return(0);
+ }
+
+ all.peaks<-NULL;
+
+ for(i in 1:length(files)){
+ print(files[i]);
+ pks<- as.matrix(.readDataTable(files[i]));
+ if(ncol(pks)!=n.col){
+ AddErrMsg("The number of columns in each file are not the same!");
+ return(0);
+ }
+
+ if(add){ # NMR ppm+int or MS mz+int
+ pks<-cbind(pks[,1], 1000, pks[,2],samp.num[i]);
+ }else{
+ pks<-cbind(pks,samp.num[i]);
+ }
+ all.peaks<-rbind(all.peaks, pks);
+ }
+
+
+ # make sure all values are numeric, sometimes users give other text values, need to exclude them
+ all.peaks <- apply(all.peaks, 2, as.numeric);
+ gd.inx <- complete.cases(all.peaks);
+ all.peaks <- all.peaks[gd.inx,]
+
+ if(sum(!gd.inx) > 0){
+ msg<-c(msg, paste("<font color='red'>A total of", sum(!gd.inx), "peaks were excluded due to non-numeric values. </font>" ));
+ }
+ msg<-c(msg, paste("These samples contain a total of ", dim(all.peaks)[1], "peaks," ));
+ msg<-c(msg, paste("with an average of ", round(dim(all.peaks)[1]/length(files), 1), "peaks per sample" ));
+
+ colnames(all.peaks)<-c("mz","rt","int","sample");
+
+ peakSet<-list(
+ peaks = all.peaks,
+ ncol = n.col,
+ sampclass = sclass,
+ sampnames = snames
+ );
+
+ qs::qsave(peakSet, "peakSet.qs");
+ mSetObj$msgSet$read.msg <- msg;
+ return(.set.mSet(mSetObj));
+}
+
+#' Read an mzTab tab separated file from the passed in file.
+#' Adapted from: https://github.com/lifs-tools/rmzTab-m/blob/master/R/MzTabReader.r
+#' @param mSetObj Input the name of the created mSetObj (see InitDataObjects).
+#' @param filename The name of the mzTab file to parse.
+#' @param identifier The identifier to be used when the table is parsed. Use "name"
+#' to use the chemical_name, "mass" to use the theoretical_neutral_mass and "sml_id"
+#' to use the SML_ID. If the number of missing name and mass entries is greater than 90%,
+#' then the SML_ID will be used.
+#' @export
+Read.mzTab <- function(mSetObj=NA, filename, identifier = "name") {
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ msg <- NULL;
+
+ # read maximum number of columns in file
+ ncol <- max(stats::na.omit(utils::count.fields(file=filename, sep = "\t")))
+
+ mztab.table = utils::read.table(file=filename, header=FALSE,
+ row.names=NULL, dec = ".", fill = TRUE,
+ col.names = paste0("V", seq_len(ncol)),
+ sep="\t", na.strings="null", quote = "",
+ stringsAsFactors = FALSE)
+
+ # first sanity check
+ # check if contains MTD, SMH and SML
+ if(sum(sapply(c("MTD", "SMH", "SML"), grepl, unique(mztab.table$V1))) == 3){
+ msg <- ("mzTab format ok!")
+ }else{
+ AddErrMsg("Invalid mzTab format! Make sure mzTab file has been validated!")
+ return(0)
+ }
+
+ # first set up metadata
+ metadata <- mztab.table[startsWith(as.character(mztab.table$V1), "MTD"),]
+ variables <- metadata[grepl("study_variable", metadata$V2),]
+
+ if(length(variables) < 1){
+ AddErrMsg("Invalid mzTab format! Make sure mzTab file has been validated!")
+ return(0)
+ }
+
+ variables.groups <- unique(gsub("-.*", "", variables$V2))
+ group.names <- metadata$V3[match(variables.groups, metadata$V2)]
+
+ variables.list <- vector("list", length=length(variables.groups))
+ names(variables.list) <- variables.groups
+
+ for(i in 1:length(variables.groups)){
+ group2match <- gsub("\\[", "\\\\[", variables.groups[i])
+ group2match <- gsub("\\]", "\\\\]", group2match)
+ all.info <- variables[grepl(group2match, variables$V2),]
+ assay.refs <- all.info$V3[grepl("assay_refs", all.info$V2)]
+ variables.list[i] <- assay.refs
+ }
+
+ # second set up small molecule summary
+ smh <- mztab.table[startsWith(as.character(mztab.table$V1), "SMH"),,drop=FALSE]
+ sml <- mztab.table[startsWith(as.character(mztab.table$V1), "SML"),,drop=FALSE]
+
+ if(nrow(sml) < 1){
+ AddErrMsg("Invalid mzTab format! Make sure mzTab file has been validated!")
+ return(0)
+ }
+
+ sml.data.frame <- data.frame(sml, stringsAsFactors = FALSE)
+ colnames(sml.data.frame) <- as.character(smh[1,])
+
+ # sanity check to see if selected identifier is valid
+ # if more than 90% of names are null, switch to use m/z
+ # if more than 90% of m/z are null, switch to use sml_id
+ if(sum(is.null(sml.data.frame$chemical_name))/length(sml.data.frame$chemical_name) > 0.1) {
+ msg <- c(msg, "Too many missing chemical names, will use theoretical neutral mass instead!")
+ identifier <- "mass"
+ }else if(sum(is.null(sml.data.frame$theoretical_neutral_mass))/length(sml.data.frame$theoretical_neutral_mass) > 0.1){
+ msg <- c(msg, "Too many missing m/z, will use mzTab SML_ID instead!")
+ identifier <- "sml_id"
+ }else if(sum(is.na(sml.data.frame$theoretical_neutral_mass))/length(sml.data.frame$theoretical_neutral_mass) > 0.1){ # sometime it's NA
+ msg <- c(msg, "Too many missing m/z, will use mzTab SML_ID instead!")
+ identifier <- "sml_id"
+ }
+
+ # deal with duplicates in selected ids
+ if(identifier == "name"){
+ id.og <- id <- sml.data.frame$chemical_name
+ dup.id <- paste(sml.data.frame$chemical_name, sml.data.frame$adduct_ions, sep="_")
+ id[which(duplicated(id, fromLast = TRUE) | duplicated(id))] <- dup.id[which(duplicated(id, fromLast = TRUE) | duplicated(id))]
+ }else if(identifier == "mass"){
+ id.og <- id <- round(as.numeric(sml.data.frame$theoretical_neutral_mass), 5)
+ dup.id <- paste( round(as.numeric(sml.data.frame$theoretical_neutral_mass), 5), sml.data.frame$adduct_ions, sep="_")
+ id[which(duplicated(id, fromLast = TRUE) | duplicated(id))] <- dup.id[which(duplicated(id, fromLast = TRUE) | duplicated(id))]
+ }else{
+ id <- sml.data.frame$SML_ID;
+ }
+
+ # sanity check to see if selected id is valid
+ # if ids are still duplicates, switch to append sml_id
+ if(sum(duplicated(id)) > 1){
+ id <- paste(id.og, sml.data.frame$SML_ID, sep="_")
+ }
+
+ assay_data <- trimws(unlist( lapply(variables.list, function(x) strsplit(x, "\\|")) ))
+ assay_data <- paste("abundance_", assay_data, sep="")
+ assay_df <- sml.data.frame[,match(assay_data, colnames(sml.data.frame))]
+
+ assay_table <- cbind.data.frame(Sample=id, assay_df, stringsAsFactors = FALSE)
+
+ # replace colnames with actual variable groups
+ samples <- colnames(assay_table)[-1]
+ samples_base <- gsub("abundance_", "", samples)
+ variables.list <- lapply(variables.list, function(x) trimws(unlist(strsplit(x, "\\|"))))
+
+ samples2groups <- vector(length = length(samples_base))
+
+ for(i in 1:length(samples_base)){
+ samples2groups[i] <- group.names[sapply(variables.list, function(x) samples_base[i] %in% x)]
+ }
+
+ # remove blank from dataframe
+ blank.inx <- grepl("blank", samples2groups, ignore.case = TRUE)
+
+ if(sum(blank.inx) > 0){
+ samples2groups <- samples2groups[!blank.inx]
+ assay_table <- cbind.data.frame(Sample=id, assay_df[,!blank.inx], stringsAsFactors = FALSE)
+ }
+
+ assay_table_all <- rbind.data.frame(c("Group", samples2groups), assay_table)
+ colnames(assay_table_all) <- gsub("\\[|\\]", "", colnames(assay_table_all))
+
+ fast.write.csv(assay_table_all, "mzTab_parsed.csv", row.names = F)
+
+ mSetObj$dataSet$cls.type <- "disc";
+ mSetObj$dataSet$format <- "colu";
+
+ dat <- assay_table_all
+ msg <- c(msg, "Samples are in columns and features in rows.");
+ var.nms <- dat[-1,1];
+ dat[,1] <- NULL;
+ smpl.nms <- colnames(dat);
+ cls.lbl <- unname(unlist(dat[1,]));
+ conc <- t(dat[-1,]);
+ mSetObj$dataSet$type.cls.lbl <- class(cls.lbl);
+
+ # free memory
+ dat <- NULL;
+
+ msg <- c(msg, "The uploaded file is in the mzTab format.");
+
+ # try to remove empty line if present
+ # identified if no sample names provided
+
+ empty.inx <- is.na(smpl.nms) | smpl.nms == ""
+ if(sum(empty.inx) > 0){
+ msg <- c(msg, paste("<font color=\"red\">", sum(empty.inx), "empty rows</font> were detected and excluded from your data."));
+ smpl.nms <- smpl.nms[!empty.inx];
+ cls.lbl <- cls.lbl[!empty.inx];
+ conc <- conc[!empty.inx, ];
+ }
+
+ # try to check & remove empty lines if class label is empty
+ # Added by B. Han
+ empty.inx <- is.na(cls.lbl) | cls.lbl == ""
+ if(sum(empty.inx) > 0){
+ if(mSetObj$analSet$type != "roc"){
+ msg <- c(msg, paste("<font color=\"red\">", sum(empty.inx), "empty labels</font> were detected and excluded from your data."));
+ smpl.nms <- smpl.nms[!empty.inx];
+ cls.lbl <- cls.lbl[!empty.inx];
+ conc <- conc[!empty.inx, ];
+ }else{
+ # force all NA to empty string, otherwise NA will become "NA" class label
+ cls.lbl[is.na(cls.lbl)] <- "";
+ msg <- c(msg, paste("<font color=\"orange\">", sum(empty.inx), "new samples</font> were detected from your data."));
+ }
+ }
+
+ # check for uniqueness of dimension name
+ if(length(unique(smpl.nms))!=length(smpl.nms)){
+ dup.nm <- paste(smpl.nms[duplicated(smpl.nms)], collapse=" ");
+ AddErrMsg("Duplicate sample names are not allowed!");
+ AddErrMsg(dup.nm);
+ return(0);
+ }
+
+ # try to remove check & remove empty line if feature name is empty
+ empty.inx <- is.na(var.nms) | var.nms == "";
+ if(sum(empty.inx) > 0){
+ msg <- c(msg, paste("<font color=\"red\">", sum(empty.inx), "empty features</font> were detected and excluded from your data."));
+ var.nms <- var.nms[!empty.inx];
+ conc <- conc[,!empty.inx];
+ }
+
+ if(length(unique(var.nms))!=length(var.nms)){
+ dup.nm <- paste(var.nms[duplicated(var.nms)], collapse=" ");
+ AddErrMsg("Duplicate feature names are not allowed!");
+ AddErrMsg(dup.nm);
+ return(0);
+ }
+
+ # now check for special characters in the data labels
+ if(sum(is.na(iconv(smpl.nms)))>0){
+ na.inx <- is.na(iconv(smpl.nms));
+ nms <- paste(smpl.nms[na.inx], collapse="; ");
+ AddErrMsg(paste("No special letters (i.e. Latin, Greek) are allowed in sample names!", nms, collapse=" "));
+ return(0);
+ }
+
+ if(sum(is.na(iconv(var.nms)))>0){
+ na.inx <- is.na(iconv(var.nms));
+ nms <- paste(var.nms[na.inx], collapse="; ");
+ AddErrMsg(paste("No special letters (i.e. Latin, Greek) are allowed in feature names!", nms, collapse=" "));
+ return(0);
+ }
+
+ # only keep alphabets, numbers, ",", "." "_", "-" "/"
+ orig.smp.nms <- smpl.nms;
+ smpl.nms <- CleanNames(smpl.nms, "sample_name");
+ names(orig.smp.nms) <- smpl.nms;
+
+ # keep a copy of original names for saving tables
+ orig.var.nms <- var.nms;
+ var.nms <- CleanNames(var.nms, "var_name"); # allow space, comma and period
+ names(orig.var.nms) <- var.nms;
+
+ cls.lbl <- ClearStrings(as.vector(cls.lbl));
+
+ # now assgin the dimension names
+ rownames(conc) <- smpl.nms;
+ colnames(conc) <- var.nms;
+
+ # check for class labels at least two replicates per class
+ if(min(table(cls.lbl)) < 3){
+ AddErrMsg(paste ("A total of", length(levels(as.factor(cls.lbl))), "groups found with", length(smpl.nms), "samples."));
+ AddErrMsg("At least three replicates are required in each group!");
+ AddErrMsg("Or maybe you forgot to specify the data format?");
+ return(0);
+ }
+
+ if(length(unique(cls.lbl)) == 1){
+ AddErrMsg("At least two groups are required for statistical analysis!");
+ return(0);
+ }
+
+ mSetObj$dataSet$orig.cls <- mSetObj$dataSet$cls <- as.factor(as.character(cls.lbl));
+ mSetObj$dataSet$mumType <- "table";
+ mSetObj$dataSet$orig.var.nms <- orig.var.nms;
+ mSetObj$dataSet$orig.smp.nms <- orig.smp.nms;
+ #mSetObj$dataSet$orig <- conc; # copy to be processed in the downstream
+ qs::qsave(conc, file="data_orig.qs");
+ mSetObj$msgSet$read.msg <- c(msg, paste("The uploaded data file contains ", nrow(conc),
+ " (samples) by ", ncol(conc), " (", tolower(GetVariableLabel(mSetObj$dataSet$type)), ") data matrix.", sep=""));
+ return(.set.mSet(mSetObj));
+}
+
+
+#'Group peak list
+#'@description Group peaks from the peak list based on position
+#'using the XCMS grouping algorithm (align peaks wrt, rt, and mz).
+#'For NMR peaks, need to change ppm -> mz and add dummy rt.
+#'If the data is 2-column MS, first need to add dummy rt.
+#'If the data is 3-column MS, the data can be used directly.
+#'The default mzwid for MS is 0.25 m/z, and for NMR is 0.03 ppm.
+#'The default bw is 30 for LCMS, and 5 for GCMS.
+#'@usage GroupPeakList(mSetObj=NA, mzwid, bw, minfrac, minsamp, max)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param mzwid, define the width of overlapping m/z slices to use for creating peak density chromatograms
+#'and grouping peaks across samples
+#'@param bw, define the bandwidth (standard deviation or half width at half maximum) of gaussian smoothing
+#'kernel to apply to the peak density chromatogram
+#'@param minfrac, define the minimum fraction of samples necessary in at least one of the sample groups for
+#'it to be a valid group
+#'@param minsamp, define the minimum number of samples necessary in at least one of the sample groups for
+#'it to be a valid group
+#'@param max, define the maximum number of groups to identify in a single m/z slice
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@import qs
+#'@export
+#'
+GroupPeakList <- function(mSetObj=NA, mzwid = 0.25, bw = 30, minfrac = 0.5, minsamp = 1, max = 50) {
+ mSetObj <- .get.mSet(mSetObj);
+ peakSet <- qs::qread("peakSet.qs");
+ samples <- peakSet$sampnames;
+ classlabel <- peakSet$sampclass;
+ classnames <- levels(classlabel)
+
+ classlabel <- as.vector(unclass(classlabel))
+ classnum <- integer(max(classlabel))
+ for (i in seq(along = classnum)){
+ classnum[i] <- sum(classlabel == i)
+ }
+
+ peakmat <- peakSet$peaks;
+ porder <- order(peakmat[,"mz"]);
+ peakmat <- peakmat[porder,,drop=F]
+ rownames(peakmat) <- NULL
+ retrange <- range(peakmat[,"rt"])
+
+ minpeakmat <- min(classnum)/2
+
+ mass <- seq(peakmat[1,"mz"], peakmat[nrow(peakmat),"mz"] + mzwid, by = mzwid/2)
+ masspos <- findEqualGreaterM(peakmat[,"mz"], mass)
+
+ groupmat <- matrix(nrow = 512, ncol = 7 + length(classnum))
+ groupindex <- vector("list", 512)
+
+ endidx <- 0
+ num <- 0
+ gcount <- integer(length(classnum))
+ for (i in seq(length = length(mass)-2)) {
+ startidx <- masspos[i]
+ endidx <- masspos[i+2]-1
+ if (endidx - startidx + 1 < minpeakmat)
+ next
+ speakmat <- peakmat[startidx:endidx,,drop=FALSE]
+ den <- density(speakmat[,"rt"], bw, from = retrange[1]-3*bw, to = retrange[2]+3*bw)
+ maxden <- max(den$y)
+ deny <- den$y
+ gmat <- matrix(nrow = 5, ncol = 2+length(classnum))
+ snum <- 0
+ while (deny[maxy <- which.max(deny)] > maxden/20 && snum < max) {
+ grange <- descendMin(deny, maxy)
+ deny[grange[1]:grange[2]] <- 0
+ gidx <- which(speakmat[,"rt"] >= den$x[grange[1]] & speakmat[,"rt"] <= den$x[grange[2]])
+ gnum <- classlabel[unique(speakmat[gidx,"sample"])]
+ for (j in seq(along = gcount))
+ gcount[j] <- sum(gnum == j)
+ if (! any(gcount >= classnum*minfrac & gcount >= minsamp))
+ next
+ snum <- snum + 1
+ num <- num + 1
+ ### Double the size of the output containers if they're full
+ if (num > nrow(groupmat)) {
+ groupmat <- rbind(groupmat, matrix(nrow = nrow(groupmat), ncol = ncol(groupmat)))
+ groupindex <- c(groupindex, vector("list", length(groupindex)))
+ }
+ groupmat[num, 1] <- median(speakmat[gidx, "mz"])
+ groupmat[num, 2:3] <- range(speakmat[gidx, "mz"])
+ groupmat[num, 4] <- median(speakmat[gidx, "rt"])
+ groupmat[num, 5:6] <- range(speakmat[gidx, "rt"])
+ groupmat[num, 7] <- length(gidx)
+ groupmat[num, 7+seq(along = gcount)] <- gcount
+ groupindex[[num]] <- sort(porder[(startidx:endidx)[gidx]])
+ }
+ }
+ colnames(groupmat) <- c("mzmed", "mzmin", "mzmax", "rtmed", "rtmin", "rtmax",
+ "npeaks", classnames)
+
+ groupmat <- groupmat[seq(length = num),]
+ groupindex <- groupindex[seq(length = num)]
+
+ # Remove groups that overlap with more "well-behaved" groups
+ numsamp <- rowSums(groupmat[,(match("npeaks", colnames(groupmat))+1):ncol(groupmat),drop=FALSE])
+ uorder <- order(-numsamp, groupmat[,"npeaks"])
+ uindex <- rectUnique(groupmat[,c("mzmin","mzmax","rtmin","rtmax"),drop=FALSE],uorder)
+
+ peakSet$groups <- groupmat[uindex,];
+ peakSet$groupidx<- groupindex[uindex];
+ qs::qsave(peakSet, "peakSet.qs");
+ return(.set.mSet(mSetObj));
+}
+
+#'Set peak list group values
+#'@param mSetObj Input name of mSetObj, the data used is the nmr.xcmsSet object
+#'@import qs
+#'@export
+#'
+SetPeakList.GroupValues <- function(mSetObj=NA) {
+ mSetObj <- .get.mSet(mSetObj);
+ peakSet <- qs::qread("peakSet.qs");
+ msg <- mSetObj$msgSet$peakMsg;
+
+ peakmat <- peakSet$peaks;
+ groupmat <- peakSet$groups;
+ groupindex <- peakSet$groupidx;
+
+ sampnum <- seq(length = length(peakSet$sampnames))
+ intcol <- match("int", colnames(peakmat))
+ sampcol <- match("sample", colnames(peakmat))
+
+ # row is peak, col is sample
+ values <- matrix(nrow = length(groupindex), ncol = length(sampnum))
+
+ for (i in seq(along = groupindex)) {
+ # for each group, replace multiple peaks from the same sample by their sum
+ for(m in sampnum){
+ samp.inx<-which(peakmat[groupindex[[i]], sampcol]==m)
+ if(length(samp.inx)>0){
+ values[i, m] <- sum(peakmat[groupindex[[i]][samp.inx], intcol]);
+ }else{
+ values[i, m] <- NA;
+ }
+ }
+ }
+
+ msg<-c(msg, paste("A total of", length(groupindex), "peak groups were formed. "));
+ msg<-c(msg, paste("Peaks of the same group were summed if they are from one sample. "));
+ msg<-c(msg, paste("Peaks appearing in less than half of all samples in each group were ignored."));
+
+ colnames(values) <- peakSet$sampnames;
+
+ if(peakSet$ncol==2){
+ rownames(values) <- paste(round(groupmat[,paste("mz", "med", sep="")],5));
+ }else{
+ rownames(values) <- paste(round(groupmat[,paste("mz", "med", sep="")],5), "/", round(groupmat[,paste("rt", "med", sep="")],2), sep="");
+ mSetObj$dataSet$three.col <- TRUE;
+ }
+
+ #mSetObj$dataSet$orig <- t(values);
+ qs::qsave(t(values), file="data_orig.qs");
+ mSetObj$msgSet$proc.msg <- msg
+ mSetObj$dataSet$orig.cls <- as.factor(peakSet$sampclass);
+ mSetObj$dataSet$type.cls.lbl <- class(peakSet$sampclass);
+ return(.set.mSet(mSetObj));
+}
+
+########## Utility Functions ##############
+#'Perform utilities for peak grouping
+#'@description Perform various utilities for peak grouping
+#'@param y Input peaks
+#'@param istart Performs which.max on y
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+descendMin <- function(y, istart = which.max(y)) {
+
+ if (!is.double(y)) y <- as.double(y)
+ unlist(.C("DescendMin",
+ y,
+ length(y),
+ as.integer(istart-1),
+ ilower = integer(1),
+ iupper = integer(1),
+ DUP = FALSE)[4:5]) + 1
+}
+
+#'Perform utilities for peak grouping
+#'@description Perform various utilities for peak grouping
+#'@param x Input the data
+#'@param values Input the values
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+findEqualGreaterM <- function(x, values) {
+
+ if (!is.double(x)) x <- as.double(x)
+ if (!is.double(values)) values <- as.double(values)
+ .C("FindEqualGreaterM",
+ x,
+ length(x),
+ values,
+ length(values),
+ index = integer(length(values)),
+ DUP = FALSE)$index + 1
+}
+
+#'Perform utilities for peak grouping
+#'@description Perform various utilities for peak grouping
+#'@param m Peaks
+#'@param order Performs seq(length = nrow(m))
+#'@param xdiff Default set to 0
+#'@param ydiff Default set to 0
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'
+rectUnique <- function(m, order = seq(length = nrow(m)), xdiff = 0, ydiff = 0) {
+
+ nr <- nrow(m)
+ nc <- ncol(m)
+ if (!is.double(m))
+ m <- as.double(m)
+ .C("RectUnique",
+ m,
+ as.integer(order-1),
+ nr,
+ nc,
+ as.double(xdiff),
+ as.double(ydiff),
+ logical(nrow(m)),
+ DUP = FALSE)[[7]]
+}
\ No newline at end of file
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/stats_plot3d.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/stats_plot3d.R
new file mode 100755
index 0000000000000000000000000000000000000000..7ef9bb4f1afc5dd019f7ef2d5757997d087d1a00
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/stats_plot3d.R
@@ -0,0 +1,728 @@
+### R script for MetaboAnalyst
+### Description: 3D scatter plot for PDF report (not used for web display)
+### Author: Jeff Xia, jeff.xia@mcgill.ca
+### McGill University, Canada
+### License: GNU GPL (>= 2)
+
+Plot3D <- function(x, y = NULL, z = NULL, color = par("col"), pch = NULL,
+ main = NULL, sub = NULL, xlim = NULL, ylim = NULL, zlim = NULL,
+ xlab = NULL, ylab = NULL, zlab = NULL, scale.y = 1, angle = 40,
+ axis = TRUE, tick.marks = TRUE, label.tick.marks = TRUE,
+ x.ticklabs = NULL, y.ticklabs = NULL, z.ticklabs = NULL,
+ y.margin.add = 0, grid = TRUE, box = TRUE, lab = par("lab"),
+ lab.z = mean(lab[1:2]), type = "p", highlight.3d = FALSE,
+ mar = c(5, 3, 4, 3) + 0.1, col.axis = par("col.axis"),
+ col.grid = "grey", col.lab = par("col.lab"), cex.symbols = par("cex"),
+ cex.axis = 0.8 * par("cex.axis"), cex.lab = par("cex.lab"),
+ font.axis = par("font.axis"), font.lab = par("font.lab"),
+ lty.axis = par("lty"), lty.grid = 2, lty.hide = 1,
+ lty.hplot = par("lty"), log = "", ...)
+ # log not yet implemented
+{
+ ## Uwe Ligges <ligges@statistik.tu-dortmund.de>,
+ ## http://www.statistik.tu-dortmund.de/~ligges
+ ##
+ ## For MANY ideas and improvements thanks to Martin Maechler!!!
+ ## Parts of the help files are stolen from the standard plotting functions in R.
+
+ mem.par <- par(mar = mar)
+ x.scal <- y.scal <- z.scal <- 1
+ xlabel <- if (!missing(x)) deparse(substitute(x))
+ ylabel <- if (!missing(y)) deparse(substitute(y))
+ zlabel <- if (!missing(z)) deparse(substitute(z))
+
+ ## color as part of `x' (data.frame or list):
+ if(!is.null(d <- dim(x)) && (length(d) == 2) && (d[2] >= 4))
+ color <- x[,4]
+ else if(is.list(x) && !is.null(x$color))
+ color <- x$color
+
+ ## convert 'anything' -> vector
+ xyz <- xyz.coords(x=x, y=y, z=z, xlab=xlabel, ylab=ylabel, zlab=zlabel,
+ log=log)
+ if(is.null(xlab)) { xlab <- xyz$xlab; if(is.null(xlab)) xlab <- "" }
+ if(is.null(ylab)) { ylab <- xyz$ylab; if(is.null(ylab)) ylab <- "" }
+ if(is.null(zlab)) { zlab <- xyz$zlab; if(is.null(zlab)) zlab <- "" }
+
+ if(length(color) == 1)
+ color <- rep(color, length(xyz$x))
+ else if(length(color) != length(xyz$x))
+ stop("length(color) ", "must be equal length(x) or 1")
+
+ angle <- (angle %% 360) / 90
+ yz.f <- scale.y * abs(if(angle < 1) angle else if(angle > 3) angle - 4 else 2 - angle)
+ yx.f <- scale.y * (if(angle < 2) 1 - angle else angle - 3)
+ if(angle > 2) { ## switch y and x axis to ensure righthand oriented coord.
+ temp <- xyz$x; xyz$x <- xyz$y; xyz$y <- temp
+ temp <- xlab; xlab <- ylab; ylab <- temp
+ temp <- xlim; xlim <- ylim; ylim <- temp
+ }
+ angle.1 <- (1 < angle && angle < 2) || angle > 3
+ angle.2 <- 1 <= angle && angle <= 3
+ dat <- cbind(as.data.frame(xyz[c("x","y","z")]), col = color)
+
+ n <- nrow(dat);
+ y.range <- range(dat$y[is.finite(dat$y)])
+
+### 3D-highlighting / colors / sort by y
+ if(type == "p" || type == "h") {
+ y.ord <- rev(order(dat$y))
+ dat <- dat[y.ord, ]
+ if(length(pch) > 1)
+ if(length(pch) != length(y.ord))
+ stop("length(pch) ", "must be equal length(x) or 1")
+ else pch <- pch[y.ord]
+ daty <- dat$y
+ daty[!is.finite(daty)] <- mean(daty[is.finite(daty)])
+ if(highlight.3d && !(all(diff(daty) == 0)))
+ dat$col <- rgb(seq(0, 1, length = n) * (y.range[2] - daty) / diff(y.range), g=0, b=0)
+ }
+
+### optim. axis scaling
+ p.lab <- par("lab")
+ ## Y
+ y.range <- range(dat$y[is.finite(dat$y)], ylim)
+ y.prty <- pretty(y.range, n = lab[2],
+ min.n = max(1, min(.5 * lab[2], p.lab[2])))
+ y.scal <- round(diff(y.prty[1:2]), digits = 12)
+ y.add <- min(y.prty)
+ dat$y <- (dat$y - y.add) / y.scal
+ y.max <- (max(y.prty) - y.add) / y.scal
+
+ x.range <- range(dat$x[is.finite(dat$x)], xlim)
+ x.prty <- pretty(x.range, n = lab[1],
+ min.n = max(1, min(.5 * lab[1], p.lab[1])))
+ x.scal <- round(diff(x.prty[1:2]), digits = 12)
+ dat$x <- dat$x / x.scal
+ x.range <- range(x.prty) / x.scal
+ x.max <- ceiling(x.range[2])
+ x.min <- floor(x.range[1])
+ if(!is.null(xlim)) {
+ x.max <- max(x.max, ceiling(xlim[2] / x.scal))
+ x.min <- min(x.min, floor(xlim[1] / x.scal))
+ }
+ x.range <- range(x.min, x.max)
+ ## Z
+ z.range <- range(dat$z[is.finite(dat$z)], zlim)
+ z.prty <- pretty(z.range, n = lab.z,
+ min.n = max(1, min(.5 * lab.z, p.lab[2])))
+ z.scal <- round(diff(z.prty[1:2]), digits = 12)
+ dat$z <- dat$z / z.scal
+ z.range <- range(z.prty) / z.scal
+ z.max <- ceiling(z.range[2])
+ z.min <- floor(z.range[1])
+ if(!is.null(zlim)) {
+ z.max <- max(z.max, ceiling(zlim[2] / z.scal))
+ z.min <- min(z.min, floor(zlim[1] / z.scal))
+ }
+ z.range <- range(z.min, z.max)
+
+### init graphics
+ plot.new()
+ if(angle.2) {x1 <- x.min + yx.f * y.max; x2 <- x.max}
+ else {x1 <- x.min; x2 <- x.max + yx.f * y.max}
+ plot.window(c(x1, x2), c(z.min, z.max + yz.f * y.max))
+ temp <- strwidth(format(rev(y.prty))[1], cex = cex.axis/par("cex"))
+ if(angle.2) x1 <- x1 - temp - y.margin.add
+ else x2 <- x2 + temp + y.margin.add
+ plot.window(c(x1, x2), c(z.min, z.max + yz.f * y.max))
+ if(angle > 2) par("usr" = par("usr")[c(2, 1, 3:4)])
+ usr <- par("usr") # we have to remind it for use in closures
+ title(main, sub, ...)
+
+### draw axis, tick marks, labels, grid, ...
+ xx <- if(angle.2) c(x.min, x.max) else c(x.max, x.min)
+ if(grid) {
+ ## grids
+ ###################
+ # XY wall
+ i <- x.min:x.max;
+ segments(i, z.min, i + (yx.f * y.max), yz.f * y.max + z.min,
+ col = col.grid, lty = lty.grid);
+
+ i <- 0:y.max;
+ segments(x.min + (i * yx.f), i * yz.f + z.min,
+ x.max + (i * yx.f), i * yz.f + z.min,
+ col = col.grid, lty = lty.grid);
+
+ ######################
+ # XZ wall
+ # verticle lines
+ temp <- yx.f * y.max;
+ temp1 <- yz.f * y.max;
+ i <- (x.min + temp):(x.max + temp);
+ segments(i, z.min + temp1, i, z.max + temp1,
+ col = col.grid, lty = lty.grid);
+
+ # horizontal lines
+ i <- (z.min + temp1):(z.max + temp1);
+ segments(x.min + temp, i, x.max + temp, i,
+ col = col.grid, lty = lty.grid)
+
+
+ ##################
+ # YZ wall
+ # horizontal lines
+ i <- xx[2]:x.min;
+ mm <- z.min:z.max;
+ segments(i, mm, i + temp, mm + temp1,
+ col = col.grid, lty = lty.grid);
+ # verticle lines
+ i <- 0:y.max;
+ segments(x.min + (i * yx.f), i * yz.f + z.min,
+ xx[2] + (i * yx.f), i * yz.f + z.max,
+ col = col.grid, lty = lty.grid)
+
+
+ # make the axis into solid line
+ segments(x.min, z.min, x.min + (yx.f * y.max), yz.f * y.max + z.min,
+ col = col.grid, lty = lty.hide);
+ segments(x.max, z.min, x.max + (yx.f * y.max), yz.f * y.max + z.min,
+ col = col.axis, lty = lty.hide);
+ segments(x.min + (y.max * yx.f), y.max * yz.f + z.min,
+ x.max + (y.max* yx.f), y.max * yz.f + z.min,
+ col = col.grid, lty = lty.hide);
+ segments(x.min + temp, z.min + temp1, x.min + temp, z.max + temp1,
+ col = col.grid, lty = lty.hide);
+ segments(x.max + temp, z.min + temp1, x.max + temp, z.max + temp1,
+ col = col.axis, lty = lty.hide);
+ segments(x.min + temp, z.max + temp1, x.max + temp, z.max + temp1,
+ col = col.axis, lty = lty.hide);
+ segments(xx[2], z.max, xx[2] + temp, z.max + temp1,
+ col = col.axis, lty = lty.hide);
+ }
+ if(axis) {
+ if(tick.marks) { ## tick marks
+ xtl <- (z.max - z.min) * (tcl <- -par("tcl")) / 50
+ ztl <- (x.max - x.min) * tcl / 50
+ mysegs <- function(x0,y0, x1,y1)
+ segments(x0,y0, x1,y1, col=col.axis, lty=lty.axis)
+ ## Y
+ i.y <- 0:y.max
+ mysegs(yx.f * i.y - ztl + xx[1], yz.f * i.y + z.min,
+ yx.f * i.y + ztl + xx[1], yz.f * i.y + z.min)
+ ## X
+ i.x <- x.min:x.max
+ mysegs(i.x, -xtl + z.min, i.x, xtl + z.min)
+ ## Z
+ i.z <- z.min:z.max
+ mysegs(-ztl + xx[2], i.z, ztl + xx[2], i.z)
+
+ if(label.tick.marks) { ## label tick marks
+ las <- par("las")
+ mytext <- function(labels, side, at, ...)
+ mtext(text = labels, side = side, at = at, line = -.5,
+ col=col.lab, cex=cex.axis, font=font.lab, ...)
+ ## X
+ if(is.null(x.ticklabs))
+ x.ticklabs <- format(i.x * x.scal)
+ mytext(x.ticklabs, side = 1, at = i.x)
+ ## Z
+ if(is.null(z.ticklabs))
+ z.ticklabs <- format(i.z * z.scal)
+ mytext(z.ticklabs, side = if(angle.1) 4 else 2, at = i.z,
+ adj = if(0 < las && las < 3) 1 else NA)
+ ## Y
+ temp <- if(angle > 2) rev(i.y) else i.y ## turn y-labels around
+ if(is.null(y.ticklabs))
+ y.ticklabs <- format(y.prty)
+ else if (angle > 2)
+ y.ticklabs <- rev(y.ticklabs)
+ text(i.y * yx.f + xx[1],
+ i.y * yz.f + z.min, y.ticklabs,
+ pos=if(angle.1) 2 else 4, offset=1,
+ col=col.lab, cex=cex.axis/par("cex"), font=font.lab)
+ }
+ }
+
+ ## axis and labels
+
+ mytext2 <- function(lab, side, line, at)
+ mtext(lab, side = side, line = line, at = at, col = col.lab,
+ cex = cex.lab, font = font.axis, las = 0)
+ ## X
+ lines(c(x.min, x.max), c(z.min, z.min), col = col.axis, lty = lty.axis)
+ mytext2(xlab, 1, line = 1.5, at = mean(x.range))
+ ## Y
+ lines(xx[1] + c(0, y.max * yx.f), c(z.min, y.max * yz.f + z.min),
+ col = col.axis, lty = lty.axis)
+ mytext2(ylab, if(angle.1) 2 else 4, line= 0.5, at = z.min + y.max * yz.f)
+
+ ## Z
+ lines(xx[c(2,2)], c(z.min, z.max), col = col.axis, lty = lty.axis)
+ mytext2(zlab, if(angle.1) 4 else 2, line= 1.5, at = mean(z.range))
+
+ }
+
+### plot points
+ x <- dat$x + (dat$y * yx.f)
+ z <- dat$z + (dat$y * yz.f)
+ col <- as.character(dat$col)
+ if(type == "h") {
+ z2 <- dat$y * yz.f + z.min
+ segments(x, z, x, z2, col = col, cex = cex.symbols, lty = lty.hplot, ...)
+ points(x, z, type = "p", col = col, pch = pch, cex = cex.symbols, ...)
+ }
+ else points(x, z, type = type, col = col, pch = pch, cex = cex.symbols, ...)
+
+### box-lines in front of points (overlay)
+ if(axis && box) {
+ lines(c(x.min, x.max), c(z.max, z.max),
+ col = col.axis, lty = lty.axis)
+ lines(c(0, y.max * yx.f) + x.max, c(0, y.max * yz.f) + z.max,
+ col = col.axis, lty = lty.axis)
+ lines(xx[c(1,1)], c(z.min, z.max), col = col.axis, lty = lty.axis)
+ }
+
+
+ # par(mem.par) # we MUST NOT set the margins back
+ ### Return Function Object
+ ob <- ls() ## remove all unused objects from the result's enviroment:
+ rm(list = ob[!ob %in% c("angle", "mar", "usr", "x.scal", "y.scal", "z.scal", "yx.f",
+ "yz.f", "y.add", "z.min", "z.max", "x.min", "x.max", "y.max",
+ "x.prty", "y.prty", "z.prty")])
+ rm(ob)
+ invisible(list(
+ xyz.convert = function(x, y=NULL, z=NULL) {
+ xyz <- xyz.coords(x, y, z)
+ if(angle > 2) { ## switch y and x axis to ensure righthand oriented coord.
+ temp <- xyz$x; xyz$x <- xyz$y; xyz$y <- temp
+ }
+ y <- (xyz$y - y.add) / y.scal
+ return(list(x = xyz$x / x.scal + yx.f * y,
+ y = xyz$z / z.scal + yz.f * y))
+ },
+ points3d = function(x, y = NULL, z = NULL, type = "p", ...) {
+ xyz <- xyz.coords(x, y, z)
+ if(angle > 2) { ## switch y and x axis to ensure righthand oriented coord.
+ temp <- xyz$x; xyz$x <- xyz$y; xyz$y <- temp
+ }
+ y2 <- (xyz$y - y.add) / y.scal
+ x <- xyz$x / x.scal + yx.f * y2
+ y <- xyz$z / z.scal + yz.f * y2
+ mem.par <- par(mar = mar, usr = usr)
+ on.exit(par(mem.par))
+ if(type == "h") {
+ y2 <- z.min + yz.f * y2
+ segments(x, y, x, y2, ...)
+ points(x, y, type = "p", ...)
+ }
+ else points(x, y, type = type, ...)
+ },
+ plane3d = function(Intercept, x.coef = NULL, y.coef = NULL,
+ lty = "dashed", lty.box = NULL, ...){
+ if(!is.atomic(Intercept) && !is.null(coef(Intercept))) Intercept <- coef(Intercept)
+ if(is.null(lty.box)) lty.box <- lty
+ if(is.null(x.coef) && length(Intercept) == 3){
+ x.coef <- Intercept[if(angle > 2) 3 else 2]
+ y.coef <- Intercept[if(angle > 2) 2 else 3]
+ Intercept <- Intercept[1]
+ }
+ mem.par <- par(mar = mar, usr = usr)
+ on.exit(par(mem.par))
+ x <- x.min:x.max
+ ltya <- c(lty.box, rep(lty, length(x)-2), lty.box)
+ x.coef <- x.coef * x.scal
+ z1 <- (Intercept + x * x.coef + y.add * y.coef) / z.scal
+ z2 <- (Intercept + x * x.coef +
+ (y.max * y.scal + y.add) * y.coef) / z.scal
+ segments(x, z1, x + y.max * yx.f, z2 + yz.f * y.max, lty = ltya, ...)
+ y <- 0:y.max
+ ltya <- c(lty.box, rep(lty, length(y)-2), lty.box)
+ y.coef <- (y * y.scal + y.add) * y.coef
+ z1 <- (Intercept + x.min * x.coef + y.coef) / z.scal
+ z2 <- (Intercept + x.max * x.coef + y.coef) / z.scal
+ segments(x.min + y * yx.f, z1 + y * yz.f,
+ x.max + y * yx.f, z2 + y * yz.f, lty = ltya, ...)
+ },
+
+ wall3d = function(Intercept, x.coef = NULL, y.coef = NULL,
+ lty = "dashed", lty.box = NULL, ...){
+ if(!is.atomic(Intercept) && !is.null(coef(Intercept))) Intercept <- coef(Intercept)
+ if(is.null(lty.box)) lty.box <- lty
+ if(is.null(x.coef) && length(Intercept) == 3){
+ x.coef <- Intercept[if(angle > 2) 3 else 2]
+ y.coef <- Intercept[if(angle > 2) 2 else 3]
+ Intercept <- Intercept[1]
+ }
+ mem.par <- par(mar = mar, usr = usr)
+ on.exit(par(mem.par))
+ x <- x.min:x.max
+ ltya <- c(lty.box, rep(lty, length(x)-2), lty.box)
+ x.coef <- x.coef * x.scal
+ z1 <- (Intercept + x * x.coef + y.add * y.coef) / z.scal
+ z2 <- (Intercept + x * x.coef +
+ (y.max * y.scal + y.add) * y.coef) / z.scal
+ segments(x, z1, x + y.max * yx.f, z2 + yz.f * y.max, lty = ltya, ...)
+ y <- 0:y.max
+ ltya <- c(lty.box, rep(lty, length(y)-2), lty.box)
+ y.coef <- (y * y.scal + y.add) * y.coef
+ z1 <- (Intercept + x.min * x.coef + y.coef) / z.scal
+ z2 <- (Intercept + x.max * x.coef + y.coef) / z.scal
+ segments(x.min + y * yx.f, z1 + y * yz.f,
+ x.max + y * yx.f, z2 + y * yz.f, lty = ltya, ...)
+ },
+ box3d = function(...){
+ mem.par <- par(mar = mar, usr = usr)
+ on.exit(par(mem.par))
+ lines(c(x.min, x.max), c(z.max, z.max), ...)
+ lines(c(0, y.max * yx.f) + x.max, c(0, y.max * yz.f) + z.max, ...)
+ lines(c(0, y.max * yx.f) + x.min, c(0, y.max * yz.f) + z.max, ...)
+ lines(c(x.max, x.max), c(z.min, z.max), ...)
+ lines(c(x.min, x.min), c(z.min, z.max), ...)
+ lines(c(x.min, x.max), c(z.min, z.min), ...)
+ }
+ ))
+}
+
+
+#'Create 3D PCA score plot
+#'@description This function creates both a static 3D PCA score plot as well as an interactive 3D PCA score plot
+#'using the plotly R package. The 3D PCA score plot is stored in the mSetObj (mSetObj$imgSet$pca.3d). To view
+#'the plot, if your mSetObj is named mSet, type "mSet$imgSet$pca.3d" inro your R console, and the 3D plot will appear.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@usage PlotPCA3DScoreImg(mSetObj=NA, imgName, format="png", dpi=72, width=NA, inx1, inx2, inx3, angl)
+#'@param mSetObj Input name of the created mSet Object.
+#'@param imgName Input a name for the plot.
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@param inx1 Numeric, indicate the number of the principal component for the x-axis of the loading plot.
+#'@param inx2 Numeric, indicate the number of the principal component for the y-axis of the loading plot.
+#'@param inx3 Numeric, indicate the number of the principal component for the z-axis of the loading plot.
+#'@param angl Input the angle
+#'@usage mSet <- PlotPCA3DScore(mSetObj=NA, imgName, format="json", dpi=72, width=NA, inx1, inx2, inx3, angl)
+#'@export
+#'@importFrom plotly plot_ly add_markers layout
+
+PlotPCA3DScoreImg <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA, inx1, inx2, inx3, angl){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ xlabel = paste("PC",inx1, "(", round(100*mSetObj$analSet$pca$variance[inx1],1), "%)");
+ ylabel = paste("PC",inx2, "(", round(100*mSetObj$analSet$pca$variance[inx2],1), "%)");
+ zlabel = paste("PC",inx3, "(", round(100*mSetObj$analSet$pca$variance[inx3],1), "%)");
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+
+ if(is.na(width)){
+ w <- 9;
+ }else if(width == 0){
+ w <- 7.2;
+ }else{
+ w <- width;
+ }
+ h <- w;
+
+ mSetObj$imgSet$pca.score3d <- imgName;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+
+ pchs <- as.numeric(mSetObj$dataSet$cls)+1;
+ uniq.pchs <- unique(pchs);
+
+ if(mSetObj$dataSet$cls.type == "disc"){
+
+ cols <- GetColorSchema(mSetObj$dataSet$cls);
+ legend.nm <- unique(as.character(mSetObj$dataSet$cls));
+ uniq.cols <- unique(cols);
+ Plot3D(mSetObj$analSet$pca$x[, inx1], mSetObj$analSet$pca$x[, inx2], mSetObj$analSet$pca$x[, inx3], xlab= xlabel, ylab=ylabel,
+ zlab=zlabel, angle =angl, color=cols, pch=pchs, box=F);
+ legend("topleft", legend =legend.nm, pch=uniq.pchs, col=uniq.cols);
+ dev.off();
+
+ if(!.on.public.web){
+ # 3D View using plotly
+ if(length(uniq.pchs) > 3){
+ col <- RColorBrewer::brewer.pal(length(uniq.pchs), "Set3")
+ }else{
+ col <- c("#1972A4", "#FF7070")
+ }
+
+ p <- plotly::plot_ly(x = mSetObj$analSet$pca$x[, inx1], y = mSetObj$analSet$pca$x[, inx2], z = mSetObj$analSet$pca$x[, inx3],
+ color = mSetObj$dataSet$cls, colors = col)
+ p <- plotly::add_markers(p, sizes = 5)
+ p <- plotly::layout(p, scene = list(xaxis = list(title = xlabel),
+ yaxis = list(title = ylabel),
+ zaxis = list(title = zlabel)))
+ mSetObj$imgSet$pca.3d <- p;
+ print("The Interactive 3D PCA plot has been created, please find it in mSet$imgSet$pca.3d.")
+ }
+
+ }else{
+
+ Plot3D(mSetObj$analSet$pca$x[, inx1], mSetObj$analSet$pca$x[, inx2], mSetObj$analSet$pca$x[, inx3], xlab= xlabel, ylab=ylabel,
+ zlab=zlabel, angle =angl, pch=pchs, box=F);
+ dev.off();
+
+ if(!.on.public.web){
+ # 3D View using plotly
+ col <- c("#C61951", "#1972A4")
+ p <- plotly::plot_ly(x = mSetObj$analSet$pca$x[, inx1], y = mSetObj$analSet$pca$x[, inx2], z = mSetObj$analSet$pca$x[, inx3],
+ color = pchs, colors = col, marker = list(colorbar = list(len = 1, tickmode = array, tickvals = range(unique(pchs)),
+ ticktext = levels(mSetObj$dataSet$cls))));
+ p <- plotly::add_markers(p, sizes = 1000);
+ p <- plotly::layout(p, scene = list(xaxis = list(title = xlabel),
+ yaxis = list(title = ylabel),
+ zaxis = list(title = zlabel)));
+ mSetObj$imgSet$pca.3d <- p;
+ print("The Interactive 3D PCA plot has been created, please find it in mSet$imgSet$pca.3d.")
+ }
+ }
+ return(.set.mSet(mSetObj));
+}
+
+#'Plot sPLS-DA 3D score plot
+#'@description This function creates two 3D sPLS-DA score plots, the first is static for Analysis Report purposes, as well as
+#'an interactive 3D plot using the plotly R package. The 3D score plot is saved in the created mSetObj (mSetObj$imgSet$splsda.3d).
+#'To view the score plot, if the name of your mSetObj is mSet, enter "mSet$imgSet$splsda.3d" to view the interactive score plot.
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@param inx1 Numeric, indicate the number of the principal component for the x-axis of the loading plot.
+#'@param inx2 Numeric, indicate the number of the principal component for the y-axis of the loading plot.
+#'@param inx3 Numeric, indicate the number of the principal component for the z-axis of the loading plot.
+#'@param angl Input the angle
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'@importFrom plotly plot_ly add_markers layout
+PlotSPLS3DScoreImg<-function(mSetObj=NA, imgName, format="png", dpi=72, width=NA, inx1, inx2, inx3, angl){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- 9;
+ }else if(width == 0){
+ w <- 7.2;
+ }else{
+ w <- width;
+ }
+ h <- w;
+
+ mSetObj$imgSet$spls.score3d <- imgName;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ par(mar=c(5,5,3,3));
+
+ spls3d <- list();
+
+ ## need to check if only 2 or 3 components generated
+ if(length(mSetObj$analSet$splsr$explained_variance$X)==2){
+ spls3d$score$axis <- paste("Component", c(inx1, inx2), " (", round(100*mSetObj$analSet$splsr$explained_variance$X[c(inx1, inx2)], 1), "%)", sep="");
+ coords <- data.frame(signif(mSetObj$analSet$splsr$variates$X[,c(inx1, inx2)], 5));
+ spls3d$score$axis <- c(spls3d$score$axis, "Component3 (NA)");
+ coords <- rbind(coords, "comp 3"=rep (0, ncol(coords)));
+ }else{
+ spls3d$score$axis <- paste("Component", c(inx1, inx2, inx3), " (", round(100*mSetObj$analSet$splsr$explained_variance$X[c(inx1, inx2, inx3)], 1), "%)", sep="");
+ coords <- data.frame(signif(mSetObj$analSet$splsr$variates$X[,c(inx1, inx2, inx3)], 5));
+ }
+
+ xlabel <- spls3d$score$axis[1]
+ ylabel <- spls3d$score$axis[2]
+ zlabel <- spls3d$score$axis[3]
+
+ # static
+ cols <- GetColorSchema(mSetObj$dataSet$cls);
+ legend.nm <- unique(as.character(mSetObj$dataSet$cls));
+ uniq.cols <- unique(cols);
+ pchs <- as.numeric(mSetObj$dataSet$cls)+1;
+ uniq.pchs <- unique(pchs);
+ Plot3D(coords[,inx1], coords[,inx2], coords[,inx3], xlab= xlabel, ylab=ylabel,
+ zlab=zlabel, angle = angl, color=cols, pch=pchs, box=F);
+ legend("topleft", legend = legend.nm, pch=uniq.pchs, col=uniq.cols);
+ dev.off();
+
+ if(!.on.public.web){
+ # 3D View using plotly
+ if(length(uniq.pchs) > 3){
+ col <- RColorBrewer::brewer.pal(length(uniq.pchs), "Set3")
+ }else{
+ col <- c("#1972A4", "#FF7070")
+ }
+ p <- plotly::plot_ly(x = coords[, inx1], y = coords[, inx2], z = coords[, inx3],
+ color = mSetObj$dataSet$cls, colors = col)
+ p <- plotly::add_markers(p, sizes = 5)
+ p <- plotly::layout(p, scene = list(xaxis = list(title = xlabel),
+ yaxis = list(title = ylabel),
+ zaxis = list(title = zlabel)))
+
+ mSetObj$imgSet$splsda.3d <- p;
+ print("The Interactive 3D sPLS-DA plot has been created, please find it in mSet$imgSet$splsda.3d.")
+ }
+ return(.set.mSet(mSetObj));
+}
+
+
+#'Plot sPLS-DA 3D score plot
+#'@description This function creates two 3D sPLS-DA score plots, the first is static for Analysis Report purposes, as well as
+#'an interactive 3D plot using the plotly R package. The 3D score plot is saved in the created mSetObj (mSetObj$imgSet$splsda.3d).
+#'To view the score plot, if the name of your mSetObj is mSet, enter "mSet$imgSet$splsda.3d" to view the interactive score plot.
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@param inx1 Numeric, indicate the number of the principal component for the x-axis of the loading plot.
+#'@param inx2 Numeric, indicate the number of the principal component for the y-axis of the loading plot.
+#'@param inx3 Numeric, indicate the number of the principal component for the z-axis of the loading plot.
+#'@param angl Input the angle
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'@importFrom plotly plot_ly add_markers layout
+PlotSPLS3DScoreImg<-function(mSetObj=NA, imgName, format="png", dpi=72, width=NA, inx1, inx2, inx3, angl){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- 9;
+ }else if(width == 0){
+ w <- 7.2;
+ }else{
+ w <- width;
+ }
+ h <- w;
+
+ mSetObj$imgSet$spls.score3d <- imgName;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ par(mar=c(5,5,3,3));
+
+ spls3d <- list();
+
+ ## need to check if only 2 or 3 components generated
+ if(length(mSetObj$analSet$splsr$explained_variance$X)==2){
+ spls3d$score$axis <- paste("Component", c(inx1, inx2), " (", round(100*mSetObj$analSet$splsr$explained_variance$X[c(inx1, inx2)], 1), "%)", sep="");
+ coords <- data.frame(signif(mSetObj$analSet$splsr$variates$X[,c(inx1, inx2)], 5));
+ spls3d$score$axis <- c(spls3d$score$axis, "Component3 (NA)");
+ coords <- rbind(coords, "comp 3"=rep (0, ncol(coords)));
+ }else{
+ spls3d$score$axis <- paste("Component", c(inx1, inx2, inx3), " (", round(100*mSetObj$analSet$splsr$explained_variance$X[c(inx1, inx2, inx3)], 1), "%)", sep="");
+ coords <- data.frame(signif(mSetObj$analSet$splsr$variates$X[,c(inx1, inx2, inx3)], 5));
+ }
+
+ xlabel <- spls3d$score$axis[1]
+ ylabel <- spls3d$score$axis[2]
+ zlabel <- spls3d$score$axis[3]
+
+ # static
+ cols <- GetColorSchema(mSetObj$dataSet$cls);
+ legend.nm <- unique(as.character(mSetObj$dataSet$cls));
+ uniq.cols <- unique(cols);
+ pchs <- as.numeric(mSetObj$dataSet$cls)+1;
+ uniq.pchs <- unique(pchs);
+ Plot3D(coords[,inx1], coords[,inx2], coords[,inx3], xlab= xlabel, ylab=ylabel,
+ zlab=zlabel, angle = angl, color=cols, pch=pchs, box=F);
+ legend("topleft", legend = legend.nm, pch=uniq.pchs, col=uniq.cols);
+ dev.off();
+
+ if(!.on.public.web){
+ # 3D View using plotly
+ if(length(uniq.pchs) > 3){
+ col <- RColorBrewer::brewer.pal(length(uniq.pchs), "Set3")
+ }else{
+ col <- c("#1972A4", "#FF7070")
+ }
+ p <- plotly::plot_ly(x = coords[, inx1], y = coords[, inx2], z = coords[, inx3],
+ color = mSetObj$dataSet$cls, colors = col)
+ p <- plotly::add_markers(p, sizes = 5)
+ p <- plotly::layout(p, scene = list(xaxis = list(title = xlabel),
+ yaxis = list(title = ylabel),
+ zaxis = list(title = zlabel)))
+
+ mSetObj$imgSet$splsda.3d <- p;
+ print("The Interactive 3D sPLS-DA plot has been created, please find it in mSet$imgSet$splsda.3d.")
+ }
+ return(.set.mSet(mSetObj));
+}
+
+
+#'Plot PLS 3D score plot
+#'@description This function creates two 3D PLS-DA score plots, the first is static for Analysis Report purposes, as well as
+#'an interactive 3D plot using the plotly R package. The 3D score plot is saved in the created mSetObj (mSetObj$imgSet$plsda.3d).
+#'To view the score plot, if the name of your mSetObj is mSet, enter "mSet$imgSet$plsda.3d" to view the interactive score plot.
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@param inx1 Numeric, indicate the number of the principal component for the x-axis of the loading plot.
+#'@param inx2 Numeric, indicate the number of the principal component for the y-axis of the loading plot.
+#'@param inx3 Numeric, indicate the number of the principal component for the z-axis of the loading plot.
+#'@param angl Input the angle
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'@importFrom plotly plot_ly add_markers layout
+
+PlotPLS3DScoreImg<-function(mSetObj=NA, imgName, format="png", dpi=72, width=NA, inx1, inx2, inx3, angl){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- 9;
+ }else if(width == 0){
+ w <- 7.2;
+ }else{
+ w <- width;
+ }
+ h <- w;
+
+ mSetObj$imgSet$pls.score3d <- imgName;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ par(mar=c(5,5,3,3));
+
+ xlabel <- paste("Component", inx1, "(", round(100*mSetObj$analSet$plsr$Xvar[inx1]/mSetObj$analSet$plsr$Xtotvar,1), "%)");
+ ylabel <- paste("Component", inx2, "(", round(100*mSetObj$analSet$plsr$Xvar[inx2]/mSetObj$analSet$plsr$Xtotvar,1), "%)");
+ zlabel <- paste("Component", inx3, "(", round(100*mSetObj$analSet$plsr$Xvar[inx3]/mSetObj$analSet$plsr$Xtotvar,1), "%)");
+
+ cols <- GetColorSchema(mSetObj$dataSet$cls);
+ legend.nm <- unique(as.character(mSetObj$dataSet$cls));
+ uniq.cols <- unique(cols);
+ pchs <- as.numeric(mSetObj$dataSet$cls)+1;
+ uniq.pchs <- unique(pchs);
+ Plot3D(mSetObj$analSet$plsr$score[,inx1], mSetObj$analSet$plsr$score[,inx2], mSetObj$analSet$plsr$score[,inx3], xlab= xlabel, ylab=ylabel,
+ zlab=zlabel, angle =angl, color=cols, pch=pchs, box=F);
+ legend("topleft", legend = legend.nm, pch=uniq.pchs, col=uniq.cols);
+ dev.off();
+
+ if(!.on.public.web){
+ # 3D View using plotly
+ if(length(uniq.pchs) > 3){
+ col <- RColorBrewer::brewer.pal(length(uniq.pchs), "Set3")
+ }else{
+ col <- c("#1972A4", "#FF7070")
+ }
+ p <- plotly::plot_ly(x = mSetObj$analSet$plsr$score[, inx1], y = mSetObj$analSet$plsr$score[, inx2], z = mSetObj$analSet$plsr$score[, inx3],
+ color = mSetObj$dataSet$cls, colors = col)
+ p <- plotly::add_markers(p, sizes = 5)
+ p <- plotly::layout(p, scene = list(xaxis = list(title = xlabel),
+ yaxis = list(title = ylabel),
+ zaxis = list(title = zlabel)))
+
+ mSetObj$imgSet$plsda.3d <- p;
+ print("The Interactive 3D PLS-DA plot has been created, please find it in mSet$imgSet$plsda.3d.")
+ }
+
+ return(.set.mSet(mSetObj));
+}
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/stats_sigfeatures.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/stats_sigfeatures.R
new file mode 100755
index 0000000000000000000000000000000000000000..1bf35bd9966d3ec2e8d735fc689fb61fa7ddc27b
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/stats_sigfeatures.R
@@ -0,0 +1,402 @@
+#'Perform Signifiance Analysis of Microarrays (SAM) analysis
+#'@description Perform SAM
+#'@param mSetObj Input name of the created mSet Object
+#'@param method Method for SAM analysis, default is set to "d.stat", alternative is "wilc.stat"
+#'@param paired Logical, indicates if samples are paired or not. Default is set to FALSE
+#'@param varequal Logical, indicates if variance is equal. Default is set to TRUE
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'@import siggenes
+#'@import qs
+SAM.Anal <- function(mSetObj=NA, method="d.stat", paired=FALSE, varequal=TRUE, delta=0, imgName){
+ .prepare.sam.anal(mSetObj, method, paired, varequal, delta, imgName);
+ .perform.computing();
+ .save.sam.anal(mSetObj);
+}
+
+.prepare.sam.anal <- function(mSetObj=NA, method="d.stat", paired=FALSE, varequal=TRUE, delta=0, imgName){
+ mSetObj <- .get.mSet(mSetObj);
+
+ imgName = paste(imgName, "dpi72.png", sep="");
+ mat <- t(mSetObj$dataSet$norm); # in sam the column is sample
+ cl <- as.factor(mSetObj$dataSet$cls); # change to 0 and 1 for class label
+
+ my.fun<-function(){
+ library(siggenes);
+ if(dat.in$cls.num==2){
+ if(dat.in$paired){
+ dat.in$cls <- dat.in$cls.paired;
+ }
+ if(dat.in$method == "d.stat"){
+ sam_out <- siggenes::sam(dat.in$data, dat.in$cls, method=d.stat, var.equal=dat.in$varequal, R.fold=0, rand=123);
+ }else{
+ sam_out <- siggenes::sam(dat.in$data, dat.in$cls, method=wilc.stat, R.fold=0,rand=123);
+ }
+ }else{
+ sam_out <- siggenes::sam(dat.in$data, dat.in$cls, rand=123);
+ }
+
+ # check if need to compute a suitable delta value
+ delta <- dat.in$delta;
+ if(delta == 0){
+ mat.fdr <- sam_out@mat.fdr
+ deltaVec <- mat.fdr[,"Delta"];
+ fdrVec <- mat.fdr[,"FDR"];
+ signumVec <- mat.fdr[,"Called"];
+
+ delta <- deltaVec[1];
+ for(i in 1:length(deltaVec)){
+ my.delta = deltaVec[i];
+ fdr = fdrVec[i];
+ called = signumVec[i];
+ if(called > 0){ # at least 1 significant cmpd
+ # check fdr, default threshold 0.01
+ # if too many significant compounds, tight up and vice versa
+ if(fdr < 0.001){
+ delta <- my.delta; break;
+ }else if(fdr < 0.01 & called < 100){
+ delta <- my.delta; break;
+ }else if(fdr < 0.05 & called <50){
+ delta <- my.delta; break;
+ }else if(fdr < 0.1 & called < 20){
+ delta <- my.delta; break;
+ }else if(called < 10){
+ delta <- my.delta; break;
+ }
+ }
+ }
+ }
+
+ # get the signficant features
+ summary.mat <- summary(sam_out, delta)@mat.sig;
+ sig.mat <- as.matrix(signif(summary.mat[,-c(1,6)],5));
+ data.table::fwrite(as.data.frame(sig.mat), file="sam_sigfeatures.csv", row.names=TRUE);
+
+ # plot SAM plot
+ Cairo::Cairo(file = dat.in$imgName, unit="in", dpi=72, width=8, height=8, type="png", bg="white");
+ siggenes::plot(sam_out, delta);
+ dev.off();
+
+ return(list(sam.res=sam_out, sam.delta=delta, sig.mat=sig.mat, img=imgName));
+ }
+
+ dat.in <- list(data=mat, cls=cl, cls.num=mSetObj$dataSet$cls.num, method=method, varequal=varequal,
+ paired=paired, delta=delta, cls.paired=as.numeric(mSetObj$dataSet$pairs), imgName=imgName, my.fun=my.fun);
+
+ qs::qsave(dat.in, file="dat.in.qs");
+ mSetObj$imgSet$sam.cmpd <- imgName;
+ return(.set.mSet(mSetObj));
+}
+
+.save.sam.anal <- function(mSetObj = NA){
+ mSetObj <- .get.mSet(mSetObj);
+ dat.in <- qs::qread("dat.in.qs");
+ my.res <- dat.in$my.res;
+ mSetObj$analSet$sam <- my.res$sam.res;
+ mSetObj$analSet$sam.delta <- my.res$sam.delta;
+ mSetObj$analSet$sam.cmpds <- my.res$sig.mat;
+ return(.set.mSet(mSetObj));
+}
+
+#'Plot SAM Delta Plot
+#'@description Plot SAM Delta Plot (FDR)
+#'@param mSetObj Input name of the created mSet Object
+#'@param delta Input the delta
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotSAM.FDR <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- 10;
+ }else if(width == 0){
+ w <- 7.2;
+ }
+ h <- w*3/5;
+
+ mSetObj$imgSet$sam.fdr <- imgName;
+ delta <- mSetObj$analSet$sam.delta;
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ par(mfrow=c(1,2), mar=c(5,6,4,1));
+ mat.fdr <- mSetObj$analSet$sam@mat.fdr;
+ plot(mat.fdr[,"Delta"],mat.fdr[,"FDR"],xlab='Delta',ylab=NA,type="b", col='blue', las=2);
+ abline(v = delta, lty=3, col="magenta");
+ mtext("FDR", side=2, line=5);
+ par(mar=c(5,5,4,2))
+ plot(mat.fdr[,"Delta"],mat.fdr[,"Called"],xlab='Delta',ylab="Significant feaure No.",type="b", col='blue', las=2);
+ abline(v = delta, lty=3, col="magenta");
+
+ hit.inx <- mat.fdr[,"Delta"] <= delta;
+ my.fdr <- signif(min(mat.fdr[,"FDR"][hit.inx]), 3);
+ my.sigs <- min(mat.fdr[,"Called"][hit.inx]);
+ mtext(paste("Delta:", delta, " FDR:", my.fdr, " Sig. cmpds:", my.sigs), line=-2, side = 3, outer = TRUE, font=2)
+ dev.off();
+
+ return(.set.mSet(mSetObj));
+}
+
+#'Plot SAM
+#'@description Plot SAM with positive and negative metabolite sets
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'@import qs
+
+PlotSAM.Cmpd <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA){
+ .prepare.sam.cmpd(mSetObj, imgName, format, dpi, width);
+ .perform.computing();
+ # no need to collect as it is an image
+}
+
+.prepare.sam.cmpd <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA){
+ # note, this is now a remote call and only used for other formats by users
+ mSetObj <- .get.mSet(mSetObj);
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- 8;
+ }else if(width == 0){
+ w <- 7;
+ }else{
+ w <- width;
+ }
+ h <- w;
+
+ my.fun <- function(){
+ Cairo::Cairo(file = dat.in$imgName, unit="in", dpi=dat.in$dpi, width=dat.in$width, height=dat.in$height, type=dat.in$type, bg="white");
+ siggenes::plot(dat.in$mSetObj$analSet$sam, dat.in$mSetObj$analSet$sam.delta);
+ dev.off();
+ }
+ dat.in <- list(mSetObj = mSetObj, dpi=dpi, width=w, height=h, type=format, imgName=imgName, my.fun=my.fun);
+ qs::qsave(dat.in, file="dat.in.qs");
+ mSetObj$imgSet$sam.cmpd <- imgName;
+ return(.set.mSet(mSetObj));
+}
+
+#'For EBAM analysis
+#'@description deteriming a0, only applicable for z.ebam (default)
+#'@param mSetObj Input name of the created mSet Object
+#'@param isPaired Logical
+#'@param isVarEq Logical
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'@import qs
+EBAM.Init <- function(mSetObj=NA, isPaired, isVarEq, nonPar, A0=-99, delta, imgA0, imgSig){
+ .prepare.ebam.init(mSetObj, isPaired, isVarEq, nonPar, A0, delta, imgA0, imgSig);
+ .perform.computing();
+ .save.ebam.init(mSetObj);
+}
+
+.prepare.ebam.init <- function(mSetObj=NA, isPaired, isVarEq, nonPar, A0=-99, delta, imgA0, imgSig){
+ mSetObj <- .get.mSet(mSetObj);
+ if(isPaired){
+ cl.ebam <- as.numeric(mSetObj$dataSet$pairs);
+ }else{
+ cl.ebam <- as.numeric(mSetObj$dataSet$cls)-1; # change to 0 and 1 for class label
+ }
+ method <- "z.ebam";
+ if(nonPar && length(levels(mSetObj$dataSet$cls)) == 2){
+ method <- "wilc.ebam"
+ }
+ conc.ebam <- t(mSetObj$dataSet$norm); # in sam column is sample, row is gene
+
+ imgA0 = paste(imgA0, "dpi72.png", sep="");
+ imgSig = paste(imgSig, "dpi72.png", sep="");
+
+ my.fun <- function(){
+ library(siggenes);
+ ebam_a0 <- siggenes::find.a0(dat.in$data, dat.in$cls, var.equal=dat.in$isVarEq, gene.names=rownames(dat.in$data), rand=123);
+
+ # plotting ebam A0
+ Cairo::Cairo(file = dat.in$imgA0, unit="in", dpi=72, width=8, height=6, type="png", bg="white");
+ plot(ebam_a0);
+ dev.off();
+
+ A0 <- dat.in$A0;
+ if(A0 == -99){ # default
+ A0 <- round(as.numeric(ebam_a0@suggested),4)
+ }
+ if(dat.in$method=="z.ebam"){
+ ebam_out <- siggenes::ebam(dat.in$data, dat.in$cls, method=z.ebam, a0=A0, var.equal=dat.in$isVarEq, fast=TRUE, gene.names=rownames(dat.in$data), rand=123);
+ }else{
+ ebam_out <- siggenes::ebam(dat.in$data, dat.in$cls, method=wilc.ebam, gene.names=rownames(dat.in$data), rand=123);
+ }
+
+ # plotting ebam sig features
+ Cairo::Cairo(file = dat.in$imgSig, unit="in", dpi=72, width=7, height=7, type="png", bg="white");
+ plot(ebam_out, delta);
+ dev.off();
+
+ summary.mat <- summary(ebam_out, delta)@mat.sig;
+ sig.mat <- as.matrix(signif(summary.mat[,-1],5));
+ data.table::fwrite(as.data.frame(sig.mat),file="ebam_sigfeatures.csv", row.names=TRUE);
+
+ return(list(ebam_a0=A0, ebam_out=ebam_out, sig.mat=sig.mat, a0=A0, delta=delta));
+ }
+
+ dat.in <- list(data=conc.ebam, cls=cl.ebam, isVarEq=isVarEq, method=method, A0=A0, imgA0=imgA0, imgSig=imgSig, my.fun=my.fun);
+ qs::qsave(dat.in, file="dat.in.qs");
+
+ mSetObj$imgSet$ebam.a0 <- imgA0;
+ mSetObj$imgSet$ebam.cmpd <-imgSig;
+ return(.set.mSet(mSetObj));
+}
+
+.save.ebam.init <- function(mSetObj = NA){
+ mSetObj <- .get.mSet(mSetObj);
+ dat.in <- qs::qread("dat.in.qs");
+ my.res <- dat.in$my.res;
+ mSetObj$analSet$ebam <- my.res$ebam_out;
+ mSetObj$analSet$ebam.cmpds <- my.res$sig.mat;
+ mSetObj$analSet$ebam.a0 <- my.res$ebam_a0;
+ mSetObj$analSet$ebam.delta <- my.res$delta;
+ return(.set.mSet(mSetObj));
+}
+
+#'Plot EBAM
+#'@description Plot EBAM
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@usage PlotEBAM.Cmpd(mSetObj=NA, imgName, format, dpi, width)
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@import qs
+#'@export
+#'
+PlotEBAM.Cmpd<-function(mSetObj=NA, imgName, format="png", dpi=72, width=NA){
+ .prepare.ebam.cmpd(mSetObj, imgName, format, dpi, width);
+ .perform.computing();
+}
+
+.prepare.ebam.cmpd <-function(mSetObj=NA, imgName, format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # note, this is now a remote call and only used for other formats by users
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- h <- 7;
+ }else if(width == 0){
+ w <- h <- 7;
+ mSetObj$imgSet$ebam.cmpd <-imgName;
+ }else{
+ w <- h <- width;
+ }
+
+ my.fun <- function(){
+ Cairo::Cairo(file = dat.in$imgName, unit="in", dpi=dat.in$dpi, width=dat.in$width, height=dat.in$height, type=dat.in$type, bg="white");
+ siggenes::plot(dat.in$mSetObj$analSet$ebam, dat.in$mSetObj$analSet$ebam.delta);
+ dev.off();
+ }
+ dat.in <- list(mSetObj = mSetObj, dpi=dpi, width=w, height=h, type=format, imgName=imgName, my.fun=my.fun);
+ qs::qsave(dat.in, file="dat.in.qs");
+
+ mSetObj$imgSet$sam.cmpd <- imgName;
+ return(.set.mSet(mSetObj));
+}
+
+##############################################
+##############################################
+########## Utilities for web-server ##########
+##############################################
+##############################################
+
+GetSAMDeltaRange <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ mat.fdr <- mSetObj$analSet$sam@mat.fdr;
+ rng <- range(mat.fdr[,"Delta"]);
+ step <- (rng[2]-rng[1])/12
+ return(signif(c(rng, step), 3));
+}
+
+#'For SAM analysis
+#'@description obtain a default delta with reasonable number
+#'of sig features and decent FDR
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+GetSuggestedSAMDelta <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$analSet$sam.delta);
+}
+
+GetEBAMSuggestedA0 <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$analSet$ebam.a0);
+}
+
+GetSAMSigMat <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(CleanNumber(mSetObj$analSet$sam.cmpds));
+}
+
+GetSAMSigRowNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ rownames(mSetObj$analSet$sam.cmpds);
+}
+
+GetSAMSigColNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ colnames(mSetObj$analSet$sam.cmpds);
+}
+
+#'Sig table for SAM
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@export
+GetSigTable.SAM <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ GetSigTable(mSetObj$analSet$sam.cmpds, "SAM", mSetObj$dataSet$type);
+}
+
+GetEBAMSigMat <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(CleanNumber(mSetObj$analSet$ebam.cmpds));
+}
+
+GetEBAMSigRowNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ rownames(mSetObj$analSet$ebam.cmpds);
+}
+
+GetEBAMSigColNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ colnames(mSetObj$analSet$ebam.cmpds);
+}
+
+#'Sig table for EBAM
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@export
+GetSigTable.EBAM <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ GetSigTable(mSetObj$analSet$ebam.cmpds, "EBAM", mSetObj$dataSet$type);
+}
+
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/stats_spls.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/stats_spls.R
new file mode 100755
index 0000000000000000000000000000000000000000..d89e18a606c35304ba35cd228881eb14771fc318
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/stats_spls.R
@@ -0,0 +1,2659 @@
+
+#'Perform sPLS-DA
+#'@description Sparse PLS functions (adapted from mixOmics package for web-based usage)
+#'this function is a particular setting of internal_mint.block
+#'the formatting of the input is checked in internal_wrapper.mint
+#'@param X numeric matrix of predictors
+#'@param Y a factor or a class vector for the discrete outcome
+#'@param ncomp the number of components to include in the model. Default to 2.
+#'@param mode Default set to c("regression", "canonical", "invariant", "classic")
+#'@param keepX Number of \eqn{X} variables kept in the model on the last components (once all keepX.constraint[[i]] are used).
+#'@param keepX.constraint A list containing which variables of X are to be kept on each of the first PLS-components.
+#'@param scale Boleean. If scale = TRUE, each block is standardized to zero means and unit variances (default: TRUE).
+#'@param tol Convergence stopping value.
+#'@param max.iter integer, the maximum number of iterations.
+#'@param near.zero.var boolean, see the internal \code{\link{nearZeroVar}} function (should be set to TRUE in particular for data with many zero values).
+#'Setting this argument to FALSE (when appropriate) will speed up the computations
+#'@param logratio "None" by default, or "CLR"
+#'@param multilevel Designate multilevel design, "NULL" by default
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+splsda <- function(X,
+ Y,
+ ncomp = 2,
+ mode = c("regression", "canonical", "invariant", "classic"),
+ keepX,
+ keepX.constraint=NULL,
+ scale = TRUE,
+ tol = 1e-06,
+ max.iter = 100,
+ near.zero.var = FALSE,
+ logratio = "none", # one of "none", "CLR"
+ multilevel = NULL) # multilevel is passed to multilevel(design = ) in withinVariation. Y is ommited and shouldbe included in multilevel design
+{
+
+
+ #-- validation des arguments --#
+ # most of the checks are done in the wrapper.mint.spls.hybrid function
+ if(is.null(multilevel))
+ {
+ if (is.null(Y))
+ stop("'Y' has to be something else than NULL.")
+
+ if (is.null(dim(Y)))
+ {
+ Y = factor(Y)
+ } else {
+ stop("'Y' should be a factor or a class vector.")
+ }
+
+ if (nlevels(Y) == 1)
+ stop("'Y' should be a factor with more than one level")
+
+ Y.mat = unmap(Y)
+ colnames(Y.mat) = levels(Y)#paste0("Y", 1:ncol(Y.mat))
+ }else{
+ # we expect a vector or a 2-columns matrix in 'Y' and the repeated measurements in 'multilevel'
+ multilevel = data.frame(multilevel)
+
+ if ((nrow(X) != nrow(multilevel)))
+ stop("unequal number of rows in 'X' and 'multilevel'.")
+
+ if (ncol(multilevel) != 1)
+ stop("'multilevel' should have a single column for the repeated measurements, other factors should be included in 'Y'.")
+
+ if (!is.null(ncol(Y)) && !ncol(Y) %in% c(0,1,2))# multilevel 1 or 2 factors
+ stop("'Y' should either be a factor, a single column data.frame containing a factor, or a 2-columns data.frame containing 2 factors.")
+
+ multilevel = data.frame(multilevel, Y)
+ multilevel[, 1] = as.numeric(factor(multilevel[, 1])) # we want numbers for the repeated measurements
+
+ Y.mat = NULL
+ }
+
+ # call to 'internal_wrapper.mint'
+ result = internal_wrapper.mint(X = X, Y = Y.mat, ncomp = ncomp, scale = scale, near.zero.var = near.zero.var, mode = mode,
+ keepX = keepX, keepX.constraint = keepX.constraint, max.iter = max.iter, tol = tol, logratio = logratio,
+ multilevel = multilevel, DA = TRUE)
+
+ # choose the desired output from 'result'
+ out = list(
+ call = match.call(),
+ X = result$X[-result$indY][[1]],
+ Y = if (is.null(multilevel))
+ {
+ Y
+ } else {
+ result$Y.factor
+ },
+ ind.mat = result$X[result$indY][[1]],
+ ncomp = result$ncomp,
+ mode = result$mode,
+ keepX = result$keepA[[1]],
+ keepY = result$keepA[[2]],
+ keepX.constraint = result$keepA.constraint[[1]],
+ keepY.constraint = result$keepA.constraint[[2]],
+ variates = result$variates,
+ loadings = result$loadings,
+ names = result$names,
+ tol = result$tol,
+ iter = result$iter,
+ max.iter = result$max.iter,
+ nzv = result$nzv,
+ scale = scale,
+ logratio = logratio,
+ explained_variance = result$explained_variance,#[-result$indY],
+ input.X = result$input.X
+ )
+
+ class(out) = c("splsda","spls","DA")
+ # output if multilevel analysis
+ if (!is.null(multilevel))
+ {
+ out$multilevel = multilevel
+ class(out) = c("mlsplsda",class(out))
+ }
+
+ return(invisible(out))
+}
+
+internal_wrapper.mint = function(X,
+ Y,
+ study,
+ ncomp = 2,
+ keepX.constraint,
+ keepY.constraint,
+ keepX,
+ keepY,
+ mode,
+ scale = FALSE,
+ near.zero.var = FALSE,
+ max.iter = 100,
+ tol = 1e-06,
+ logratio = "none", # one of "none", "CLR"
+ DA = FALSE, # indicate whether it's a DA analysis, only used for the multilvel approach with withinVariation
+ multilevel = NULL) # multilevel is passed to multilevel(design=) in withinVariation. Y is ommited and should be included in multilevel design
+{
+
+ if (is.null(ncomp) || !is.numeric(ncomp) || ncomp <= 0 || length(ncomp)>1)
+ stop("invalid number of variates, 'ncomp'.")
+
+ #-- validation des arguments --#
+
+ check = Check.entry.pls(X, Y, ncomp, keepX, keepY, keepX.constraint, keepY.constraint, mode=mode, scale=scale,
+ near.zero.var=near.zero.var, max.iter=max.iter ,tol=tol ,logratio=logratio ,DA=DA, multilevel=multilevel)
+ X = check$X
+ input.X = X # save the checked X, before logratio/multileve/scale
+ Y = check$Y
+ ncomp = check$ncomp
+ mode = check$mode
+ keepX.constraint = check$keepX.constraint
+ keepY.constraint = check$keepY.constraint
+ keepX = check$keepX
+ keepY = check$keepY
+ nzv.A = check$nzv.A
+
+ #set the default study factor
+ if (missing(study))
+ {
+ study = factor(rep(1,nrow(X)))
+ } else {
+ study = as.factor(study)
+ }
+ if (length(study) != nrow(X))
+ stop(paste0("'study' must be a factor of length ",nrow(X),"."))
+
+ if (any(table(study) <= 1))
+ stop("At least one study has only one sample, please consider removing before calling the function again")
+ if (any(table(study) < 5))
+ warning("At least one study has less than 5 samples, mean centering might not do as expected")
+
+ design = matrix(c(0,1,1,0), ncol = 2, nrow = 2, byrow = TRUE)
+
+
+ #-----------------------------#
+ #-- logratio transformation --#
+
+ X = logratio.transfo(X=X, logratio=logratio)
+
+ #as X may have changed
+ if (ncomp > min(ncol(X), nrow(X)))
+ stop("'ncomp' should be smaller than ", min(ncol(X), nrow(X)), call. = FALSE)
+
+ #-- logratio transformation --#
+ #-----------------------------#
+
+
+ #---------------------------------------------------------------------------#
+ #-- multilevel approach ----------------------------------------------------#
+
+ if (!is.null(multilevel))
+ {
+ if (!DA)
+ {
+ Xw = withinVariation(X, design = multilevel)
+ Yw = withinVariation(Y, design = multilevel)
+ X = Xw
+ Y = Yw
+ } else {
+ Xw = withinVariation(X, design = multilevel)
+ X = Xw
+
+ #-- Need to set Y variable for 1 or 2 factors
+ Y = multilevel[, -1,drop=FALSE]
+ if (ncol(Y)>0)
+ Y = apply(Y, 1, paste, collapse = ".") # paste is to combine in the case we have 2 levels
+
+ Y = as.factor(Y)
+ Y.factor = Y
+ Y = unmap(Y)
+ colnames(Y) = levels(Y)
+ rownames(Y) = rownames(X)
+ # if DA keepY should be all the levels (which is not happening in the check because of multilevel
+ keepY = rep(ncol(Y),ncomp)
+ }
+ }
+ #-- multilevel approach ----------------------------------------------------#
+ #---------------------------------------------------------------------------#
+
+
+ #---------------------------------------------------------------------------#
+ #-- pls approach ----------------------------------------------------#
+
+ result = internal_mint.block(A = list(X = X, Y = Y), indY = 2, mode = mode, ncomp = c(ncomp, ncomp), tol = tol, max.iter = max.iter,
+ design = design, keepA = list(keepX, keepY), keepA.constraint = list(keepX.constraint, keepY.constraint),
+ scale = scale, scheme = "horst",init="svd", study = study)
+
+ #-- pls approach ----------------------------------------------------#
+ #---------------------------------------------------------------------------#
+
+ result$ncomp = ncomp
+ if(near.zero.var)
+ result$nzv = nzv.A
+
+ if(!is.null(multilevel) & DA)
+ result$Y.factor = Y.factor
+
+ result$input.X = input.X
+
+ class(result) = c("mint.spls.hybrid")
+ return(invisible(result))
+
+}
+
+internal_mint.block = function (A, indY = NULL, design = 1 - diag(length(A)), tau=NULL,#rep(1, length(A)),
+ ncomp = rep(1, length(A)), scheme = "horst", scale = TRUE, bias = FALSE,
+ init = "svd.single", tol = 1e-06, verbose = FALSE,
+ mode = "canonical", max.iter = 100,study = NULL, keepA = NULL,
+ keepA.constraint = NULL, penalty = NULL)
+{
+ # A: list of matrices
+ # indY: integer, pointer to one of the matrices of A
+ # design: design matrix, links between matrices. Diagonal must be 0
+ # ncomp: vector of ncomp, per matrix
+ # scheme: a function "g", refer to the article (thanks Benoit)
+ # scale: do you want to scale ? mean is done by default and cannot be changed (so far)
+ # bias: scale the data with n or n-1
+ # init: one of "svd" or "random", initialisation of the algorithm
+ # tol: nobody cares about this
+ # verbose: show the progress of the algorithm
+ # mode: canonical, classic, invariant, regression
+ # max.iter: nobody cares about this
+ # study: factor for each matrix of A, must be a vector
+ # keepA: keepX of spls for each matrix of A. must be a list. Each entry must be of the same length (max ncomp)
+ # keepA.constraint: keepX.constraint, which variables are kept on the first num.comp-1 components. It is a list of characters
+ # near.zero.var: do you want to remove variables with very small variance
+
+ names(ncomp) = names(A)
+
+ # keepA is updated to be of length length(A) now, the first entries correspond to the keepA.constraint if it was provided
+ for (q in 1:length(A))
+ keepA[[q]] = c(unlist(lapply(keepA.constraint[[q]], length)), keepA[[q]]) #of length ncomp, can contains 0
+
+ # center the data per study, per matrix of A, scale if scale=TRUE, option bias
+ mean_centered = lapply(A, function(x){mean_centering_per_study(x, study, scale, bias)})
+ A = lapply(mean_centered, function(x){as.matrix(x$concat.data)})
+ ni = table(study) #number of samples per study
+
+ ### Start: Initialization parameters
+ pjs = sapply(A, NCOL)
+ nb_ind = NROW(A[[1]])
+ J = length(A)
+ R = A # R: residuals matrices, will be a list of length ncomp
+ N = max(ncomp)
+
+ AVE_inner = AVE_outer = rep(NA, max(ncomp))
+ defl.matrix = AVE_X = crit = loadings.partial.A = variates.partial.A = tau.rgcca = list()
+ P = loadings.A = loadings.Astar = c = t = b = variates.A = vector("list", J)
+
+ for (k in 1:J)
+ t[[k]] = variates.A[[k]] = matrix(NA, nb_ind, N)
+
+ for (k in 1:J)
+ P[[k]] = loadings.A[[k]] = loadings.Astar[[k]]= matrix(NA, pjs[[k]], N)
+
+ for (k in 1:J)
+ {
+ loadings.partial.A[[k]] = variates.partial.A[[k]] = vector("list", length = nlevels(study))
+ for(m in 1:nlevels(study))
+ {
+ loadings.partial.A[[k]][[m]] = matrix(nrow = NCOL(A[[k]]), ncol = N)
+ variates.partial.A[[k]][[m]] = matrix(nrow = ni[m], ncol = N)
+ }
+ }
+
+ defl.matrix[[1]] = A
+ ndefl = ncomp - 1
+ J2 = J-1
+
+ if (is.vector(tau))
+ tau = matrix(rep(tau, N), nrow = N, ncol = length(tau), byrow = TRUE)
+ ### End: Initialization parameters
+
+
+ iter=NULL
+ for (n in 1 : N)
+ {
+ ### Start: Estimation ai
+ if (is.null(tau))
+ {
+ mint.block.result = sparse.mint.block_iteration(R, design, study = study,
+ keepA.constraint = if (!is.null(keepA.constraint)) {lapply(keepA.constraint, function(x){unlist(x[n])})} else {NULL} ,
+ keepA = if (!is.null(keepA)) {lapply(keepA, function(x){x[n]})} else {NULL},
+ scheme = scheme, init = init, max.iter = max.iter, tol = tol, verbose = verbose,penalty = penalty)
+ }
+ ### End: Estimation ai
+
+ if(is.null(tau))
+ {
+ #recording loadings.partials, $Ai$study[,ncomp]
+ # recording variates.partials, $Ai[,ncomp]
+ for(k in 1:J)
+ {
+ for(m in 1:nlevels(study))
+ {
+ loadings.partial.A[[k]][[m]][, n] = matrix(mint.block.result$loadings.partial.A.comp[[k]][[m]], ncol=1)
+ variates.partial.A[[k]][[m]][, n] = matrix(mint.block.result$variates.partial.A.comp[[k]][[m]], ncol=1)
+ }
+ #variates.partial.A[[k]][,n]=matrix(unlist(mint.block.result$variates.partial.A.comp[[k]]),ncol=1)
+ }
+ }
+
+ AVE_inner[n] = mint.block.result$AVE_inner
+ crit[[n]] = mint.block.result$crit
+ tau.rgcca[[n]] = mint.block.result$tau
+
+ for (k in 1:J)
+ variates.A[[k]][, n] = mint.block.result$variates.A[, k]
+
+ # deflation if there are more than 1 component and if we haven't reach the max number of component (N)
+ if (N != 1 & n != N)
+ {
+ defla.result = defl.select(mint.block.result$variates.A, R, ndefl, n, nbloc = J, indY = indY, mode = mode, aa = mint.block.result$loadings.A)
+ R = defla.result$resdefl
+ defl.matrix[[n + 1]] = R
+ }
+
+ for (k in 1 : J)
+ {
+ if (N != 1)
+ {
+ P[[k]][, n - 1] = defla.result$pdefl[[k]]
+ }
+ loadings.A[[k]][, n] = mint.block.result$loadings.A[[k]]
+ }
+
+ if (n == 1)
+ {
+ for (k in 1 : J)
+ loadings.Astar[[k]][, n] = mint.block.result$loadings.A[[k]]
+ } else {
+ for (k in 1 : J)
+ loadings.Astar[[k]][, n] = mint.block.result$loadings.A[[k]] - loadings.Astar[[k]][, (1 : n - 1), drop = F] %*% drop(t(loadings.A[[k]][, n]) %*% P[[k]][, 1 : (n - 1), drop = F])
+ }
+ iter = c(iter, mint.block.result$iter)
+ }
+
+ if (verbose)
+ cat(paste0("Computation of the SGCCA block components #", N , " is under progress...\n"))
+
+ shave.matlist = function(mat_list, nb_cols) mapply(function(m, nbcomp) m[, 1:nbcomp, drop = FALSE], mat_list, nb_cols, SIMPLIFY = FALSE)
+ shave.veclist = function(vec_list, nb_elts) mapply(function(m, nbcomp) m[1:nbcomp], vec_list, nb_elts, SIMPLIFY = FALSE)
+
+ for (k in 1:J)
+ {
+ rownames(loadings.A[[k]]) = rownames(loadings.Astar[[k]])=colnames(A[[k]])
+ rownames(variates.A[[k]]) = rownames(A[[k]])
+ colnames(variates.A[[k]]) = colnames(loadings.A[[k]]) = paste0("comp ", 1:max(ncomp))
+ AVE_X[[k]] = apply(cor(A[[k]], variates.A[[k]])^2, 2, mean)
+ if (is.null(tau))
+ {
+ names(loadings.partial.A[[k]]) = names(variates.partial.A[[k]]) = levels(study)
+ for (m in 1:nlevels(study))
+ {
+ rownames(loadings.partial.A[[k]][[m]]) = colnames(A[[k]])
+ colnames(loadings.partial.A[[k]][[m]]) = paste0("comp ", 1:max(ncomp))
+ rownames(variates.partial.A[[k]][[m]]) = rownames(mean_centered[[1]]$rownames.study[[m]])
+ colnames(variates.partial.A[[k]][[m]]) = paste0("comp ", 1:max(ncomp))
+ }
+ }
+ }
+
+ outer = matrix(unlist(AVE_X), nrow = max(ncomp))
+ for (j in 1 : max(ncomp))
+ AVE_outer[j] = sum(pjs * outer[j, ])/sum(pjs)
+
+ variates.A = shave.matlist(variates.A, ncomp)
+ AVE_X = shave.veclist(AVE_X, ncomp)
+ AVE = list(AVE_X = AVE_X, AVE_outer = AVE_outer, AVE_inner = AVE_inner)
+
+ #calcul explained variance
+ A_split=lapply(A, study_split, study) #split the data per study
+
+ expl.A=lapply(1:length(A),function(x){
+ if (nlevels(study) == 1)
+ {
+ temp = suppressWarnings(explained_variance(A[[x]], variates = variates.A[[x]], ncomp = ncomp[[x]]))
+ }else{
+ temp = lapply(1:nlevels(study), function(y){
+ suppressWarnings(explained_variance(A_split[[x]][[y]], variates = variates.partial.A[[x]][[y]], ncomp = ncomp[[x]]))})
+ temp[[length(temp)+1]] = explained_variance(A[[x]], variates = variates.A[[x]], ncomp = ncomp[[x]])
+ names(temp) = c(levels(study), "all data")
+ }
+ temp
+ })
+ names(expl.A) = names(A)
+
+ ### Start: output
+ names(loadings.A) = names(variates.A) = names(A)
+
+ if (is.null(tau))
+ names(loadings.partial.A) = names(variates.partial.A) = names(A)
+
+ names = lapply(1:J, function(x) {colnames(A[[x]])})
+ names(names) = names(A)
+ names[[length(names) + 1]] = row.names(A[[1]])
+ names(names)[length(names)] = "indiv"
+
+ out = list(X = A, indY = indY, ncomp = ncomp, mode = mode,
+ keepA = keepA, keepA.constraint = keepA.constraint,
+ variates = variates.A, loadings = shave.matlist(loadings.A, ncomp),
+ variates.partial= if(is.null(tau)) {variates.partial.A} ,loadings.partial= if(is.null(tau)) {loadings.partial.A},
+ loadings.star = shave.matlist(loadings.Astar, ncomp),
+ names = list(sample = row.names(A[[1]]), colnames = lapply(A, colnames), blocks = names(A)),
+ tol = tol, iter=iter, max.iter=max.iter,
+ design = design,
+ scheme = scheme, crit = crit, AVE = AVE, defl.matrix = defl.matrix,
+ init = init, bias = bias,
+ scale = scale, tau = if(!is.null(tau)) tau.rgcca, study = study,
+ explained_variance = expl.A)
+ ### End: Output
+
+ return(out)
+}
+
+
+# Performance for PLS-DA and sPLS-DA
+# Performance prediction for PLS-DA and sPLS-DA
+# Jeff Xia \email{jeff.xia@mcgill.ca}
+# McGill University, Canada
+# License: GNU GPL (>= 2)
+perf.splsda <- function(object,
+ dist = c("all", "max.dist", "centroids.dist", "mahalanobis.dist"),
+ constraint = FALSE,
+ validation = c("Mfold", "loo"),
+ folds = 5,
+ nrepeat = 1,
+ auc = FALSE,
+ progressBar = FALSE,
+ cpus,
+ ...){
+
+ #-- initialising arguments --#
+ # these data are the centered and scaled X output or the unmapped(Y) scaled and centered
+ X = object$input.X
+ level.Y = object$names$colnames$Y #to make sure the levels are ordered
+ Y = object$Y
+ ncomp = object$ncomp
+ n = nrow(X)
+
+ logratio = object$logratio
+ if (is.null(logratio))
+ logratio = "none"
+
+ multilevel = object$multilevel # repeated measurement and Y
+ near.zero.var = !is.null(object$nzv) # if near.zero.var was used, we set it to TRUE. if not used, object$nzv is NULL
+
+ if(any(class(object) == "plsda") & constraint == TRUE)
+ {
+ constraint = FALSE #no need as all variable will be included
+ warning("'constraint' is set to FALSE as all variables are selected on all components (plsda object).")
+ }
+ #-- tells which variables are selected in X and in Y --#
+ if(constraint)
+ {
+ keepX.constraint = apply(object$loadings$X, 2, function(x){names(which(x!=0))})
+ # gives a matrix of ncomp columns, I want a list of length ncomp
+ keepX.constraint = split(keepX.constraint, rep(1:ncol(keepX.constraint), each = nrow(keepX.constraint)))
+ names(keepX.constraint) = paste("comp",1:length(keepX.constraint),sep="")
+
+ #keepX = NULL
+ } else {
+ #keepX.constraint = NULL
+ if (any(class(object) == "splsda"))
+ {
+ keepX = object$keepX
+ } else {
+ keepX = rep(ncol(X), ncomp)
+ }
+ }
+
+ tol = object$tol
+ max.iter = object$max.iter
+
+ # initialize new objects:
+ features = list()
+ for(k in 1:ncomp)
+ features[[k]] = NA
+
+ # check input arguments
+
+ if (hasArg(method.predict))
+ stop("'method.predict' argument has been replaced by 'dist' to match the 'tune' function")
+ method.predict = NULL # to pass R CMD check
+
+ dist = match.arg(dist, choices = c("all", "max.dist", "centroids.dist", "mahalanobis.dist"), several.ok = TRUE)
+ if (any(dist == "all"))
+ {
+ nmthdd = 3
+ dist = c("max.dist", "centroids.dist", "mahalanobis.dist")
+ } else {
+ nmthdd = length(dist)
+ }
+
+ if (length(validation) > 1 )
+ validation = validation [1]
+ if (!(validation %in% c("Mfold", "loo")))
+ stop("Choose 'validation' among the two following possibilities: 'Mfold' or 'loo'")
+
+ if (validation == "loo")
+ {
+ if (nrepeat != 1)
+ warning("Leave-One-Out validation does not need to be repeated: 'nrepeat' is set to '1'.")
+ nrepeat = 1
+ }
+
+ if (!is.logical(progressBar))
+ stop("'progressBar' must be either TRUE or FALSE")
+
+ measure = c("overall","BER") # one of c("overall","BER")
+
+
+ if (!(logratio %in% c("none", "CLR")))
+ stop("Choose one of the two following logratio transformation: 'none' or 'CLR'")
+ #fold is checked in 'MCVfold'
+
+ if(!missing(cpus))
+ {
+ if(!is.numeric(cpus) | length(cpus)!=1)
+ stop("'cpus' must be a numerical value")
+
+ parallel = TRUE
+ cl = makeCluster(cpus, type = "SOCK")
+ clusterExport(cl, c("splsda","selectVar"))
+ } else {
+ parallel = FALSE
+ cl = NULL
+ }
+
+
+ #---------------------------------------------------------------------------#
+ #-- logration + multilevel approach ----------------------------------------#
+ # we can do logratio and multilevel on the whole data as these transformation are done per sample
+ X = logratio.transfo(X = X, logratio = logratio)
+ if (!is.null(multilevel))
+ {
+ Xw = withinVariation(X, design = multilevel)
+ X = Xw
+ }
+ #-- logratio + multilevel approach -----------------------------------------#
+ #---------------------------------------------------------------------------#
+
+
+ # -------------------------------------
+ # added: first check for near zero var on the whole data set
+ if (near.zero.var == TRUE)
+ {
+ nzv = nearZeroVar(X)
+ if (length(nzv$Position > 0))
+ {
+ warning("Zero- or near-zero variance predictors.\nReset predictors matrix to not near-zero variance predictors.\nSee $nzv for problematic predictors.")
+ X = X[, -nzv$Position, drop=TRUE]
+
+ if (ncol(X)==0)
+ stop("No more predictors after Near Zero Var has been applied!")
+
+ if (any(keepX > ncol(X)))
+ keepX = ncol(X)
+
+ }
+ }
+ # and then we start from the X data set with the nzv removed
+
+
+
+ list.features = list()
+
+ mat.error.rate = mat.sd.error = mat.mean.error = error.per.class.keepX.opt = list()
+ error.per.class = list()
+ final=list()
+
+ for (measure_i in measure)
+ {
+ mat.sd.error[[measure_i]] = matrix(0,nrow = ncomp, ncol = length(dist),
+ dimnames = list(c(paste('comp', 1 : ncomp)), dist))
+ mat.mean.error[[measure_i]] = matrix(0,nrow = ncomp, ncol = length(dist),
+ dimnames = list(c(paste('comp', 1 : ncomp)), dist))
+ error.per.class.keepX.opt[[measure_i]] = list()
+ mat.error.rate[[measure_i]]=list()
+ for(ijk in dist)
+ {
+ mat.error.rate[[measure_i]][[ijk]] = array(0, c(nlevels(Y), nrepeat ,ncomp),
+ dimnames = list(c(levels(Y)),c(paste('nrep', 1 : nrepeat)),c(paste('comp', 1 : ncomp))))
+
+ error.per.class.keepX.opt[[measure_i]][[ijk]] = matrix(nrow = nlevels(Y), ncol = ncomp,
+ dimnames = list(c(levels(Y)), c(paste('comp', 1 : ncomp))))
+ }
+ }
+
+ if(auc == TRUE)
+ {
+ auc.mean=list()
+ auc.all=list()
+ }
+
+ prediction.all = class.all = auc.mean = auc.all = list()
+ for(ijk in dist)
+ {
+ class.all[[ijk]] = array(0, c(nrow(X), nrepeat ,ncomp),
+ dimnames = list(rownames(X),c(paste('nrep', 1 : nrepeat)),c(paste('comp', 1 : ncomp))))
+ }
+
+ for (comp in 1 : ncomp)
+ {
+ if (progressBar == TRUE)
+ cat("\ncomp",comp, "\n")
+
+ if(constraint)
+ {
+
+ if(comp > 1)
+ {
+ choice.keepX.constraint = keepX.constraint[1 : (comp - 1)]
+ } else {
+ choice.keepX.constraint = NULL
+ }
+ test.keepX = keepX.constraint[comp]
+ #names(test.keepX) = test.keepX
+ #test.keepX is a vector a variables to keep on comp 'comp'
+ } else {
+ if(comp > 1)
+ {
+ choice.keepX = keepX[1 : (comp - 1)]
+ } else {
+ choice.keepX = NULL
+ }
+ test.keepX = keepX[comp]
+ names(test.keepX) = test.keepX
+ #test.keepX is a value
+ }
+
+ # estimate performance of the model for each component
+ result = MCVfold.splsda (X, Y, multilevel = multilevel, validation = validation, folds = folds, nrepeat = nrepeat, ncomp = comp,
+ choice.keepX = if(constraint){NULL}else{choice.keepX},
+ choice.keepX.constraint = if(constraint){choice.keepX.constraint}else{NULL},
+ test.keepX = test.keepX, measure = measure, dist = dist, near.zero.var = near.zero.var,
+ auc = auc, progressBar = progressBar, class.object = class(object), cl = cl)
+
+ # ---- extract stability of features ----- # NEW
+ if (any(class(object) == "splsda"))
+ list.features[[comp]] = result$features$stable
+
+ for (ijk in dist)
+ {
+ for (measure_i in measure)
+ {
+ mat.error.rate[[measure_i]][[ijk]][ ,,comp] = result[[measure_i]]$mat.error.rate[[ijk]][,1]
+ mat.mean.error[[measure_i]][comp, ijk]=result[[measure_i]]$error.rate.mean[[ijk]]
+ if (!is.null(result[[measure_i]]$error.rate.sd))
+ {
+ mat.sd.error[[measure_i]][comp, ijk]=result[[measure_i]]$error.rate.sd[[ijk]]
+ } else {
+ mat.sd.error= NULL
+ }
+ # confusion matrix for keepX.opt
+ error.per.class.keepX.opt[[measure_i]][[ijk]][ ,comp]=result[[measure_i]]$confusion[[ijk]][,1]
+ }
+
+ #prediction of each samples for each fold and each repeat, on each comp
+ class.all[[ijk]][, , comp] = result$class.comp[[ijk]][,,1]
+ }
+ prediction.all[[comp]] = array(unlist(result$prediction.comp),c(nrow(result$prediction.comp[[1]]), ncol(result$prediction.comp[[1]]), nrepeat),
+ dimnames = c(dimnames(result$prediction.comp[[1]])[1:2], list(paste0("nrep",1:nrepeat))))#[[1]][, , 1] #take only one component [[1]] and one of test.keepX [,,1]
+
+ if(auc == TRUE)
+ {
+ auc.all[[comp]] = lapply(result$auc.all, function(x) x[,,1])
+ auc.mean[[comp]] = result$auc[, , 1]
+ }
+ }
+ if (parallel == TRUE)
+ stopCluster(cl)
+
+ names(prediction.all) = paste('comp', 1:ncomp)
+
+ result = list(error.rate = mat.mean.error,
+ error.rate.sd = mat.sd.error,
+ error.rate.all = mat.error.rate,
+ error.rate.class = error.per.class.keepX.opt[[1]],
+ predict = prediction.all,
+ class = class.all)
+
+ if(auc)
+ {
+ names(auc.mean) = c(paste('comp', 1:ncomp))
+ result$auc = auc.mean
+
+ names(auc.all) = c(paste('comp', 1:ncomp))
+ result$auc.all =auc.all
+ }
+
+ if (any(class(object) == "splsda"))
+ {
+ names(list.features) = paste('comp', 1:ncomp)
+ result$features$stable = list.features
+ }
+
+ if (progressBar == TRUE)
+ cat('\n')
+
+ # added
+ if (near.zero.var == TRUE)
+ result$nzvX = nzv$Position
+
+ if (any(class(object) == "splsda"))
+ {
+ method = "splsda.mthd"
+ } else if (any(class(object) == "plsda")) {
+ method = "plsda.mthd"
+ } else {
+ warning("Something that should not happen happened. Please contact us.")
+ }
+ class(result) = c("perf",paste(c("perf", method), collapse ="."))
+ result$call = match.call()
+
+
+ #updated outputs
+ return(invisible(result))
+}
+
+MCVfold.splsda = function(
+ X,
+ Y,
+ multilevel = NULL, # repeated measurement only
+ validation,
+ folds,
+ nrepeat = 1,
+ ncomp,
+ choice.keepX = NULL, #either choice.keepX or choice.keepX.constraint, not both
+ choice.keepX.constraint = NULL,
+ test.keepX, # can be either a vector of names (keepX.constraint) or a value(keepX). In case of a value, there needs to be names(test.keepX)
+ measure = c("overall"), # one of c("overall","BER")
+ dist = "max.dist",
+ auc = FALSE,
+ max.iter = 100,
+ near.zero.var = FALSE,
+ progressBar = TRUE,
+ class.object = NULL,
+ cl
+)
+{
+
+ pb = FALSE;
+ M = length(folds);
+ features = features.j = NULL;
+ auc.all = prediction.comp = class.comp = list()
+ for(ijk in dist)
+ class.comp[[ijk]] = array(0, c(nrow(X), nrepeat, length(test.keepX)))# prediction of all samples for each test.keepX and nrep at comp fixed
+ folds.input = folds
+ for(nrep in 1:nrepeat)
+ {
+ prediction.comp[[nrep]] = array(0, c(nrow(X), nlevels(Y), length(test.keepX)), dimnames = list(rownames(X), levels(Y), names(test.keepX)))
+ rownames(prediction.comp[[nrep]]) = rownames(X)
+ colnames(prediction.comp[[nrep]]) = levels(Y)
+
+ if(nlevels(Y)>2)
+ {
+ auc.all[[nrep]] = array(0, c(nlevels(Y),2, length(test.keepX)), dimnames = list(paste(levels(Y), "vs Other(s)"), c("AUC","p-value"), names(test.keepX)))
+ }else{
+ auc.all[[nrep]] = array(0, c(1,2, length(test.keepX)), dimnames = list(paste(levels(Y)[1], levels(Y)[2], sep = " vs "), c("AUC","p-value"), names(test.keepX)))
+ }
+
+ n = nrow(X)
+ repeated.measure = 1:n
+ if (!is.null(multilevel))
+ {
+ repeated.measure = multilevel[,1]
+ n = length(unique(repeated.measure)) # unique observation: we put every observation of the same "sample" in the either the training or test set
+ }
+
+
+ #-- define the folds --#
+ if (validation == "Mfold")
+ {
+
+ if (nrep > 1) # reinitialise the folds
+ folds = folds.input
+
+ if (is.null(folds) || !is.numeric(folds) || folds < 2 || folds > n)
+ {
+ stop("Invalid number of folds.")
+ } else {
+ M = round(folds)
+ if (is.null(multilevel))
+ {
+ temp = stratified.subsampling(Y, folds = M)
+ folds = temp$SAMPLE
+ if(temp$stop > 0 & nrep == 1) # to show only once
+ warning("At least one class is not represented in one fold, which may unbalance the error rate.\n
+ Consider a number of folds lower than the minimum in table(Y): ", min(table(Y)))
+ } else {
+ folds = split(sample(1:n), rep(1:M, length = n)) # needs to have all repeated samples in the same fold
+ }
+ }
+ } else if (validation == "loo") {
+ folds = split(1:n, rep(1:n, length = n))
+ M = n
+ }
+
+ M = length(folds)
+
+ error.sw = matrix(0, nrow = M, ncol = length(test.keepX))
+ rownames(error.sw) = paste0("fold",1:M)
+ colnames(error.sw) = names(test.keepX)
+ # for the last keepX (i) tested, prediction combined for all M folds so as to extract the error rate per class
+ # prediction.all = vector(length = nrow(X))
+ # in case the test set only includes one sample, it is better to advise the user to
+ # perform loocv
+ stop.user = FALSE
+
+ # function instead of a loop so we can use lapply and parLapply. Can't manage to put it outside without adding all the arguments
+ fonction.j.folds = function(j)#for (j in 1:M)
+ {
+ if (progressBar == TRUE)
+ setTxtProgressBar(pb, (M*(nrep-1)+j-1)/(M*nrepeat))
+
+ #print(j)
+ #set up leave out samples.
+ omit = which(repeated.measure %in% folds[[j]] == TRUE)
+
+ # get training and test set
+ X.train = X[-omit, ]
+ Y.train = Y[-omit]
+ X.test = X[omit, , drop = FALSE]#matrix(X[omit, ], nrow = length(omit)) #removed to keep the colnames in X.test
+ Y.test = Y[omit]
+
+ #---------------------------------------#
+ #-- near.zero.var ----------------------#
+
+ # first remove variables with no variance
+ var.train = apply(X.train, 2, var)
+ ind.var = which(var.train == 0)
+ if (length(ind.var) > 0)
+ {
+ X.train = X.train[, -c(ind.var),drop = FALSE]
+ X.test = X.test[, -c(ind.var),drop = FALSE]
+
+ # match choice.keepX, choice.keepX.constraint and test.keepX if needed
+ if(is.null(choice.keepX.constraint) & !is.list(test.keepX))
+ {
+ # keepX = c(choice.keepX, test.keepX[i])
+ # keepX.constraint = NULL
+
+ # reduce choice.keepX and test.keepX if needed
+ if (any(choice.keepX > ncol(X.train)))
+ choice.keepX[which(choice.keepX>ncol(X.train))] = ncol(X.train)
+
+ if (any(test.keepX > ncol(X.train)))
+ test.keepX[which(test.keepX>ncol(X.train))] = ncol(X.train)
+
+ } else if(!is.list(test.keepX)){
+ # keepX = test.keepX[i]
+ # keepX.constraint = choice.keepX.constraint
+
+ # reduce test.keepX if needed
+ if (any(test.keepX > ncol(X.train)))
+ test.keepX[which(test.keepX>ncol(X.train))] = ncol(X.train)
+
+ choice.keepX.constraint = match.keepX.constraint(names.remove = names(ind.var), keepX.constraint = choice.keepX.constraint)
+
+ } else {
+ # keepX = NULL
+ # keepX.constraint = c(choice.keepX.constraint, test.keepX)
+
+ # reduce choice.keepX.constraint if needed
+ choice.keepX.constraint = match.keepX.constraint(names.remove = names(ind.var), keepX.constraint = c(choice.keepX.constraint, test.keepX))
+
+ }
+
+ }
+
+ if(near.zero.var == TRUE)
+ {
+ remove.zero = nearZeroVar(X.train)$Position
+
+ if (length(remove.zero) > 0)
+ {
+ names.var = colnames(X.train)[remove.zero]
+
+ X.train = X.train[, -c(remove.zero),drop = FALSE]
+ X.test = X.test[, -c(remove.zero),drop = FALSE]
+
+ # match choice.keepX, choice.keepX.constraint and test.keepX if needed
+ if(is.null(choice.keepX.constraint) & !is.list(test.keepX))
+ {
+ # keepX = c(choice.keepX, test.keepX[i])
+ # keepX.constraint = NULL
+
+ # reduce choice.keepX and test.keepX if needed
+ if (any(choice.keepX > ncol(X.train)))
+ choice.keepX[which(choice.keepX>ncol(X.train))] = ncol(X.train)
+
+ if (any(test.keepX > ncol(X.train)))
+ test.keepX[which(test.keepX>ncol(X.train))] = ncol(X.train)
+
+ } else if(!is.list(test.keepX)){
+ # keepX = test.keepX[i]
+ # keepX.constraint = choice.keepX.constraint
+
+ # reduce test.keepX if needed
+ if (any(test.keepX > ncol(X.train)))
+ test.keepX[which(test.keepX>ncol(X.train))] = ncol(X.train)
+
+ choice.keepX.constraint = match.keepX.constraint(names.remove = names.var, keepX.constraint = choice.keepX.constraint)
+
+ } else {
+ # keepX = NULL
+ # keepX.constraint = c(choice.keepX.constraint, test.keepX)
+
+ # reduce choice.keepX.constraint if needed
+ choice.keepX.constraint = match.keepX.constraint(names.remove = names.var, keepX.constraint = c(choice.keepX.constraint, test.keepX))
+
+ }
+
+ }
+ #print(remove.zero)
+ }
+
+ #-- near.zero.var ----------------------#
+ #---------------------------------------#
+ prediction.comp.j = array(0, c(length(omit), nlevels(Y), length(test.keepX)), dimnames = list(rownames(X.test), levels(Y), names(test.keepX)))
+
+
+ class.comp.j = list()
+ for(ijk in dist)
+ class.comp.j[[ijk]] = matrix(0, nrow = length(omit), ncol = length(test.keepX))# prediction of all samples for each test.keepX and nrep at comp fixed
+
+
+ for (i in 1:length(test.keepX))
+ {
+ if (progressBar == TRUE)
+ setTxtProgressBar(pb, (M*(nrep-1)+j-1)/(M*nrepeat) + (i-1)/length(test.keepX)/(M*nrepeat))
+
+ # depending on whether it is a constraint and whether it is from tune or perf, keepX and keepX.constraint differ:
+ # if it's from perf, then it's only either keepX or keepX.constraint
+ # if it's from tune, then it's either keepX, or a combination of keepX.constraint and keepX
+ # we know if it's perf+constraint or tune+constraint depending on the test.keepX that is either a vector or a list
+ object.res = splsda(X.train, Y.train, ncomp = ncomp,
+ keepX = if(is.null(choice.keepX.constraint) & !is.list(test.keepX)){c(choice.keepX, test.keepX[i])}else if(!is.list(test.keepX)){test.keepX[i]} else {NULL} ,
+ keepX.constraint = if(is.null(choice.keepX.constraint)& !is.list(test.keepX)){NULL}else if(!is.list(test.keepX)){choice.keepX.constraint} else {c(choice.keepX.constraint, test.keepX)},
+ logratio = "none", near.zero.var = FALSE, mode = "regression", max.iter = max.iter)
+
+ # added: record selected features
+ if (any(class.object %in% c("splsda")) & length(test.keepX) == 1) # only done if splsda and if only one test.keepX as not used if more so far
+ # note: if plsda, 'features' includes everything: to optimise computational time, we don't evaluate for plsda object
+ features.j = selectVar(object.res, comp = ncomp)$name
+
+ test.predict.sw <- predict.spls(object.res, newdata = X.test, method = dist)
+ prediction.comp.j[, , i] = test.predict.sw$predict[, , ncomp]
+
+ for(ijk in dist)
+ class.comp.j[[ijk]][, i] = test.predict.sw$class[[ijk]][, ncomp] #levels(Y)[test.predict.sw$class[[ijk]][, ncomp]]
+ } # end i
+
+
+ return(list(class.comp.j = class.comp.j, prediction.comp.j = prediction.comp.j, features = features.j, omit = omit))
+
+ } # end fonction.j.folds
+
+
+
+ if (!is.null(cl) == TRUE)
+ {
+ result = parLapply(cl, 1: M, fonction.j.folds)
+ } else {
+ result = lapply(1: M, fonction.j.folds)
+
+ }
+
+ # combine the results
+ for(j in 1:M)
+ {
+ omit = result[[j]]$omit
+ prediction.comp.j = result[[j]]$prediction.comp.j
+ class.comp.j = result[[j]]$class.comp.j
+
+ prediction.comp[[nrep]][omit, , ] = prediction.comp.j
+
+ for(ijk in dist)
+ class.comp[[ijk]][omit,nrep, ] = class.comp.j[[ijk]]
+
+ if (any(class.object %in% c("splsda")) & length(test.keepX) == 1) # only done if splsda and if only one test.keepX as not used if more so far
+ features = c(features, result[[j]]$features)
+
+ }
+
+ if (progressBar == TRUE)
+ setTxtProgressBar(pb, (M*nrep)/(M*nrepeat))
+
+ if(auc)
+ {
+ data=list()
+ for (i in 1:length(test.keepX))
+ {
+ data$outcome = Y
+ data$data = prediction.comp[[nrep]][, , i]
+ auc.all[[nrep]][, , i] = as.matrix(statauc(data))
+ }
+ }
+
+ } #end nrep 1:nrepeat
+
+ names(prediction.comp) = names (auc.all) = paste0("nrep.", 1:nrepeat)
+ # class.comp[[ijk]] is a matrix containing all prediction for test.keepX, all nrepeat and all distance, at comp fixed
+
+ # average auc over the nrepeat, for each test.keepX
+ if(auc)
+ {
+
+ if(nlevels(Y)>2)
+ {
+ auc.mean.sd = array(0, c(nlevels(Y),2, length(test.keepX)), dimnames = list(rownames(auc.all[[1]]), c("AUC.mean","AUC.sd"), names(test.keepX)))
+ }else{
+ auc.mean.sd = array(0, c(1,2, length(test.keepX)), dimnames = list(rownames(auc.all[[1]]), c("AUC.mean","AUC.sd"), names(test.keepX)))
+ }
+
+ for(i in 1:length(test.keepX))
+ {
+ temp = NULL
+ for(nrep in 1:nrepeat)
+ {
+ temp = cbind(temp, auc.all[[nrep]][, 1, i])
+ }
+ auc.mean.sd[, 1, i] = apply(temp,1,mean)
+ auc.mean.sd[, 2, i] = apply(temp,1,sd)
+ }
+ } else {
+ auc.mean.sd = auc.all = NULL
+
+ }
+
+ result = list()
+ error.mean = error.sd = error.per.class.keepX.opt.comp = keepX.opt = test.keepX.out = mat.error.final = choice.keepX.out = list()
+
+ if (any(measure == "overall"))
+ {
+ for(ijk in dist)
+ {
+ rownames(class.comp[[ijk]]) = rownames(X)
+ colnames(class.comp[[ijk]]) = paste0("nrep.", 1:nrepeat)
+ dimnames(class.comp[[ijk]])[[3]] = paste0("test.keepX.",names(test.keepX))
+
+ #finding the best keepX depending on the error measure: overall or BER
+ # classification error for each nrep and each test.keepX: summing over all samples
+ error = apply(class.comp[[ijk]],c(3,2),function(x)
+ {
+ sum(as.character(Y) != x)
+ })
+ rownames(error) = names(test.keepX)
+ colnames(error) = paste0("nrep.",1:nrepeat)
+
+ # we want to average the error per keepX over nrepeat and choose the minimum error
+ error.mean[[ijk]] = apply(error,1,mean)/length(Y)
+ if (!nrepeat == 1)
+ error.sd[[ijk]] = apply(error,1,sd)/length(Y)
+
+ mat.error.final[[ijk]] = error/length(Y) # percentage of misclassification error for each test.keepX (rows) and each nrepeat (columns)
+
+ keepX.opt[[ijk]] = which(error.mean[[ijk]] == min(error.mean[[ijk]]))[1] # chose the lowest keepX if several minimum
+
+ # confusion matrix for keepX.opt
+ error.per.class.keepX.opt.comp[[ijk]] = apply(class.comp[[ijk]][, , keepX.opt[[ijk]], drop = FALSE], 2, function(x)
+ {
+ conf = get.confusion_matrix(Y.learn = factor(Y), Y.test = factor(Y), pred = x)
+ out = (apply(conf, 1, sum) - diag(conf)) / summary(Y)
+ })
+
+ rownames(error.per.class.keepX.opt.comp[[ijk]]) = levels(Y)
+ colnames(error.per.class.keepX.opt.comp[[ijk]]) = paste0("nrep.", 1:nrepeat)
+
+
+ test.keepX.out[[ijk]] = test.keepX[keepX.opt[[ijk]]]
+ if(is.null(choice.keepX))
+ {
+ choice.keepX.out[[ijk]] = c(lapply(choice.keepX.constraint,length), test.keepX.out)
+ }else{
+ choice.keepX.out[[ijk]] = c(choice.keepX, test.keepX.out)
+ }
+ result$"overall"$error.rate.mean = error.mean
+ if (!nrepeat == 1)
+ result$"overall"$error.rate.sd = error.sd
+
+ result$"overall"$confusion = error.per.class.keepX.opt.comp
+ result$"overall"$mat.error.rate = mat.error.final
+ result$"overall"$keepX.opt = test.keepX.out
+ }
+ }
+
+ if (any(measure == "BER"))
+ {
+ for(ijk in dist)
+ {
+ rownames(class.comp[[ijk]]) = rownames(X)
+ colnames(class.comp[[ijk]]) = paste0("nrep.", 1:nrepeat)
+ dimnames(class.comp[[ijk]])[[3]] = paste0("test.keepX.",names(test.keepX))
+
+ error = apply(class.comp[[ijk]],c(3,2),function(x)
+ {
+ conf = get.confusion_matrix(Y.learn = factor(Y),Y.test = factor(Y),pred = x)
+ get.BER(conf)
+ })
+ rownames(error) = names(test.keepX)
+ colnames(error) = paste0("nrep.",1:nrepeat)
+
+ # average BER over the nrepeat
+ error.mean[[ijk]] = apply(error,1,mean)
+ if (!nrepeat == 1)
+ error.sd[[ijk]] = apply(error,1,sd)
+
+ mat.error.final[[ijk]] = error # BER for each test.keepX (rows) and each nrepeat (columns)
+
+ keepX.opt[[ijk]] = which(error.mean[[ijk]] == min(error.mean[[ijk]]))[1]
+
+ # confusion matrix for keepX.opt
+ error.per.class.keepX.opt.comp[[ijk]] = apply(class.comp[[ijk]][, , keepX.opt[[ijk]], drop = FALSE], 2, function(x)
+ {
+ conf = get.confusion_matrix(Y.learn = factor(Y), Y.test = factor(Y), pred = x)
+ out = (apply(conf, 1, sum) - diag(conf)) / summary(Y)
+ })
+
+ rownames(error.per.class.keepX.opt.comp[[ijk]]) = levels(Y)
+ colnames(error.per.class.keepX.opt.comp[[ijk]]) = paste0("nrep.", 1:nrepeat)
+
+ test.keepX.out[[ijk]] = test.keepX[keepX.opt[[ijk]]]
+ if(is.null(choice.keepX))
+ {
+ choice.keepX.out[[ijk]] = c(lapply(choice.keepX.constraint,length), test.keepX.out)
+ }else{
+ choice.keepX.out[[ijk]] = c(choice.keepX, test.keepX.out)
+ }
+ result$"BER"$error.rate.mean = error.mean
+ if (!nrepeat == 1)
+ result$"BER"$error.rate.sd = error.sd
+
+ result$"BER"$confusion = error.per.class.keepX.opt.comp
+ result$"BER"$mat.error.rate = mat.error.final
+ result$"BER"$keepX.opt = test.keepX.out
+
+ }
+
+
+ }
+
+
+ result$prediction.comp = prediction.comp
+ result$auc = auc.mean.sd
+ result$auc.all = auc.all
+ result$class.comp = class.comp
+ result$features$stable = sort(table(as.factor(features))/M/nrepeat, decreasing = TRUE)
+ return(result)
+}
+
+#'Perform Sparse Generalized Canonical Correlation (sgccak)
+#'@description Runs sgccak() modified from RGCCA
+#'@param A Data
+#'@param design Set design
+#'@param study Default set to NULL
+#'@param keepA.constraint Default set to NULL
+#'@param keepA Default set to NULL
+#'@param scheme Scheme, default set to "horst"
+#'@param init Init mode, default set to "svd"
+#'@param max.iter Max number of iterations, numeric, default set to 100
+#'@param tol Tolerance, numeric, default set to 1e-06
+#'@param verbose Default set to TRUE
+#'@param bias Default set to FALSE
+#'@param penalty Default set to NULL
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+sparse.mint.block_iteration = function(A, design, study = NULL, keepA.constraint = NULL, keepA = NULL,
+ scheme = "horst", init = "svd", max.iter = 100, tol = 1e-06, verbose = TRUE, bias = FALSE,
+ penalty=NULL){
+
+ # keepA.constraint is a list of positions in A of the variables to keep on the component
+ # keepA is a vector of numbers
+ # study is a vector
+ # == == == == no check needed as this function is only used in internal_mint.block, in which the checks are conducted
+
+ ### Start: Initialization parameters
+ J = length(A)
+ J2 = J-1
+ pjs = sapply(A, NCOL)
+ AVE_X = rep(0, J)
+ if (!is.null(penalty))
+ penalty = penalty * sqrt(pjs)
+
+
+ iter = 1
+ converg = crit = numeric()
+ variates.A = Z = matrix(0, NROW(A[[1]]), J)
+ misdata = any(sapply(A, function(x){any(is.na(x))})) # Detection of missing data
+
+ if (misdata)
+ is.na.A = lapply(A, is.na)
+
+ g = function(x) switch(scheme, horst = x, factorial = x^2, centroid = abs(x))
+
+
+ # study split
+ A_split = lapply(A, study_split, study)
+ if (misdata)
+ is.na.A_split = lapply(is.na.A, study_split, study)
+
+ nlevels_study = nlevels(study)
+ ### End: Initialization parameters
+
+ ### Start: Initialisation "loadings.A" vector
+ if (init == "svd")
+ {
+ ### Start: Change initialization of loadings.A
+ if (misdata)
+ {
+ M = lapply(c(1:(J-1)), function(x){crossprod(replace(A[[x]], is.na(A[[x]]), 0), replace(A[[J]], is.na(A[[J]]), 0))})
+ } else {
+ M = lapply(c(1:(J-1)), function(x){crossprod(A[[x]], A[[J]])})
+ }
+
+ svd.M = lapply(M, function(x){svd(x, nu = 1, nv = 1)})
+ loadings.A = lapply(c(1:(J-1)), function(x){svd.M[[x]]$u})
+ loadings.A[[J]] = svd.M[[1]]$v
+ } else if (init=="svd.single") {
+ alpha = lapply(1 : J, function(y){initsvd(lapply(y, function(x) {replace(A[[x]], is.na(A[[x]]), 0)})[[1]])})
+
+ loadings.A = list()
+ for (j in 1:J)
+ {
+ if (nrow(A[[j]]) >= ncol(A[[j]]))
+ {
+ loadings.A[[j]] = alpha[[j]]
+ } else {
+ K = as.matrix(A[[j]]) %*% as.matrix(t(A[[j]]))
+ N = ifelse(bias, nrow(A[[j]]), nrow(A[[j]]) - 1)
+ alpha[[j]] = drop(1/sqrt(t(alpha[[j]]) %*% K %*% alpha[[j]])) * alpha[[j]]
+ loadings.A[[j]] = t(A[[j]]) %*% alpha[[j]]
+ }
+ }
+
+ ### End: Change initialization of a
+ } else {
+ stop("init should be either 'svd' or 'svd.single'.")
+ }
+ ### End: Initialisation "a" vector
+ variates.partial.A.comp = NULL
+ loadings.partial.A.comp = list()
+ for (q in 1:J)
+ {
+ if(misdata)
+ {
+ #variates.A[, q] = apply(A[[q]], 1, miscrossprod, loadings.A[[q]])
+ A.temp = replace(A[[q]], is.na.A[[q]], 0) # replace NA in A[[q]] by 0
+ variates.A.temp = A.temp %*% loadings.A[[q]]
+ temp = drop(loadings.A[[q]]) %o% rep(1, nrow(A[[q]]))
+ temp[(t(is.na.A[[q]]))] = 0
+ loadings.A.norm = crossprod(temp)
+ variates.A[, q] = variates.A.temp / diag(loadings.A.norm)
+ # we can have 0/0, so we put 0
+ a = is.na(variates.A[, q])
+ if (any(a))
+ variates.A[a, q] = 0
+ }else{
+ variates.A[, q] = A[[q]]%*%loadings.A[[q]]
+ }
+ loadings.A[[q]] = l2.norm(as.vector(loadings.A[[q]]))
+ loadings.partial.A.comp[[q]] = list()
+ }
+ loadings.A_old = loadings.A
+
+ ### Start Algorithm 1 Sparse generalized canonical analysis (See Variable selection for generalized canonical correlation analysis (Tenenhaus))
+ repeat {
+ #variates.Aold can be used for the convergence of the algorithm, not used at the moment, so please disregard variates.Aold
+ variates.Aold = variates.A
+ for (q in 1:J)
+ {
+ ### Start : !!! Impact of the diag of the design matrix !!! ###
+ if (scheme == "horst")
+ CbyCovq = design[q, ]
+
+ if (scheme == "factorial")
+ CbyCovq = design[q, ] * cov2(variates.A, variates.A[, q], bias = bias)
+
+ if (scheme == "centroid")
+ CbyCovq = design[q, ] * sign(cov2(variates.A, variates.A[, q], bias = bias))
+ ### End : !!! Impact of the diag of the design matrix !!! ###
+
+ ### Step A start: Compute the inner components
+ Z[, q] = rowSums(mapply("*", CbyCovq, as.data.frame(variates.A)))
+ Z_split = study_split(Z[,q,drop=FALSE],study) # split Z by the study factor
+ ### Step A end: Compute the inner components
+
+
+ ### Step B start: Computer the outer weight ###
+ # possibility of removing NA (replacing by 0) and use crossprod, further development
+ temp=0
+ for (m in 1:nlevels_study)
+ {
+ if(misdata)
+ {
+ loadings.partial.A.comp[[q]][[m]] = apply(t(A_split[[q]][[m]]), 1, miscrossprod, Z_split[[m]])
+ }else{
+ loadings.partial.A.comp[[q]][[m]] = t(A_split[[q]][[m]])%*%Z_split[[m]]
+ }
+ temp=temp+loadings.partial.A.comp[[q]][[m]]
+ }
+ loadings.A[[q]] = temp
+
+
+ # sparse using keepA / penalty
+ if (!is.null(penalty))
+ {
+ loadings.A[[q]] = sparsity(loadings.A[[q]], keepA = NULL,keepA.constraint = NULL, penalty = penalty[q])
+ }else{
+ loadings.A[[q]] = sparsity(loadings.A[[q]], keepA[[q]], keepA.constraint[[q]], penalty = NULL)
+ }
+
+ loadings.A[[q]]=l2.norm(as.vector(loadings.A[[q]]))
+
+ ### Step B end: Computer the outer weight ###
+ if(misdata)
+ {
+ #variates.A[, q] = apply(A[[q]], 1, miscrossprod, loadings.A[[q]])
+ A.temp = replace(A[[q]], is.na.A[[q]], 0) # replace NA in A[[q]] by 0
+ variates.A.temp = A.temp %*% loadings.A[[q]]
+ temp = drop(loadings.A[[q]]) %o% rep(1, nrow(A[[q]]))
+ temp[(t(is.na.A[[q]]))] = 0
+ loadings.A.norm = crossprod(temp)
+ variates.A[, q] = variates.A.temp / diag(loadings.A.norm)
+ # we can have 0/0, so we put 0
+ a = is.na(variates.A[, q])
+ if (any(a))
+ variates.A[a, q] = 0
+
+ }else{
+ variates.A[, q] = A[[q]]%*%loadings.A[[q]]
+ }
+
+ }
+
+ crit[iter] = sum(design * g(cov2(variates.A, bias = bias)))
+
+ if (iter > max.iter)
+ warning("The SGCCA algorithm did not converge", call. = FALSE)#cat("The SGCCA algorithm did not converge after", max.iter ,"iterations."))
+
+ ### Start: Match algorithm with mixOmics algo (stopping point)
+ ### if ((converg[iter] < tol & sum(stationnary_point) == J) | iter > max.iter)
+ if (max(sapply(1:J, function(x){crossprod(loadings.A[[x]] - loadings.A_old[[x]])})) < tol | iter > max.iter)
+ break
+ ### End: Match algorithm with mixOmics algo (stopping point)
+
+ loadings.A_old = loadings.A
+ iter = iter + 1
+ }
+ ### End Algorithm 1 (See Variable selection for generalized canonical correlation analysis (Tenenhaus))
+
+
+ #calculation variates.partial.A.comp
+ variates.partial.A.comp = lapply(1 : J, function(x){
+ lapply(1 : nlevels_study, function(y){
+ if(misdata)
+ {
+ #apply(A_split[[x]][[y]], 1, miscrossprod, loadings.A[[x]])
+ A.temp = replace(A_split[[x]][[y]], is.na.A_split[[x]][[y]], 0) # replace NA in A_split[[x]][[y]] by 0
+ variates.part.A.temp = A.temp %*% loadings.A[[x]]
+ temp = drop(loadings.A[[x]]) %o% rep(1, nrow(A_split[[x]][[y]]))
+ temp[(t(is.na.A[[x]][[y]]))] = 0
+ loadings.A.norm = crossprod(temp)
+ variates.part.A = variates.part.A.temp / diag(loadings.A.norm)
+ # we can have 0/0, so we put 0
+ a = is.na(variates.part.A)
+ if (any(a))
+ variates.part.A[a] = 0
+
+ return(variates.part.A)
+ }else{
+ A_split[[x]][[y]] %*% loadings.A[[x]]
+ }
+ })
+ })
+
+ if (verbose)
+ plot(crit, xlab = "iteration", ylab = "criteria")
+
+ AVE_inner = sum(design * cor(variates.A)^2/2)/(sum(design)/2)
+
+ result = list(variates.A = variates.A, loadings.A = loadings.A, crit = crit[which(crit != 0)],
+ AVE_inner = AVE_inner, loadings.partial.A.comp = loadings.partial.A.comp, variates.partial.A.comp = variates.partial.A.comp, iter = iter)
+ return(result)
+}
+
+mean_centering_per_study=function(data, study, scale, bias=FALSE)
+{
+
+ M = length(levels(study)) # number of groups
+ # split the data
+ data.list.study = study_split(data, study)
+
+ # center and scale data per group, and concatene the data
+ res = lapply(data.list.study, scale.function, scale = scale, bias = bias)
+ concat.data = do.call("rbind", lapply(res,function(x){x[[1]]}))
+ meanX = lapply(res, function(x){x[[2]]})
+ sqrt.sdX = lapply(res, function(x){x[[3]]})
+ rownames.study = lapply(res, function(x){rownames(x[[1]])})
+
+ #rename rows and cols of concatenated centered (and/or scaled) data
+ colnames(concat.data) = colnames(data)
+
+ #sort the samples as in the original X
+ indice.match = match(rownames(data),rownames(concat.data))
+ concat.data = concat.data[indice.match, ,drop=FALSE]
+
+ if (M > 1)
+ {
+ for (m in 1:M)
+ {
+ attr(concat.data,paste0("means:", levels(study)[m])) = meanX[[m]]
+ if(scale)
+ {
+ attr(concat.data,paste0("sigma:", levels(study)[m])) = sqrt.sdX[[m]]
+ } else {
+ attr(concat.data,paste0("sigma:", levels(study)[m])) = NULL
+ }
+ }
+ } else {
+ attr(concat.data,"scaled:center") = meanX[[1]]
+ if (scale)
+ {
+ attr(concat.data,"scaled:scale") = sqrt.sdX[[1]]
+ } else {
+ attr(concat.data,"scaled:scale") = NULL
+ }
+ }
+
+ return(list(concat.data=concat.data, rownames.study=rownames.study))
+}
+
+study_split = function(data, study)
+{
+ data = as.matrix(data)
+ M = length(levels(study))
+ P = ncol(data)
+
+ #---------------------- split data
+ data.list.study = split(data,study)
+ if (!is.null(rownames(data)))
+ study.name = split(rownames(data),study)
+
+ for(m in 1:M)
+ {
+ data.list.study[[m]] = matrix(data.list.study[[m]], ncol=P)
+
+ if (!is.null(colnames(data)))
+ colnames(data.list.study[[m]]) = colnames(data)
+
+ if (!is.null(rownames(data)))
+ rownames(data.list.study[[m]]) = study.name[[m]]
+ }
+ result = data.list.study
+ return(invisible(result))
+}
+
+scale.function=function(temp, scale = TRUE, bias = FALSE)
+{
+ meanX = colMeans(temp, na.rm = TRUE)
+ data.list.study.scale_i = t(t(temp) - meanX)
+ if (scale)
+ {
+ if (bias)
+ {
+ sqrt.sdX = sqrt(colSums(data.list.study.scale_i^2, na.rm = TRUE) / (nrow(temp)))
+ } else {
+ sqrt.sdX = sqrt(colSums(data.list.study.scale_i^2, na.rm = TRUE) / (nrow(temp) - 1))
+ }
+ data.list.study.scale_i = t(t(data.list.study.scale_i) / sqrt.sdX)
+ } else {
+ sqrt.sdX = NULL
+ }
+
+ is.na.data = is.na(data.list.study.scale_i)
+ #if (sum(is.na.data) > 0)
+ #data.list.study.scale_i[is.na.data] = 0
+
+ out = list(data_scale=data.list.study.scale_i, meanX=meanX, sqrt.sdX=sqrt.sdX)
+ return(out)
+}
+
+l2.norm=function(x)
+{
+ if (!is.vector(x))
+ stop("x has to be a vector")
+
+ out = x / drop(sqrt(crossprod(x)))
+}
+
+miscrossprod = function (x, y) {
+ d.p = sum(drop(x) * drop(y), na.rm = TRUE)
+ #d.p = as.vector(d.p)/norm2(d.p) ## change made
+ return(d.p)
+}
+
+sparsity=function(loadings.A, keepA, keepA.constraint=NULL, penalty=NULL)
+{
+
+ if (!is.null(keepA.constraint))
+ {
+ loadings.A[-keepA.constraint] = 0
+ } else if (!is.null(keepA)) {
+ nx = length(loadings.A) - keepA
+ loadings.A = soft_thresholding_L1(loadings.A, nx = nx)
+ } else if (!is.null(penalty)) {
+ loadings.A = soft.threshold(loadings.A, penalty)
+ }
+
+ return(loadings.A)
+}
+
+soft_thresholding_L1 = function(x,nx)
+{
+ #selection on a (loadings.X). modified on 19/02/15 to make sure that a!=0
+ if (nx!=0)
+ {
+ absa = abs(x)
+ if (any(rank(absa, ties.method = "max") <= nx))
+ {
+ x = ifelse(rank(absa, ties.method = "max") <= nx, 0,
+ sign(x) * (absa - max(absa[rank(absa, ties.method = "max") <= nx])))
+ }
+ }
+
+ x
+}
+
+cov2 = function (x, y = NULL, bias = TRUE) {
+ n = NROW(x)
+ if (is.null(y)) {
+ x = as.matrix(x)
+ if (bias) {
+ C = ((n - 1)/n) * cov(x, use = "pairwise.complete.obs")
+ } else {
+ C = cov(x, use = "pairwise.complete.obs")
+ }
+ } else {
+ if (bias) {
+ C = ((n - 1)/n) * cov(x, y, use = "pairwise.complete.obs")
+ } else {
+ C = cov(x, y, use = "pairwise.complete.obs")
+ }
+ }
+ return(C)
+}
+
+defl.select = function(yy, rr, nncomp, nn, nbloc, indY = NULL, mode = "canonical", aa = NULL) { ### Start: Add new parameter for estimation classic mode
+ resdefl = NULL
+ pdefl = NULL
+ for (q in 1 : nbloc) {
+ ### Start: insertion of new deflations (See La regression PLS Theorie et pratique (page 139))
+ if ( nn <= nncomp[q] ) {
+ if ((mode == "canonical") || (q != indY)) { #deflation of each block independently from the others, except indY
+ defltmp = deflation(rr[[q]], yy[ , q])
+ resdefl[[q]] = defltmp$R
+ pdefl[[q]] = defltmp$p
+ } else if (mode == "classic") {
+ resdefl[[q]] = Reduce("+", lapply(c(1:nbloc)[-q], function(x) {rr[[q]] - yy[ ,x]%*%t(aa[[q]])}))/(nbloc-1)
+ pdefl[[q]] = rep(0,NCOL(rr[[q]]))
+ } else if (mode == "invariant") { #no deflation
+ resdefl[[q]] = rr[[q]]
+ pdefl[[q]] = rep(0,NCOL(rr[[q]]))
+ } else if (mode == "regression") {
+ resdefl[[q]] = Reduce("+", lapply(c(1:nbloc)[-q], function(x) {deflation(rr[[q]],yy[, x])$R}))/(nbloc-1)
+ pdefl[[q]] = rep(0,NCOL(rr[[q]]))
+ }
+ ### End: insertion of new deflations (See La regression PLS Theorie et pratique (page 139))
+ } else {
+ resdefl[[q]] = rr[[q]]
+ pdefl[[q]] = rep(0,NCOL(rr[[q]]))
+ }
+ }
+ return(list(resdefl=resdefl,pdefl=pdefl))
+}
+
+deflation = function(X, y){
+ # Computation of the residual matrix R
+ # Computation of the vector p.
+ is.na.tX = is.na(t(X))
+ if (any(is.na.tX))
+ {
+ #p = apply(t(X),1,miscrossprod,y)/as.vector(crossprod(y))
+
+ #variates.A[, q] = apply(A[[q]], 1, miscrossprod, loadings.A[[q]])
+ A.temp = replace(t(X), is.na.tX, 0) # replace NA in A[[q]] by 0
+ variates.A.temp = A.temp %*% y
+ temp = drop(y) %o% rep(1, nrow(A.temp))
+ temp[(t(is.na.tX))] = 0
+ loadings.A.norm = crossprod(temp)
+ p = variates.A.temp / diag(loadings.A.norm)
+ # we can have 0/0, so we put 0
+ a = is.na(p)
+ if (any(a))
+ p[a] = 0
+
+ } else {
+ p = t(X)%*%y/as.vector(crossprod(y))
+ }
+
+ R = X - y%*%t(p)
+ return(list(p=p,R=R))
+}
+
+explained_variance = function(data, variates, ncomp)
+{
+ #check input data
+ check = Check.entry.single(data, ncomp)
+ data = check$X
+ ncomp = check$ncomp
+
+ isna = is.na(data)
+ if (sum(isna > 0))
+ {
+ warning("NA values put to zero, results will differ from PCA methods used with NIPALS")
+ data[isna] = 0
+ }
+ nor2x = sum((data)^2) # total variance in the data
+ exp.varX = NULL
+ for (h in 1:ncomp)
+ {
+ temp = variates[, h] / drop(t(variates[, h]) %*% (variates[, h]))
+ exp_var_new = as.numeric(t(variates[, h]) %*% data %*% t(data) %*% temp )/nor2x
+ exp.varX = append(exp.varX, exp_var_new)
+
+ }
+ names(exp.varX) = paste("comp", 1:ncomp)
+
+ # result: vector of length ncomp with the explained variance per component
+ exp.varX
+}
+
+Check.entry.single = function(X, ncomp, q){
+
+ #-- validation des arguments --#
+ if (length(dim(X)) != 2)
+ stop(paste0("'X[[", q, "]]' must be a numeric matrix."))
+
+ X = as.matrix(X)
+
+ if (!is.numeric(X))
+ stop(paste0("'X[[", q, "]]' must be a numeric matrix."))
+
+ N = nrow(X)
+ P = ncol(X)
+
+ if (is.null(ncomp) || !is.numeric(ncomp) || ncomp <= 0)
+ stop(paste0("invalid number of variates 'ncomp' for matrix 'X[[", q, "]]'."))
+
+ ncomp = round(ncomp)
+
+ # add colnames and rownames if missing
+ X.names = dimnames(X)[[2]]
+ if (is.null(X.names))
+ {
+ X.names = paste("X", 1:P, sep = "")
+ dimnames(X)[[2]] = X.names
+ }
+
+ ind.names = dimnames(X)[[1]]
+ if (is.null(ind.names))
+ {
+ ind.names = 1:N
+ rownames(X) = ind.names
+ }
+
+ if (length(unique(rownames(X))) != nrow(X))
+ stop("samples should have a unique identifier/rowname")
+ if (length(unique(X.names)) != P)
+ stop("Unique indentifier is needed for the columns of X")
+
+ return(list(X=X, ncomp=ncomp, X.names=X.names, ind.names=ind.names))
+}
+
+
+
+
+
+
+
+
+stratified.subsampling = function(Y, folds = 10)
+{
+ stop = 0
+ for(i in 1:nlevels(Y))
+ {
+ ai=sample(which(Y==levels(Y)[i]),replace=FALSE) # random sampling of the samples from level i
+ aai=suppressWarnings(split(ai,factor(1:min(folds,length(ai))))) # split of the samples in k-folds
+ if(length(ai)<folds) # if one level doesn't have at least k samples, the list is completed with "integer(0)"
+ {
+ for(j in (length(ai)+1):folds)
+ aai[[j]]=integer(0)
+ stop = stop +1
+ }
+ assign(paste("aa",i,sep="_"),sample(aai,replace=FALSE)) # the `sample(aai)' is to avoid the first group to have a lot more data than the rest
+ }
+
+ # combination of the different split aa_i into SAMPLE
+ SAMPLE=list()
+ for(j in 1:folds)
+ {
+ SAMPLE[[j]]=integer(0)
+ for(i in 1:nlevels(Y))
+ {
+ SAMPLE[[j]]=c(SAMPLE[[j]],get(paste("aa",i,sep="_"))[[j]])
+ }
+ }# SAMPLE is a list of k splits
+
+ ind0 = sapply(SAMPLE, length)
+ if(any(ind0 == 0))
+ {
+ SAMPLE = SAMPLE [-which(ind0 == 0)]
+ message("Because of a too high number of 'folds' required, ",length(which(ind0 == 0))," folds were randomly assigned no data: the number of 'folds' is reduced to ", length(SAMPLE))
+ }
+
+ return(list(SAMPLE = SAMPLE, stop = stop))
+}
+
+selectVar <- function(object, comp =1, block=NULL, ...){
+
+ # check arguments
+ # -----------------
+ if (length(comp) > 1)
+ stop("Expecting one single value for 'comp'")
+
+ if (is.null(block))
+ {
+ if (any(comp > object$ncomp))
+ stop("'comp' is greater than the number of components in the fitted model")
+ null.block=TRUE
+ block=1:length(object$loadings)
+
+ }else{
+ if (any(class(object)%in%c("pca")))
+ object$names$blocks="X"
+
+ if (is.numeric(block))
+ {
+ if (any(block>length(object$names$blocks)))
+ stop("'block' needs to be lower than the number of blocks in the fitted model, which is length(object$names$blocks)")
+
+ }else if (is.character(block) & sum(!is.na(match(block,object$names$blocks)))==0) {
+ stop("No entry of 'block' match object$names$blocks")
+
+ }else if (is.character(block) & sum(is.na(match(block,object$names$blocks)))>0) {
+ warning("At least one entry of 'block' does not match object$names$blocks")
+ }
+
+ if (length(object$ncomp)>1)
+ {
+ if (any(comp > object$ncomp[block]))
+ stop("'comp' is greater than the number of components in the fitted model for the block you specified. See object$ncomp")
+
+ }else{
+ if (any(comp > object$ncomp))
+ stop("'comp' is greater than the number of components in the fitted model")
+ }
+
+ null.block=FALSE
+ }
+
+ # main function: get the names and values of the non zero loadings
+ # -----------------
+ out = lapply(object$loadings[block],get.name.and.value,comp=comp)
+
+
+ # outputs
+ # ----------
+ #if all blocks are considered by default (null.block=TRUE) and it's a DA analysis, then we don't show Y
+ if (null.block)
+ {
+ if (any(class(object)%in%c("block.plsda","block.splsda")))# the position of Y is in indY
+ {
+ out=out[-object$indY] #remove Y
+ }else if (any(class(object)%in%c("mint.plsda","mint.splsda","plsda","splsda"))) {
+ # Y is always in second position
+ out=out[[1]]
+ }else if (any(class(object)%in%c("pca"))) { #keep the result as a list
+ out=out[[1]]
+ }
+
+ } else {
+ if (length(grep("pca",class(object)))>0)
+ out=out
+ }
+
+ #we add comp as an output
+ out$comp=comp
+
+ return(out)
+}
+
+get.name.and.value=function(x,comp)
+{
+ if(length(x[,comp,drop=FALSE]) > 1)
+ {
+ name.var = names(sort(abs(x[,comp]), decreasing = T)[1:sum(x[,comp]!=0)])
+ } else {
+ name.var = rownames(x) # when only one number, sort loses the name of the variable
+ }
+ value.var=x[name.var,comp]
+ return(list(name = name.var, value = data.frame(value.var)))
+}
+
+get.confusion_matrix = function(Y.learn,Y.test,pred)
+{
+ ClassifResult = array(0,c(nlevels(factor(Y.learn)),nlevels(factor(Y.learn))))
+ rownames(ClassifResult) = levels(factor(Y.learn))
+ colnames(ClassifResult) = paste("predicted.as.",levels(factor(Y.learn)),sep = "")
+ #--------record of the classification accuracy for each level of Y
+ for(i in 1:nlevels(factor(Y.learn)))
+ {
+ ind.i = which(Y.test == levels(factor(Y.learn))[i])
+ for(ij in 1:nlevels(factor(Y.learn)))
+ {
+ ClassifResult[i,ij] = sum(pred[ind.i] == levels(Y.learn)[ij])
+
+ }
+ }
+ ClassifResult
+}
+
+get.BER = function(X)
+{
+ if(!is.numeric(X)| !is.matrix(X) | length(dim(X)) != 2 | nrow(X)!=ncol(X))
+ stop("'X' must be a square numeric matrix")
+
+ nlev = nrow(X)
+ #calculation of the BER
+ ClassifResult.temp = X
+ diag(ClassifResult.temp) = 0
+ BER = sum(apply(ClassifResult.temp,1,sum,na.rm = TRUE)/apply(X,1,sum,na.rm = TRUE),na.rm = TRUE)/nlev
+ return(BER)
+}
+
+#predict.block.pls <-predict.block.spls <- predict.mint.splsda <- predict.pls <-
+predict.spls <- function(object, newdata, study.test, dist = c("all", "max.dist", "centroids.dist", "mahalanobis.dist"), multilevel = NULL, ...)
+{
+
+ ncomp = object$ncomp
+ newdata.input=newdata
+
+ if(length(grep("plsda", class(object)))>0) # a DA analysis (mint).(block).(s)plsda
+ {
+ #if DA analysis, the unmap Y is in ind.mat
+ Y.factor=object$Y
+ Y=object$ind.mat
+ }else{
+ #if not DA, Y is in object$Y
+ Y=object$Y
+ if(is.null(Y)) # block analysis
+ {
+ Y=object$X[[object$indY]]
+ }
+ }
+ q=ncol(Y)
+
+
+ p=ncol(object$X)
+ if(is.list(object$X))
+ stop("Something is wrong, object$X should be a matrix and it appears to be a list") #this should never happen/intern check
+
+ if(is.list(newdata) & !is.data.frame(newdata))
+ stop("'newdata' must be a numeric matrix")
+
+ # deal with near.zero.var in object, to remove the same variable in newdata as in object$X (already removed in object$X)
+ if(length(object$nzv$Position) > 0)
+ newdata = newdata[, -object$nzv$Position,drop=FALSE]
+
+ if(all.equal(colnames(newdata),colnames(object$X))!=TRUE)
+ stop("'newdata' must include all the variables of 'object$X'")
+
+ #not a block, the input newdata should be a matrix
+ if (length(dim(newdata)) == 2) {
+ if (ncol(newdata) != p)
+ stop("'newdata' must be a numeric matrix with ncol = ", p,
+ " or a vector of length = ", p, ".")
+ }
+
+ if (length(dim(newdata)) == 0) {
+ if (length(newdata) != p)
+ stop("'newdata' must be a numeric matrix with ncol = ", p,
+ " or a vector of length = ", p, ".")
+ dim(newdata) = c(1, p)
+ }
+
+ #check col/rownames of newdata
+ check=Check.entry.single(newdata, ncomp,q=1)
+ newdata=check$X
+
+ if(length(rownames(newdata))==0) rownames(newdata)=1:nrow(newdata)
+ if(max(table(rownames(newdata)))>1) stop('samples should have a unique identifier/rowname')
+
+ # we transform everything in lists
+ X=list(X=object$X)
+ object$X=X
+ newdata=list(newdata=newdata)
+
+ object$indY=2
+ ind.match = 1
+
+
+ # logratio and multilevel transform if necessary
+ if (!is.null(object$logratio))
+ newdata = lapply(newdata, logratio.transfo, logratio = object$logratio)
+
+ if(!is.null(multilevel))
+ newdata = lapply(newdata, withinVariation, design = data.frame(multilevel))
+
+ p = lapply(X, ncol)
+ q = ncol(Y)
+ J = length(X) #at this stage we have a list of blocks
+ variatesX = object$variates[-(J + 1)];
+ loadingsX = object$loadings[-(J + 1)]
+
+ scale = object$scale # X and Y are both mean centered by groups and if scale=TRUE they are scaled by groups
+
+ # scale newdata if just one study
+ if (!is.null(attr(X[[1]], "scaled:center")))
+ newdata[which(!is.na(ind.match))] = lapply(which(!is.na(ind.match)), function(x){sweep(newdata[[x]], 2, STATS = attr(X[[x]], "scaled:center"))})
+ if (scale)
+ newdata[which(!is.na(ind.match))] = lapply(which(!is.na(ind.match)), function(x){sweep(newdata[[x]], 2, FUN = "/", STATS = attr(X[[x]], "scaled:scale"))})
+
+ means.Y = matrix(attr(Y, "scaled:center"),nrow=nrow(newdata[[1]]),ncol=q,byrow=TRUE);
+ if (scale)
+ {sigma.Y = matrix(attr(Y, "scaled:scale"),nrow=nrow(newdata[[1]]),ncol=q,byrow=TRUE)}else{sigma.Y=matrix(1,nrow=nrow(newdata[[1]]),ncol=q)}
+ concat.newdata=newdata
+ names(concat.newdata)=names(X)
+
+
+ ### at this stage we have
+ # X # list of blocks
+ # Y # observation
+ # newdata #list of blocks for the prediction, same length as A, scaled
+
+ # replace missing data by 0
+ concat.newdata = lapply(concat.newdata,function(x)
+ {
+ ind = which(is.na(x))
+ if (length(ind) > 0)
+ x[ind] = 0
+ x
+ })
+
+ # replace missing data by 0
+ X = lapply(X,function(x)
+ {
+ ind = which(is.na(x))
+ if (length(ind) > 0)
+ x[ind] = 0
+ x
+ })
+
+ # -----------------------
+ # prediction
+ # -----------------------
+
+ B.hat = t.pred = Y.hat = list() #= betay
+ for (i in 1 : J)
+ {
+ Pmat = Cmat = Wmat = NULL
+
+ ### Start estimation using formula Y = XW(P'W)C (+ Yr, residuals on Y) See page 136 La regression PLS Theorie et pratique Tenenhaus
+ # Estimation matrix W, P and C
+ Pmat = crossprod(X[[i]], variatesX[[i]])
+ Cmat = crossprod(Y, variatesX[[i]])
+ Wmat = loadingsX[[i]]
+
+ # Prediction Y.hat, B.hat and t.pred
+ Ypred = lapply(1 : ncomp[i], function(x){concat.newdata[[i]] %*% Wmat[, 1:x] %*% solve(t(Pmat[, 1:x]) %*% Wmat[, 1:x]) %*% t(Cmat)[1:x, ]})
+ Ypred = sapply(Ypred, function(x){x*sigma.Y + means.Y}, simplify = "array")
+
+ Y.hat[[i]] = Ypred
+
+ t.pred[[i]] = concat.newdata[[i]] %*% Wmat %*% solve(t(Pmat) %*% Wmat)
+ t.pred[[i]] = matrix(data = sapply(1:ncol(t.pred[[i]]),
+ function(x) {t.pred[[i]][, x] * apply(variatesX[[i]], 2,
+ function(y){(norm(y, type = "2"))^2})[x]}), nrow = nrow(concat.newdata[[i]]), ncol = ncol(t.pred[[i]]))
+
+ B.hat[[i]] = sapply(1 : ncomp[i], function(x){Wmat[, 1:x] %*% solve(t(Pmat[, 1:x]) %*% Wmat[, 1:x]) %*% t(Cmat)[1:x, ]}, simplify = "array")
+ ### End estimation using formula Y = XW(P'W)C (+ Yr, residuals on Y) See page 136 La regression PLS Theorie et pratique Tenenhaus
+
+ rownames(t.pred[[i]]) = rownames(newdata[[i]])
+ colnames(t.pred[[i]]) = paste("dim", c(1:ncomp[i]), sep = " ")
+ rownames(Y.hat[[i]]) = rownames(newdata[[i]])
+ colnames(Y.hat[[i]]) = colnames(Y)
+ dimnames(Y.hat[[i]])[[3]]=paste("dim", c(1:ncomp[i]), sep = " ")
+ rownames(B.hat[[i]]) = colnames(newdata[[i]])
+ colnames(B.hat[[i]]) = colnames(Y)
+ dimnames(B.hat[[i]])[[3]]=paste("dim", c(1:ncomp[i]), sep = " ")
+
+ }
+
+
+ #-- valeurs sortantes --#
+ names(Y.hat)=names(t.pred)=names(B.hat)=names(object$X)
+
+
+
+ # basic prediction results
+ if(length(grep("block",class(object)))!=0 & length(object$X)>1 )
+ {
+ out=list(predict=Y.hat[which(!is.na(ind.match))],variates=t.pred[which(!is.na(ind.match))],B.hat=B.hat[which(!is.na(ind.match))])
+
+ # average prediction over the blocks
+ temp.all =list()
+ for(comp in 1:min(ncomp[-object$indY])) #note: all ncomp are the same in v6 as the input parameter is a single value
+ {
+ temp = array(0, c(nrow(Y.hat[[1]]), ncol(Y.hat[[1]]), J), dimnames = list(rownames(newdata[[1]]), colnames(Y),names(object$X)))
+ for(i in 1 : J)
+ temp[, , i] = Y.hat[[i]][, , comp]
+
+ temp.all[[comp]] = temp
+ }
+ names(temp.all) = paste("dim", c(1:min(ncomp[-object$indY])), sep = " ")
+
+ out$AveragedPredict = array(unlist(lapply(temp.all, function(x){apply(x, c(1,2), mean)})), dim(Y.hat[[1]]), dimnames = list(rownames(newdata[[1]]), colnames(Y), paste("dim", c(1:min(ncomp[-object$indY])), sep = " ")))
+
+ out$WeightedPredict = array(unlist(lapply(temp.all, function(x){apply(x, c(1,2), function(z){
+ temp = aggregate(object$weights,list(z),sum)
+ ind = which(temp[,2]== max (temp[,2]))# if two max, then NA
+ if(length(ind) == 1)
+ {
+ res = temp[ind, 1]
+ } else {
+ res = NA
+ }
+ res
+ })})), dim(Y.hat[[1]]), dimnames = list(rownames(newdata[[1]]), colnames(Y), paste("dim", c(1:min(ncomp[-object$indY])), sep = " ")))
+
+
+ #out$newdata=concat.newdata
+ }else if(length(grep("block",class(object)))!=0){ # a block but can have only one block (so e.g. a pls done with a block.pls)
+ out=list(predict=Y.hat,variates=t.pred,B.hat=B.hat)
+
+ } else {# not a block (pls/spls/plsda/splsda/mint...)
+ out=list(predict=Y.hat[[1]],variates=t.pred[[1]],B.hat=B.hat[[1]])
+ }
+
+ # get the classification for each new sample if the object is a DA
+ if(any(class(object)=="DA")) # a DA analysis (mint).(block).(s)plsda
+ {
+
+ if(length(grep("block",class(object)))!=0 & length(object$X)>1 )
+ {
+
+ # predict class of AveragePredict, only with max.dist
+ out$AveragedPredict.class$max.dist = matrix(sapply(1:ncomp[1], ### List level
+ function(y){apply(out$AveragedPredict[, , y, drop = FALSE], 1, ### component level
+ function(z){
+ paste(levels(Y.factor)[which(z == max(z))], collapse = "/")
+ }) ### matrix level
+ }), nrow = nrow(newdata[[1]]), ncol = ncomp[1])
+
+
+ # predict class of WeightedPredict, only with max.dist
+ out$WeightedPredict.class$max.dist = matrix(sapply(1:ncomp[1], ### List level
+ function(y){apply(out$WeightedPredict[, , y, drop = FALSE], 1, ### component level
+ function(z){
+ paste(levels(Y.factor)[which(z == max(z))], collapse = "/")
+ }) ### matrix level
+ }), nrow = nrow(newdata[[1]]), ncol = ncomp[1])
+
+ rownames(out$AveragedPredict.class$max.dist) = rownames(out$WeightedPredict.class$max.dist) = rownames(newdata[[1]])
+ colnames(out$AveragedPredict.class$max.dist) = colnames(out$WeightedPredict.class$max.dist) = paste("dim", c(1:min(ncomp[-object$indY])), sep = " ")
+ }
+
+
+
+ # creating temporary 'blocks' outputs to pass into the internal_predict.DA function
+ out.temp=list(predict=Y.hat[which(!is.na(ind.match))],variates=t.pred[which(!is.na(ind.match))],B.hat=B.hat[which(!is.na(ind.match))])
+ out.temp$newdata=concat.newdata[which(!is.na(ind.match))]
+
+ # getting classification for each new sample
+ object.temp = object
+ object.temp$X = object.temp$X[which(!is.na(ind.match))]
+ object.temp$variates = object.temp$variates[c(which(!is.na(ind.match)),J+1)] #J+1 is Y
+ classif.DA=internal_predict.DA(object=object.temp, q=q, out=out.temp, dist=dist, weights = object$weights[which(!is.na(ind.match))])
+ out=c(out,classif.DA)
+
+ }
+
+ out$call = match.call()
+ class(out) = paste("predict")
+
+ out
+
+}
+
+logratio.transfo <- function (X, logratio = "none", offset = 0)
+{
+ if (logratio == "ILR") {
+ if (any(class(X) != "ilr")) {
+ X = ilr.transfo(X, offset = offset)
+ }
+ }
+ else if (logratio == "CLR") {
+ X = clr.transfo(X, offset = offset)
+ }
+ return(X)
+}
+
+internal_predict.DA = function(object, out, q, dist, weights)
+{
+
+ if (length(grep("plsda",class(object)))==0) # a DA analysis (mint).(block).(s)plsda
+ stop("'Object' is not from a Discriminant Analysis", call.=FALSE)
+
+ out.DA = list()
+ J = length(object$X) #at this stage we have a list of blocks
+ p = lapply(object$X, ncol)
+ t.pred = out$variates
+ Y.hat = out$predict
+ newdata = out$newdata #actually concat.newdata
+ variatesX = object$variates[-(J + 1)];
+ ncomp = object$ncomp
+
+ Y = object$Y
+ Y.prim = unmap(object$Y)
+ G = cls = list()
+ for (i in 1 : J)
+ {
+ G[[i]] = sapply(1:q, function(x) {apply(as.matrix(variatesX[[i]][Y.prim[, x] == 1,,drop=FALSE]), 2, mean)})
+ if (ncomp[i] == 1)
+ G[[i]] = t(t(G[[i]]))
+ else
+ G[[i]] = t(G[[i]])
+ colnames(G[[i]]) = paste("dim", c(1:ncomp[i]), sep = " ")
+
+ }
+ names(G)=names(object$X)
+
+ ### Start: Maximum distance
+ if (any(dist == "all") || any(dist == "max.dist"))
+ {
+ cls$max.dist = lapply(1:J, function(x){matrix(sapply(1:ncomp[x], ### List level
+ function(y){apply(Y.hat[[x]][, , y, drop = FALSE], 1, ### component level
+ function(z){
+ paste(levels(Y)[which(z == max(z))], collapse = "/")
+ }) ### matrix level
+ }), nrow = nrow(newdata[[x]]), ncol = ncomp[x])
+ })
+ cls$max.dist = lapply(1:J, function(x){colnames(cls$max.dist[[x]]) = paste(rep("comp", ncomp[x]), 1 : ncomp[[x]], sep = " ");
+ rownames(cls$max.dist[[x]]) = rownames(newdata[[x]]); return(cls$max.dist[[x]])})
+ names(cls$max.dist)=names(object$X)
+ }
+
+
+ ### Start: Centroids distance
+ if (any(dist == "all") || any(dist == "centroids.dist"))
+ {
+ cl = list()
+ centroids.fun = function(x, G, h, i) {
+ q = nrow(G[[i]])
+ x = matrix(x, nrow = q, ncol = h, byrow = TRUE)
+
+ if (h > 1) {
+ d = apply((x - G[[i]][, 1:h])^2, 1, sum)
+ }
+ else {
+ d = (x - G[[i]][, 1])^2
+ }
+ cl.id = paste(levels(Y)[which(d == min(d))], collapse = "/")
+ }
+
+ for (i in 1 : J)
+ {
+ cl[[i]] = matrix(nrow = nrow(newdata[[1]]), ncol = ncomp[i])
+
+ for (h in 1 : ncomp[[i]])
+ {
+ cl.id = apply(matrix(t.pred[[i]][, 1:h], ncol = h), 1, function(x) {centroids.fun(x = x, G = G, h = h, i = i)})
+ cl[[i]][, h] = cl.id
+ }
+ }
+
+ cls$centroids.dist = lapply(1:J, function(x){colnames(cl[[x]]) = paste(rep("comp", ncomp[x]), 1 : ncomp[[x]], sep = " ");
+ rownames(cl[[x]]) = rownames(newdata[[x]]); return(cl[[x]])})
+ names(cls$centroids.dist)=names(object$X)
+ }### End: Centroids distance
+
+
+ ### Start: Mahalanobis distance
+ if (any(dist == "all") || any(dist == "mahalanobis.dist"))
+ {
+ cl = list()
+ Sr.fun = function(x, G, Yprim, h, i) {
+ q = nrow(G[[i]])
+ Xe = Yprim %*% G[[i]][, 1:h]
+ #Xr = object$variates$X[, 1:h] - Xe
+ Xr = variatesX[[i]][, 1:h] - Xe
+ Sr = t(Xr) %*% Xr/nrow(Yprim)
+ Sr.inv = solve(Sr)
+ x = matrix(x, nrow = q, ncol = h, byrow = TRUE)
+ if (h > 1) {
+ mat = (x - G[[i]][, 1:h]) %*% Sr.inv %*% t(x - G[[i]][, 1:h])
+ d = apply(mat^2, 1, sum)
+ } else {
+ d = drop(Sr.inv) * (x - G[[i]][, 1])^2
+ }
+ cl.id = paste(levels(Y)[which(d == min(d))], collapse = "/")
+ }
+
+ for (i in 1 : J){
+ cl[[i]] = matrix(nrow = nrow(newdata[[1]]), ncol = ncomp[i])
+
+ for (h in 1:ncomp[[i]]) {
+ cl.id = apply(matrix(t.pred[[i]][, 1:h], ncol = h), 1, Sr.fun, G = G, Yprim = Y.prim, h = h, i = i)
+ cl[[i]][, h] = cl.id
+ }
+ }
+
+ cls$mahalanobis.dist = lapply(1:J, function(x){colnames(cl[[x]]) = paste(rep("comp", ncomp[x]), 1 : ncomp[[x]], sep = " ");
+ rownames(cl[[x]]) = rownames(newdata[[x]]);return(cl[[x]])})
+ names(cls$mahalanobis.dist)=names(object$X)
+ } ### End: Mahalanobis distance
+
+ out.DA$class = cls
+
+ ### End if discriminant analysis is performed
+
+ # at this stage, we have the classification of each sample for each dataset of object$X
+ # now we need to combine the classification by vote (majority wins), only when more than one block, otherwise 'vote' is classic classification
+ if (length(object$X)>1)
+ {
+ for (ijk in 1:length(out.DA$class))# loop on the dist
+ {
+ # create a temporary array to make computation on the lists easier
+ temp=array(c(nrow(newdata[[1]]), min(ncomp), J))
+ for(i in 1:J)
+ {
+ temp[, , i] = out.DA$class[[ijk]][[i]][, 1:min(ncomp)]
+
+ }
+ # look at the majority vote for all dataset of object$X (with table), if more than a unique max, we put NA
+ table.temp = apply(temp,c(1,2), function(x){a=table(x); if (length(which(a==max(a)))==1) {b=names(which.max(a))}else{b=NA}; b})
+ colnames(table.temp) = colnames(out.DA$class[[ijk]][[i]])[1:min(ncomp)]
+ rownames(table.temp) = rownames(out.DA$class[[ijk]][[i]])
+ out.DA$MajorityVote[[ijk]] = table.temp
+ }
+ names(out.DA$MajorityVote) = names(out.DA$class)
+
+ # weighted vote for each distance, each comp
+ if(!is.null(weights))
+ {
+ out.DA$WeightedVote = lapply(out.DA$class, function(x){ # x is a distance
+ class.per.comp = lapply(1:min(ncomp), function(y) {matrix(sapply(x, function(z) z[,y, drop = FALSE]),ncol=J)}) # combine the results per component
+ names(class.per.comp) = paste0("comp",1:min(ncomp))
+ class.per.comp = lapply(class.per.comp, function(y){rownames(y) = rownames(out.DA$vote[[1]]); y})
+ class.weighted.per.comp = sapply(class.per.comp, function(y){ # for each component
+ apply(y,1,function(z){ # we aggregate the results of each individuals using the 'weights'
+ temp = aggregate(weights,list(z),sum)
+ ind = which(temp[,2]== max (temp[,2]))# if two max, then NA
+ if(length(ind) == 1)
+ {
+ res = temp[ind, 1]
+ } else {
+ res = NA
+ }
+ res
+
+ })
+ })
+
+ })
+ out.DA$weights = weights
+
+ }
+ }else{
+ out.DA$MajorityVote = lapply(out.DA$class,function(x){x[[1]]})
+ }
+
+ if (length(grep("block",class(object)))!=0 & J>1) # a block
+ {
+ out.DA$centroids = G
+ }else{ #not a block
+ out.DA$centroids = G[[1]]
+ out.DA$class = out.DA$MajorityVote
+ }
+ if (any(dist == "all"))
+ dist = "all"
+
+ out.DA$dist = dist
+
+ out.DA
+
+}
+
+Check.entry.pls = function(X, Y, ncomp, keepX, keepY, keepX.constraint, keepY.constraint, mode, scale,
+ near.zero.var, max.iter, tol, logratio, DA, multilevel)
+{
+
+ if (missing(mode))
+ mode = "regression"
+
+ if (length(mode)>1)
+ mode = mode[1]
+
+ if (!(mode %in% c("canonical", "invariant", "classic", "regression")))
+ stop("Choose one of the four following modes: canonical, invariant, classic or regression")
+
+
+ #-- validation des arguments --#
+ if (length(dim(X)) != 2)
+ stop("'X' must be a numeric matrix.")
+
+ X = as.matrix(X)
+
+ if (!(logratio %in% c("none", "CLR")))
+ stop("Choose one of the two following logratio transformation: none or CLR")
+
+ if(!is.null(multilevel))
+ {
+ #multilevel analysis: withinVariation and then pls-like
+ # if it's DA analysis, Y and 'multilevel' are combined
+ if(DA)
+ {
+ Y = multilevel
+ }else{
+ if ((nrow(X) != nrow(multilevel)))
+ stop("unequal number of rows in 'X' and 'multilevel'.")
+
+ Y = as.matrix(Y)
+ if (!is.numeric(X) || !is.numeric(Y))
+ stop("'X' and/or 'Y' must be a numeric matrix.")
+ }
+ }else{
+ Y = as.matrix(Y)
+ if (!is.numeric(X) || !is.numeric(Y))
+ stop("'X' and/or 'Y' must be a numeric matrix.")
+ }
+ N = nrow(X)
+ Q = ncol(Y)
+ P= ncol(X)
+
+ if ((N != nrow(Y)))
+ stop("Unequal number of rows in 'X' and 'Y'.")
+
+ if (is.null(ncomp) || !is.numeric(ncomp) || ncomp <= 0 || length(ncomp)>1)
+ stop("invalid number of variates, 'ncomp'.")
+
+ ncomp = round(ncomp)
+ if(ncomp > P)
+ {
+ warning("Reset maximum number of variates 'ncomp' to ncol(X) = ", P, ".")
+ ncomp = P
+ }
+
+ if (!is.numeric(tol) | tol<=0)
+ stop("tol must be non negative")
+
+ if (!is.numeric(max.iter) | max.iter<=0)
+ stop("max.iter must be non negative")
+
+
+ # add colnames and rownames if missing
+ X.names = dimnames(X)[[2]]
+ if (is.null(X.names))
+ {
+ X.names = paste("X", 1:P, sep = "")
+ dimnames(X)[[2]] = X.names
+ }
+
+
+
+ ind.names = dimnames(X)[[1]]
+ if (is.null(ind.names))
+ {
+ ind.names = dimnames(Y)[[1]]
+ rownames(X) = ind.names
+ }
+
+ if (is.null(ind.names))
+ {
+ ind.names = 1:N
+ rownames(X) = rownames(Y) = ind.names
+ }
+
+ rownames(X) = rownames(Y) = ind.names
+
+
+ #if (dim(Y)[2] == 1) Y.names = "Y"
+ Y.names = dimnames(Y)[[2]]
+ if (is.null(Y.names))
+ {
+ if (dim(Y)[2] == 1)
+ {
+ Y.names = "Y"
+ } else {
+ Y.names = paste("Y", 1:Q, sep = "")
+ }
+
+ dimnames(Y)[[2]]=Y.names
+ }
+
+ if (length(unique(X.names)) != P)
+ stop("Unique indentifier is needed for the columns of X")
+
+ if (length(unique(Y.names)) != Q)
+ stop("Unique indentifier is needed for the columns of Y")
+
+
+ # check on keepX and keepX.constraint
+ if (missing(keepX.constraint))
+ {
+ if (missing(keepX))
+ {
+ keepX = rep(P, ncomp)
+ } else {
+ if (length(keepX)<ncomp)
+ keepX = c(keepX, rep(P, ncomp - length(keepX))) #complete (with ncomp) the keepX already provided
+ }
+ keepX.constraint=list()
+ } else {
+ if (length(keepX.constraint)>ncomp)
+ stop(paste0("You should have length(keepX.constraint) lower or equal to 'ncomp' = ", ncomp, "."))
+
+ if (missing(keepX))
+ {
+ keepX = rep(P, ncomp - length(keepX.constraint))
+ } else {
+
+ if ((length(keepX.constraint) + length(keepX)) < ncomp)
+ keepX = c(keepX, rep(P, ncomp - length(keepX) - length(keepX.constraint)))
+
+ if ((length(keepX.constraint) + length(keepX)) > ncomp)
+ stop(paste0("length (keepX.constraint) + length(keepX) should be lower than 'ncomp' = ", ncomp, "."))
+
+ }
+ }
+
+ # check on keepY and keepY.constraint
+ if (missing(keepY.constraint))
+ {
+ if (missing(keepY))
+ {
+ keepY = rep(Q, ncomp)
+ } else {
+ if (length(keepY) < ncomp)
+ keepY = c(keepY, rep(Q, ncomp - length(keepY))) #complete the keepY already provided
+ }
+ keepY.constraint = list()
+ } else {
+ if (length(keepY.constraint)>ncomp)
+ stop(paste0("you should have length(keepY.constraint) lower or equal to 'ncomp' = ", ncomp, "."))
+
+ if (missing(keepY))
+ {
+ keepY = rep(Q, ncomp - length(keepY.constraint))
+ } else {
+
+ if ((length(keepY.constraint) + length(keepY)) < ncomp)
+ keepY = c(keepY, rep(Q, ncomp - length(keepY) - length(keepY.constraint)))
+
+ if ((length(keepY.constraint) + length(keepY)) > ncomp)
+ stop(paste0("length (keepY.constraint) + length(keepY) should be lower than 'ncomp' = ", ncomp,"."))
+ }
+ }
+
+
+
+ if (any(keepX<0))
+ stop("each component of 'keepX' must be non negative ")
+ if (any(keepY<0))
+ stop("each component of 'keepY' must be non negative ")
+
+ if (any(keepX > ncol(X)))
+ stop("each component of 'keepX' must be lower or equal than ", P, ".")
+ if (any(keepY > ncol(Y)))
+ stop("each component of 'keepY' must be lower or equal than ", Q, ".")
+
+ if (is.numeric(unlist(keepX.constraint)) && any(unlist(keepX.constraint) > ncol(X)))
+ stop("each entry of 'keepX.constraint' must be lower or equal than ", P, ".")
+ if ( is.numeric(unlist(keepY.constraint)) && any(unlist(keepY.constraint) > ncol(Y)))
+ stop("each entry of 'keepY.constraint' must be lower or equal than ", Q, ".")
+
+ if (!is.logical(scale))
+ stop("'scale' must be either TRUE or FALSE")
+
+ if (!is.logical(near.zero.var))
+ stop("'near.zero.var' must be either TRUE or FALSE")
+
+ # match keepX.constraint and the colnames of X in order for keepX.constraint to be a list of character
+ # safety if keepX.constraint contains a mixed of character/numeric. It should one or the other, not a mix
+ if (length(keepX.constraint) > 0)
+ {
+ if (!is.numeric(unlist(keepX.constraint)))
+ {
+ ind = match(unlist(keepX.constraint), colnames(X))
+ if (sum(is.na(ind)) > 0)
+ stop("'keepX.constraint' must contain a subset of colnames(X) or the position of the X-variables you wish to keep.")
+ }
+ X.indice = X[, unlist(keepX.constraint), drop=FALSE]
+ keepX.constraint = relist(colnames(X.indice), skeleton=keepX.constraint)
+ }
+
+ # same for keepY.constraint
+ if (length(keepY.constraint) > 0)
+ {
+ if (!is.numeric(unlist(keepY.constraint)))
+ {
+ ind = match(unlist(keepY.constraint),colnames(Y))
+ if (sum(is.na(ind)) > 0)
+ stop("'keepY.constraint' must contain a subset of colnames(Y) or the position of the Y-variables you wish to keep.")
+ }
+ Y.indice = Y[, unlist(keepY.constraint), drop=FALSE]
+ keepY.constraint = relist(colnames(Y.indice), skeleton=keepY.constraint)
+ }
+
+
+ # at this stage keepA.constraint needs to be character, to easily remove variables with near zero variance
+ ### near.zero.var, remove the variables with very small variances
+ if (near.zero.var == TRUE)
+ {
+ nzv.A = nearZeroVar(X)
+
+ if (length(nzv.A$Position) > 0)
+ {
+ names.remove.X = colnames(X)[nzv.A$Position]
+ X = X[, -nzv.A$Position, drop=FALSE]
+ warning("Zero- or near-zero variance predictors.\n Reset predictors matrix to not near-zero variance predictors.\n See $nzv for problematic predictors.")
+ if (ncol(X) == 0)
+ stop("No more variables in X")
+
+ # at this stage, keepA.constraint needs to be numbers
+ if (length(keepX.constraint) > 0)
+ {
+ #remove the variables from keepA.constraint if removed by near.zero.var
+ keepX.constraint = match.keepX.constraint(names.remove.X, keepX.constraint)
+ }
+ #need to check that the keepA[[q]] is now not higher than ncol(A[[q]])
+ if (any(keepX > ncol(X)))
+ {
+ ind = which(keepX > ncol(X))
+ keepX[ind] = ncol(X)
+ }
+ }
+
+ }else{nzv.A=NULL}
+
+ # we need numbers in keepX.constraint from now on
+ keepX.constraint = lapply(keepX.constraint,function(x){match(x, colnames(X))})
+ keepY.constraint = lapply(keepY.constraint,function(x){match(x, colnames(Y))})
+
+ return(list(X=X, Y=Y, ncomp=ncomp, X.names=X.names, Y.names=Y.names, ind.names=ind.names, mode=mode, keepX.constraint=keepX.constraint,
+ keepY.constraint=keepY.constraint, keepX=keepX, keepY=keepY, nzv.A=nzv.A))
+}
+
+#'sPLS-DA Map
+#'@description map variable for (s)plsda
+#'@param Y Input data
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+map = function (Y)
+{
+ nrowY = nrow(Y)
+ cl = numeric(nrowY)
+ I = 1:nrowY
+ J = 1:ncol(Y)
+ for (i in I)
+ {
+ cl[i] = (J[Y[i, ] == max(Y[i, ])])[1]
+ }
+ return(cl)
+}
+
+unmap = function (classification, groups = NULL, noise = NULL)
+{
+ n = length(classification)
+ u = sort(unique(classification))
+ levels = levels(classification)### Add levels
+
+ if (is.null(groups))
+ {
+ groups = u
+ } else {
+ if (any(match(u, groups, nomatch = 0) == 0))
+ stop("groups incompatible with classification")
+ miss = match(groups, u, nomatch = 0) == 0
+ }
+
+ cgroups = as.character(groups)
+ if (!is.null(noise))
+ {
+ noiz = match(noise, groups, nomatch = 0)
+ if (any(noiz == 0))
+ stop("noise incompatible with classification")
+
+ groups = c(groups[groups != noise], groups[groups == noise])
+ noise = as.numeric(factor(as.character(noise), levels = unique(groups)))
+ }
+
+ groups = as.numeric(factor(cgroups, levels = unique(cgroups)))
+ classification = as.numeric(factor(as.character(classification), levels = unique(cgroups)))
+ k = length(groups) - length(noise)
+ nam = levels(groups)
+
+ if (!is.null(noise))
+ {
+ k = k + 1
+ nam = nam[1:k]
+ nam[k] = "noise"
+ }
+
+ z = matrix(0, n, k, dimnames = c(names(classification), nam))
+ for (j in 1:k) z[classification == groups[j], j] = 1
+ attr(z, "levels") = levels
+ z
+}
+
+
+
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/stats_univariates.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/stats_univariates.R
new file mode 100755
index 0000000000000000000000000000000000000000..5397303e1008e02e04c51858616e4411aabe7c13
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/stats_univariates.R
@@ -0,0 +1,1523 @@
+#'Fold change analysis, unpaired
+#'@description Perform fold change analysis, method can be mean or median
+#'@usage FC.Anal(mSetObj, fc.thresh=2, cmp.type = 0)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param fc.thresh Fold-change threshold, numeric input
+#'@param cmp.type Comparison type, 0 for group 1 minus group 2, and 1 for group
+#'1 minus group 2
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+FC.Anal <- function(mSetObj=NA, fc.thresh=2, cmp.type = 0, paired=FALSE){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # make sure threshold is above 1
+ fc.thresh = ifelse(fc.thresh>1, fc.thresh, 1/fc.thresh);
+ max.thresh = fc.thresh;
+ min.thresh = 1/fc.thresh;
+
+ res <- GetFC(mSetObj, paired, cmp.type);
+ fc.all <- res$fc.all;
+ fc.log <- res$fc.log;
+
+ inx.up <- fc.all > max.thresh;
+ inx.down <- fc.all < min.thresh;
+ names(inx.up) <- names(inx.down) <- names(fc.all);
+ imp.inx <- inx.up | inx.down;
+ sig.mat <- cbind(fc.all[imp.inx, drop=F], fc.log[imp.inx, drop=F]);
+ colnames(sig.mat) <- c("Fold Change", "log2(FC)");
+
+ # order by absolute log value (since symmetrical in pos and neg)
+ inx.ord <- order(abs(sig.mat[,2]), decreasing=T);
+ sig.mat <- sig.mat[inx.ord,,drop=F];
+
+ fileName <- "fold_change.csv";
+ fast.write.csv(sig.mat,file=fileName);
+
+ # create a list object to store fc
+ mSetObj$analSet$fc<-list (
+ paired = FALSE,
+ raw.thresh = fc.thresh,
+ max.thresh = max.thresh,
+ min.thresh = min.thresh,
+ fc.all = fc.all, # note a vector
+ fc.log = fc.log,
+ inx.up = inx.up,
+ inx.down = inx.down,
+ inx.imp = imp.inx,
+ sig.mat = sig.mat
+ );
+ return(.set.mSet(mSetObj));
+}
+
+
+#'Plot fold change
+#'@description Plot fold change analysis
+#'@usage PlotFC(mSetObj=NA, imgName, format="png", dpi=72, width=NA)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotFC <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- 8;
+ }else if(width == 0){
+ w <- 7;
+ }else{
+ w <- width;
+ }
+ h <- w*6/8;
+
+ mSetObj$imgSet$fc <- imgName;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+
+ par(mar=c(5,5,2,3));
+
+ fc = mSetObj$analSet$fc;
+ if(fc$paired){
+ ylim <- c(-nrow(mSetObj$dataSet$norm)/2, nrow(mSetObj$dataSet$norm)/2);
+ xlim <- c(0, ncol(mSetObj$dataSet$norm));
+ plot(NULL, xlim=xlim, ylim=ylim, xlab = GetVariableLabel(mSetObj$dataSet$type),
+ ylab=paste("Count with FC >=", fc$max.thresh, "or <=", fc$min.thresh));
+ for(i in 1:ncol(fc$fc.all)){
+ segments(i,0, i, fc$fc.all[1,i], col= ifelse(fc$inx.up[i],"magenta", "darkgrey"),
+ lwd= ifelse(fc$inx.up[i], 2, 1));
+ segments(i,0, i, -fc$fc.all[2,i], col= ifelse(fc$inx.down[i], "magenta", "darkgrey"),
+ lwd= ifelse(fc$inx.down[i], 2, 1));
+ }
+ abline(h=fc$max.thresh, lty=3);
+ abline(h=fc$min.thresh, lty=3);
+ abline(h=0, lwd=1);
+ }else{
+ if(fc$raw.thresh > 0){
+ # be symmetrical
+ topVal <- max(abs(fc$fc.log));
+ ylim <- c(-topVal, topVal);
+ plot(fc$fc.log, ylab="Log2 (FC)", ylim = ylim, xlab = GetVariableLabel(mSetObj$dataSet$type), pch=19, axes=F,
+ col= ifelse(fc$inx.imp, "magenta", "darkgrey"));
+ axis(2);
+ axis(4); # added by Beomsoo
+ abline(h=log2(fc$max.thresh), lty=3);
+ abline(h=log2(fc$min.thresh), lty=3);
+ abline(h=0, lwd=1);
+ }else{ # plot side by side
+
+ dat1 <- mSetObj$dataSet$norm[as.numeric(mSetObj$dataSet$cls) == 1, ];
+ dat2 <- mSetObj$dataSet$norm[as.numeric(mSetObj$dataSet$cls) == 2, ];
+
+ mns1 <- apply(dat1, 2, mean);
+ mn1 <- mean(mns1);
+ sd1 <- sd(mns1);
+ msd1.top <- mn1 + 2*sd1;
+ msd1.low <- mn1 - 2*sd1;
+
+ mns2 <- apply(dat2, 2, mean);
+ mn2 <- mean(mns2);
+ sd2 <- sd(mns2);
+ msd2.top <- mn2 + 2*sd2;
+ msd2.low <- mn2 - 2*sd2;
+
+ ylims <- range(c(mns1, mns2, msd1.top, msd2.top, msd1.low, msd2.low));
+ new.mns <- c(mns1, rep(NA, 5), mns2);
+ cols <- c(rep("magenta", length(mns1)), rep(NA, 5), rep("blue", length(mns2)));
+ pchs <- c(rep(15, length(mns1)), rep(NA, 5), rep(19, length(mns2)));
+ plot(new.mns, ylim=ylims, pch = pchs, col = cols, cex = 1.25, axes=F, ylab="");
+ axis(2);
+ axis(4); # added by Beomsoo
+ abline(h=mn1, col="magenta", lty=3, lwd=2);
+ abline(h=msd1.low, col="magenta", lty=3, lwd=1);
+ abline(h=msd1.top, col="magenta", lty=3, lwd=1);
+ abline(h=mn2, col="blue", lty=3, lwd=2);
+ abline(h=msd2.low, col="blue", lty=3, lwd=1);
+ abline(h=msd2.top, col="blue", lty=3, lwd=1);
+ # abline(h=mean(all.mns), col="darkgrey", lty=3);
+ axis(1, at=1:length(new.mns), labels=c(1:length(mns1),rep(NA, 5),1:length(mns2)));
+ }
+ }
+ dev.off();
+
+ return(.set.mSet(mSetObj));
+}
+
+#'Used by higher functions to calculate fold change
+#'@description Utility method to calculate FC, used in higher function
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param paired Logical, true of false
+#'@param cmpType Numeric, 0 or 1
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+GetFC <- function(mSetObj=NA, paired=FALSE, cmpType){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(paired){
+ # compute the average of paired FC (unit is pair)
+ if(mSetObj$dataSet$combined.method){
+ data <- mSetObj$dataSet$norm;
+ }else{
+ row.norm <- qs::qread("row_norm.qs");
+ data <- log2(row.norm);
+ }
+
+ G1 <- data[which(mSetObj$dataSet$cls==levels(mSetObj$dataSet$cls)[1]), ]
+ G2 <- data[which(mSetObj$dataSet$cls==levels(mSetObj$dataSet$cls)[2]), ]
+
+ if(cmpType == 0){
+ fc.mat <- G1-G2;
+ }else{
+ fc.mat <- G2-G1;
+ }
+ fc.log <- apply(fc.mat, 2, mean);
+ fc.all <- signif(2^fc.log, 5);
+ }else{
+ # compute the FC of two group means (unit is group)
+ data <- NULL;
+ if(mSetObj$dataSet$combined.method){
+ data <- mSetObj$dataSet$norm;
+ m1 <- colMeans(data[which(mSetObj$dataSet$cls==levels(mSetObj$dataSet$cls)[1]), ]);
+ m2 <- colMeans(data[which(mSetObj$dataSet$cls==levels(mSetObj$dataSet$cls)[2]), ]);
+
+ # create a named matrix of sig vars for display
+ if(cmpType == 0){
+ fc.log <- signif (m1-m2, 5);
+ }else{
+ fc.log <- signif (m2-m1, 5);
+ }
+ fc.all <- signif(2^fc.log, 5);
+ }else{
+ data <- qs::qread("row_norm.qs");
+ m1 <- colMeans(data[which(mSetObj$dataSet$cls==levels(mSetObj$dataSet$cls)[1]), ]);
+ m2 <- colMeans(data[which(mSetObj$dataSet$cls==levels(mSetObj$dataSet$cls)[2]), ]);
+
+ # create a named matrix of sig vars for display
+ if(cmpType == 0){
+ ratio <- m1/m2;
+ }else{
+ ratio <- m2/m1;
+ }
+ fc.all <- signif(ratio, 5);
+ fc.log <- signif(log2(ratio), 5);
+ }
+ }
+ names(fc.all) <- names(fc.log) <- colnames(data);
+ return(list(fc.all = fc.all, fc.log = fc.log));
+}
+
+#'Perform t-test analysis
+#'@description This function is used to perform t-test analysis.
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param nonpar Logical, use a non-parametric test, T or F. False is default.
+#'@param threshp Numeric, enter the adjusted p-value (FDR) cutoff
+#'@param paired Logical, is data paired (T) or not (F).
+#'@param equal.var Logical, evaluates if the group variance is equal (T) or not (F).
+#'@param all_results Logical, if TRUE, returns T-Test analysis results
+#'for all compounds.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+Ttests.Anal <- function(mSetObj=NA, nonpar=F, threshp=0.05, paired=FALSE, equal.var=TRUE, pvalType="fdr", all_results=FALSE){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(.on.public.web & !nonpar & RequireFastUnivTests(mSetObj)){
+ res <- PerformFastUnivTests(mSetObj$dataSet$norm, mSetObj$dataSet$cls, var.equal=equal.var);
+ }else{
+ res <- GetTtestRes(mSetObj, paired, equal.var, nonpar);
+ }
+ t.stat <- res[,1];
+ p.value <- res[,2];
+ names(t.stat) <- names(p.value) <- colnames(mSetObj$dataSet$norm);
+
+ p.log <- -log10(p.value);
+ fdr.p <- p.adjust(p.value, "fdr");
+
+ if(all_results==TRUE){
+
+ all.mat <- data.frame(signif(t.stat,5), signif(p.value,5), signif(p.log,5), signif(fdr.p,5));
+
+ if(nonpar){
+ tt.nm = "Wilcoxon Rank Test";
+ file.nm <- "wilcox_rank_all.csv"
+ colnames(all.mat) <- c("V", "p.value", "-log10(p)", "FDR");
+ }else{
+ tt.nm = "T-Tests";
+ file.nm <- "t_test_all.csv";
+ colnames(all.mat) <- c("t.stat", "p.value", "-log10(p)", "FDR");
+ }
+ fast.write.csv(all.mat, file=file.nm);
+ }
+
+ if(pvalType=="fdr"){
+ inx.imp <- fdr.p <= threshp;
+ }else{
+ inx.imp <- p.value <= threshp;
+ }
+
+ sig.num <- sum(inx.imp);
+ AddMsg(paste("A total of", sig.num, "significant features were found."));
+
+ if(sig.num > 0){
+ sig.t <- t.stat[inx.imp];
+ sig.p <- p.value[inx.imp];
+ lod<- -log10(sig.p);
+ sig.q <-fdr.p[inx.imp];
+
+ sig.mat <- cbind(sig.t, sig.p, lod, sig.q);
+ colnames(sig.mat) <- c("t.stat", "p.value", "-log10(p)", "FDR");
+ ord.inx <- order(sig.p);
+ sig.mat <- sig.mat[ord.inx,,drop=F];
+ sig.mat <- signif(sig.mat, 5);
+
+ if(nonpar){
+ tt.nm = "Wilcoxon Rank Test";
+ file.nm <- "wilcox_rank.csv"
+ colnames(sig.mat) <- c("V", "p.value", "-log10(p)", "FDR");
+ }else{
+ tt.nm = "T-Tests";
+ file.nm <- "t_test.csv";
+ colnames(sig.mat) <- c("t.stat", "p.value", "-log10(p)", "FDR");
+ }
+ fast.write.csv(sig.mat, file=file.nm);
+
+ tt <- list (
+ tt.nm = tt.nm,
+ sig.nm = file.nm,
+ sig.num = sig.num,
+ paired = paired,
+ raw.thresh = threshp,
+ t.score = t.stat,
+ p.value = p.value,
+ p.log = p.log,
+ thresh = -log10(threshp), # only used for plot threshold line
+ inx.imp = inx.imp,
+ sig.mat = sig.mat
+ );
+ }else{
+ tt <- list (
+ sig.num = sig.num,
+ paired = paired,
+ raw.thresh = threshp,
+ t.score = t.stat,
+ p.value = p.value,
+ p.log = p.log,
+ thresh = -log10(threshp), # only used for plot threshold line
+ inx.imp = inx.imp
+ );
+ }
+
+ mSetObj$analSet$tt <- tt;
+
+ if(.on.public.web){
+ .set.mSet(mSetObj);
+ return(as.numeric(sig.num));
+ }
+ return(.set.mSet(mSetObj));
+}
+
+#'Plot t-test
+#'@description Plot t-test
+#'@usage PlotTT(mSetObj=NA, imgName, format="png", dpi=72, width=NA)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotTT <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- 8;
+ }else if(width == 0){
+ w <- 7;
+ }else{
+ w <- width;
+ }
+ h <- w*6/8;
+
+ mSetObj$imgSet$tt <- imgName;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ plot(mSetObj$analSet$tt$p.log, ylab="-log10(p)", xlab=GetVariableLabel(mSetObj$dataSet$type), main=mSetObj$analSet$tt$tt.nm, pch=19,
+ col= ifelse(mSetObj$analSet$tt$inx.imp, "magenta", "darkgrey"));
+ abline(h=mSetObj$analSet$tt$thresh, lty=3);
+ axis(4);
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+#'Perform Volcano Analysis
+#'@description Perform volcano analysis
+#'@usage Volcano.Anal(mSetObj=NA, paired=FALSE, fcthresh, cmpType, nonpar=F, threshp, equal.var=TRUE, pval.type="raw")
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param paired Logical, T if data is paired, F if data is not.
+#'@param fcthresh Numeric, input the fold change threshold
+#'@param cmpType Comparison type, 0 indicates group 1 vs group 2, and 1 indicates group 2 vs group 1
+#'@param percent.thresh Only for paired data, numeric, indicate the significant count threshold
+#'@param nonpar Logical, indicate if a non-parametric test should be used (T or F)
+#'@param threshp Numeric, indicate the p-value threshold
+#'@param equal.var Logical, indicates if the group variance is equal (T) or unequal (F)
+#'@param pval.type To indicate raw p-values, use "raw". To indicate FDR-adjusted p-values, use "fdr".
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+Volcano.Anal <- function(mSetObj=NA, paired=FALSE, fcthresh, cmpType, nonpar=F, threshp, equal.var=TRUE, pval.type="raw"){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # Note, volcano is based on t-tests and fold change analysis
+ #### t-tests and p values
+ if(is.null(mSetObj$analSet$tt) || mSetObj$analSet$tt$paired != paired){
+ mSetObj <- Ttests.Anal(mSetObj, nonpar, threshp, paired, equal.var, pval.type);
+ mSetObj <- .get.mSet(mSetObj);
+ }else{
+ if(mSetObj$analSet$tt$raw.thresh != threshp){
+ mSetObj <- Ttests.Anal(mSetObj, nonpar, threshp, paired, equal.var, pval.type);
+ mSetObj <- .get.mSet(mSetObj);
+ }
+ }
+
+ p.value <- mSetObj$analSet$tt$p.value;
+
+ if(pval.type == "fdr"){
+ p.value <- p.adjust(p.value, "fdr");
+ }
+
+ inx.p <- p.value <= threshp;
+ p.log <- -log10(p.value);
+
+ print("p")
+ print(threshp)
+ #### fc analysis
+ if(is.null(mSetObj$analSet$fc) || mSetObj$analSet$fc$paired != paired){
+ mSetObj <- FC.Anal(mSetObj, fcthresh, cmpType, paired);
+ mSetObj <- .get.mSet(mSetObj);
+ }else{ # check if FC is different
+ if(mSetObj$analSet$fc$raw.thresh != fcthresh){
+ mSetObj <- FC.Anal(mSetObj, fcthresh, cmpType, paired);
+ mSetObj <- .get.mSet(mSetObj);
+ }
+ }
+
+ fcthresh = ifelse(fcthresh>1, fcthresh, 1/fcthresh);
+ max.xthresh <- log2(fcthresh);
+ min.xthresh <- log2(1/fcthresh);
+
+ print("fc")
+ print(max.xthresh)
+ print(min.xthresh)
+
+ fc.log <- mSetObj$analSet$fc$fc.log;
+ fc.all <- mSetObj$analSet$fc$fc.all;
+
+ inx.up <- mSetObj$analSet$fc$inx.up;
+ inx.down <- mSetObj$analSet$fc$inx.down;
+
+ # create named sig table for display
+ inx.imp <- (inx.up | inx.down) & inx.p;
+ sig.var <- cbind(fc.all[inx.imp,drop=F], fc.log[inx.imp,drop=F], p.value[inx.imp,drop=F], p.log[inx.imp,drop=F]);
+
+ if(pval.type == "fdr"){
+ colnames(sig.var) <- c("FC", "log2(FC)", "p.ajusted", "-log10(p)");
+ }else{
+ colnames(sig.var) <- c("FC", "log2(FC)", "raw.pval", "-log10(p)");
+ }
+
+ # first order by log(p), then by log(FC)
+ ord.inx <- order(sig.var[,4], abs(sig.var[,2]), decreasing=T);
+ sig.var <- sig.var[ord.inx,,drop=F];
+ sig.var <- signif(sig.var,5);
+
+ fileName <- "volcano.csv";
+ fast.write.csv(signif(sig.var,5), file=fileName);
+
+ volcano <- list (
+ raw.threshx = fcthresh,
+ raw.threshy = threshp,
+ paired = paired,
+ max.xthresh = max.xthresh,
+ min.xthresh = min.xthresh,
+ thresh.y = -log10(threshp),
+ fc.all = fc.all,
+ fc.log = fc.log,
+ inx.up = inx.up,
+ inx.down = inx.down,
+ p.log = p.log,
+ inx.p = inx.p,
+ sig.mat = sig.var
+ );
+
+ mSetObj$analSet$volcano <- volcano;
+ return(.set.mSet(mSetObj));
+}
+
+#'Create volcano plot
+#'@description For labelling interesting points, it is defined by the following rules:
+#'need to be signficant (sig.inx) and or 2. top 5 p, or 2. top 5 left, or 3. top 5 right.
+#'@usage PlotVolcano(mSetObj=NA, imgName, plotLbl, format="png", dpi=72, width=NA)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param imgName Input a name for the plot
+#'@param plotLbl Logical, plot labels, 1 for yes and 0 for no.
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotVolcano <- function(mSetObj=NA, imgName, plotLbl, format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+
+ if(is.na(width)){
+ w <- 10;
+ }else if(width == 0){
+ w <- 8;
+ }else{
+ w <- width;
+ }
+ h <- w*6/10;
+
+ mSetObj$imgSet$volcano <- imgName;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ par(mar=c(5,5,3,4));
+ vcn <- mSetObj$analSet$volcano;
+ MyGray <- rgb(t(col2rgb("black")), alpha=40, maxColorValue=255);
+ MyHighlight <- rgb(t(col2rgb("magenta")), alpha=80, maxColorValue=255);
+
+
+ imp.inx<-(vcn$inx.up | vcn$inx.down) & vcn$inx.p;
+ plot(vcn$fc.log, vcn$p.log, pch=20, cex=ifelse(imp.inx, 1.2, 0.7),
+ col = ifelse(imp.inx, MyHighlight, MyGray),
+ xlab="log2 (FC)", ylab="-log10(p)");
+
+ sig.inx <- imp.inx;
+ p.topInx <- GetTopInx(vcn$p.log, 5, T) & (vcn$inx.down);
+ fc.leftInx <- GetTopInx(vcn$fc.log, 5, F);
+ lblInx <- sig.inx & (p.topInx | fc.leftInx);
+ if(plotLbl & sum(lblInx, na.rm=T) > 0){
+ text.lbls<-substr(colnames(mSetObj$dataSet$norm)[lblInx],1,14) # some names may be too long
+ text(vcn$fc.log[lblInx], vcn$p.log[lblInx],labels=text.lbls, pos=2, col="blue", srt=-30, xpd=T, cex=0.8);
+ }
+
+ p.topInx <- GetTopInx(vcn$p.log, 5, T) & (vcn$inx.up);
+ fc.rtInx <- GetTopInx(vcn$fc.log, 5, T);
+ lblInx <- sig.inx & (p.topInx | fc.rtInx);
+ if(plotLbl & sum(lblInx, na.rm=T) > 0){
+ text.lbls<-substr(colnames(mSetObj$dataSet$norm)[lblInx],1,14) # some names may be too long
+ text(vcn$fc.log[lblInx], vcn$p.log[lblInx],labels=text.lbls, pos=4, col="blue", srt=30, xpd=T, cex=0.8);
+ }
+ abline (v = vcn$max.xthresh, lty=3);
+ abline (v = vcn$min.xthresh, lty=3);
+ abline (h = vcn$thresh.y, lty=3);
+ axis(4); # added by Beomsoo
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+#'ANOVA
+#'@description Perform anova and only return p values and MSres (for Fisher's LSD)
+#'@param x Input the data to perform ANOVA
+#'@param cls Input class labels
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+aof <- function(x, cls) {
+ aov(x ~ cls);
+}
+
+
+#'Kruskal-Wallis
+#'@description Perform Kruskal-Wallis Test
+#'@param x Input data to perform Kruskal-Wallis
+#'@param cls Input class labels
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+kwtest <- function(x, cls) {
+ kruskal.test(x ~ cls);
+}
+
+#'Fisher for ANOVA
+#'@description Perform Fisher LSD for ANOVA, used in higher function
+#'@param aov.obj Input the anova object
+#'@param thresh Numeric, input the alpha threshold
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+FisherLSD <- function(aov.obj, thresh){
+ LSD.test(aov.obj,"cls", alpha=thresh)
+}
+
+#'Return only the signicant comparison names
+#'@description Return only the signicant comparison names, used in higher function
+#'@param tukey Input tukey output
+#'@param cut.off Input numeric cut-off
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+parseTukey <- function(tukey, cut.off){
+ inx <- tukey$cls[,"p adj"] <= cut.off;
+ paste(rownames(tukey$cls)[inx], collapse="; ");
+}
+
+#'Return only the signicant comparison names
+#'@description Return only the signicant comparison names, used in higher function
+#'@param fisher Input fisher object
+#'@param cut.off Numeric, set cut-off
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+parseFisher <- function(fisher, cut.off){
+ inx <- fisher[,"pvalue"] <= cut.off;
+ paste(rownames(fisher)[inx], collapse="; ");
+}
+
+#'Perform ANOVA analysis
+#'@description ANOVA analysis
+#'@usage ANOVA.Anal(mSetObj=NA, nonpar=F, thresh=0.05, post.hoc="fisher")
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param nonpar Logical, use a non-parametric test (T) or not (F)
+#'@param thresh Numeric, from 0 to 1, indicate the p-value threshold
+#'@param post.hoc Input the name of the post-hoc test, "fisher" or "tukey"
+#'@param all_results Logical, if TRUE, it will output the ANOVA results for all compounds
+#'with no post-hoc tests performed.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+ANOVA.Anal<-function(mSetObj=NA, nonpar=F, thresh=0.05, post.hoc="fisher", all_results=FALSE){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ sig.num <- 0;
+ if(nonpar){
+ aov.nm <- "Kruskal Wallis Test";
+ anova.res <- apply(as.matrix(mSetObj$dataSet$norm), 2, kwtest, cls=mSetObj$dataSet$cls);
+
+ #extract all p values
+ res <- unlist(lapply(anova.res, function(x) {c(x$statistic, x$p.value)}));
+ res <- data.frame(matrix(res, nrow=length(anova.res), byrow=T), stringsAsFactors=FALSE);
+
+ fstat <- res[,1];
+ p.value <- res[,2];
+
+ names(fstat) <- names(p.value) <- colnames(mSetObj$dataSet$norm);
+ fdr.p <- p.adjust(p.value, "fdr");
+
+ #inx.imp <- p.value <= thresh;
+ inx.imp <- fdr.p <= thresh;
+ sig.num <- sum(inx.imp);
+
+ if(sig.num > 0){
+ sig.f <- fstat[inx.imp];
+ sig.p <- p.value[inx.imp];
+ fdr.p <- fdr.p[inx.imp];
+
+ sig.mat <- data.frame(signif(sig.f,5), signif(sig.p,5), signif(-log10(sig.p),5), signif(fdr.p,5), 'NA');
+ rownames(sig.mat) <- names(sig.p);
+ colnames(sig.mat) <- c("chi.squared", "p.value", "-log10(p)", "FDR", "Post-Hoc");
+
+ # order the result simultaneously
+ ord.inx <- order(sig.p, decreasing = FALSE);
+ sig.mat <- sig.mat[ord.inx,,drop=F];
+
+ fileName <- "kw_posthoc.csv";
+ my.mat <- sig.mat[,1:4];
+ colnames(my.mat) <- c("chi_squared", "pval_KW", "-log10(p)", "FDR");
+ }
+ }else{
+ aov.nm <- "One-way ANOVA";
+ if(.on.public.web & RequireFastUnivTests(mSetObj)){
+ res <- PerformFastUnivTests(mSetObj$dataSet$norm, mSetObj$dataSet$cls);
+ }else{
+ aov.res <- apply(as.matrix(mSetObj$dataSet$norm), 2, aof, cls=mSetObj$dataSet$cls);
+ anova.res <- lapply(aov.res, anova);
+
+ #extract all p values
+ res <- unlist(lapply(anova.res, function(x) { c(x["F value"][1,], x["Pr(>F)"][1,])}));
+ res <- data.frame(matrix(res, nrow=length(aov.res), byrow=T), stringsAsFactors=FALSE);
+ }
+ fstat <- res[,1];
+ p.value <- res[,2];
+ names(fstat) <- names(p.value) <- colnames(mSetObj$dataSet$norm);
+
+ fdr.p <- p.adjust(p.value, "fdr");
+
+ if(all_results==TRUE){
+ all.mat <- data.frame(signif(p.value,5), signif(-log10(p.value),5), signif(fdr.p,5));
+ rownames(all.mat) <- names(p.value);
+ colnames(all.mat) <- c("p.value", "-log10(p)", "FDR");
+ fast.write.csv(all.mat, "anova_all_results.csv")
+ }
+
+ # do post-hoc only for signficant entries
+ # inx.imp <- p.value <= thresh;
+ inx.imp <- fdr.p <= thresh;
+ sig.num <- sum(inx.imp);
+ if(sig.num > 0){
+ # note aov obj is not avaible using fast version
+ # need to recompute using slower version for the sig ones
+ if(.on.public.web & RequireFastUnivTests(mSetObj)){
+ aov.imp <- apply(as.matrix(mSetObj$dataSet$norm[,inx.imp,drop=FALSE]), 2, aof, cls=mSetObj$dataSet$cls);
+ }else{
+ aov.imp <- aov.res[inx.imp];
+ }
+ sig.f <- fstat[inx.imp];
+ sig.p <- p.value[inx.imp];
+ fdr.p <- fdr.p[inx.imp];
+ cmp.res <- NULL;
+ post.nm <- NULL;
+ if(post.hoc=="tukey"){
+ tukey.res<-lapply(aov.imp, TukeyHSD, conf.level=1-thresh);
+ cmp.res <- unlist(lapply(tukey.res, parseTukey, cut.off=thresh));
+ post.nm = "Tukey's HSD";
+ }else{
+ fisher.res<-lapply(aov.imp, FisherLSD, thresh);
+ cmp.res <- unlist(lapply(fisher.res, parseFisher, cut.off=thresh));
+ post.nm = "Fisher's LSD";
+ }
+
+ # create the result dataframe,
+ # note, the last column is string, not double
+
+ sig.mat <- data.frame(signif(sig.f,5), signif(sig.p,5), signif(-log10(sig.p),5), signif(fdr.p,5), cmp.res);
+ rownames(sig.mat) <- names(sig.p);
+ colnames(sig.mat) <- c("f.value", "p.value", "-log10(p)", "FDR", post.nm);
+
+ # order the result simultaneously
+ ord.inx <- order(sig.p, decreasing = FALSE);
+ sig.mat <- sig.mat[ord.inx,,drop=F];
+ fileName <- "anova_posthoc.csv";
+ }
+ }
+
+ AddMsg(paste(c("A total of", sum(inx.imp), "significant features were found."), collapse=" "));
+ if(sig.num> 0){
+ res <- 1;
+ fast.write.csv(sig.mat,file=fileName);
+ aov<-list (
+ aov.nm = aov.nm,
+ sig.num = sig.num,
+ sig.nm = fileName,
+ raw.thresh = thresh,
+ thresh = -log10(thresh), # only used for plot threshold line
+ p.value = p.value,
+ p.log = -log10(p.value),
+ inx.imp = inx.imp,
+ post.hoc = post.hoc,
+ sig.mat = sig.mat
+ );
+ }else{
+ res <- 0;
+ aov<-list (
+ aov.nm = aov.nm,
+ sig.num = sig.num,
+ raw.thresh = thresh,
+ thresh = -log10(thresh), # only used for plot threshold line
+ p.value = p.value,
+ p.log = -log10(p.value),
+ inx.imp = inx.imp
+ );
+ }
+ mSetObj$analSet$aov <- aov;
+
+ if(.on.public.web){
+ .set.mSet(mSetObj);
+ return(res);
+ }else{
+ return(.set.mSet(mSetObj));
+ }
+}
+
+#'Plot ANOVA
+#'@description Plot ANOVA
+#'@usage PlotANOVA(mSetObj=NA, imgName, format="png", dpi=72, width=NA)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotANOVA <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ lod <- mSetObj$analSet$aov$p.log;
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+
+ if(is.na(width)){
+ w <- 9;
+ }else if(width == 0){
+ w <- 7;
+ }else{
+ w <- width;
+ }
+ h <- w*6/9;
+
+ mSetObj$imgSet$anova <- imgName;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ plot(lod, ylab="-log10(p)", xlab = GetVariableLabel(mSetObj$dataSet$type), main=mSetObj$analSet$aov$aov.nm, type="n");
+ red.inx <- which(mSetObj$analSet$aov$inx.imp);
+ blue.inx <- which(!mSetObj$analSet$aov$inx.imp);
+ points(red.inx, lod[red.inx], bg="red", cex=1.2, pch=21);
+ points(blue.inx, lod[blue.inx], bg="green", pch=21);
+ abline (h=mSetObj$analSet$aov$thresh, lty=3);
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+#'Plot Compound View
+#'@description Plots a bar-graph of selected compound over groups
+#'@usage PlotCmpdView(mSetObj=NA, cmpdNm, format="png", dpi=72, width=NA)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param cmpdNm Input a name for the compound
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+PlotCmpdView <- function(mSetObj=NA, cmpdNm, format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(.on.public.web){
+ load_ggplot()
+ }
+
+ if(mSetObj$dataSet$type.cls.lbl=="integer"){
+ cls <- as.factor(as.numeric(levels(mSetObj$dataSet$cls))[mSetObj$dataSet$cls]);
+ }else{
+ cls <- mSetObj$dataSet$cls;
+ }
+
+ imgName <- gsub("\\/", "_", cmpdNm);
+ imgName <- paste(imgName, "_dpi", dpi, ".", format, sep="");
+
+ my.width <- 200;
+ adj.width <- 90*length(levels(cls))+20;
+ if(adj.width > my.width){
+ my.width <- adj.width;
+ }
+
+ x <- mSetObj$dataSet$norm[, cmpdNm]
+ y <- cls
+ df <- data.frame(conc = x, class = y)
+ col <- unique(GetColorSchema(y))
+
+ Cairo::Cairo(file = imgName, dpi=dpi, width=my.width, height=325, type=format, bg="transparent");
+
+ p <- ggplot2::ggplot(df, aes(x=class, y=conc, fill=class)) + geom_boxplot(notch=FALSE, outlier.shape = NA, outlier.colour=NA) + theme_bw() + geom_jitter(size=1)
+ p <- p + theme(axis.title.x = element_blank(), axis.title.y = element_blank(), legend.position = "none")
+ p <- p + stat_summary(fun.y=mean, colour="yellow", geom="point", shape=18, size=3, show.legend = FALSE)
+ p <- p + theme(text = element_text(size=15), plot.margin = margin(t=0.20, r=0.25, b=0.55, l=0.25, "cm"))
+ p <- p + scale_fill_manual(values=col) + ggtitle(cmpdNm) + theme(axis.text.x = element_text(angle=45, hjust=1))
+ p <- p + theme(plot.title = element_text(size = 13, hjust=0.5, face="bold"), axis.text = element_text(size=10))
+ print(p)
+ dev.off()
+
+}
+
+##############################################
+##############################################
+########## Utilities for web-server ##########
+##############################################
+##############################################
+
+#'Sig Table for Fold-Change Analysis
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@export
+GetSigTable.FC <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ GetSigTable(mSetObj$analSet$fc$sig.mat, "fold change analysis", mSetObj$dataSet$type);
+}
+
+GetFCSigMat <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(CleanNumber(mSetObj$analSet$fc$sig.mat));
+}
+
+GetFCSigRowNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ rownames(mSetObj$analSet$fc$sig.mat);
+}
+
+GetFcSigUpMat <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ lod <- mSetObj$analSet$fc$fc.log;
+ red.inx<- which(mSetObj$analSet$fc$inx.up);
+ if(sum(red.inx) > 0){
+ return(as.matrix(cbind(red.inx, lod[red.inx])));
+ }else{
+ return(as.matrix(cbind(-1, -1)));
+ }
+}
+
+GetFcSigUpIDs <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ red.inx<- which(mSetObj$analSet$fc$inx.up);
+ if(sum(red.inx) > 0){
+ return(names(mSetObj$analSet$fc$fc.log)[red.inx]);
+ }else{
+ return("NA");
+ }
+}
+
+GetFcSigDnMat <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ lod <- mSetObj$analSet$fc$fc.log;
+ blue.inx<- which(mSetObj$analSet$fc$inx.down);
+ if(sum(blue.inx) > 0){
+ return(as.matrix(cbind(blue.inx, lod[blue.inx])));
+ }else{
+ return(as.matrix(cbind(-1, -1)));
+ }
+}
+
+GetFcSigDnIDs <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ blue.inx<- which(mSetObj$analSet$fc$inx.down);
+ if(sum(blue.inx) > 0){
+ return(names(mSetObj$analSet$fc$fc.log)[blue.inx]);
+ }else{
+ return("NA");
+ }
+}
+
+GetFcUnsigMat <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ lod <- mSetObj$analSet$fc$fc.log;
+ inx.imp <- mSetObj$analSet$fc$inx.up | mSetObj$analSet$fc$inx.down;
+ blue.inx<- which(!inx.imp);
+ if(sum(blue.inx) > 0){
+ return(as.matrix(cbind(blue.inx, lod[blue.inx])));
+ }else{
+ return(as.matrix(cbind(-1, -1)));
+ }
+}
+
+GetFcUnsigIDs <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ lod <- mSetObj$analSet$fc$fc.log;
+ inx.imp <- mSetObj$analSet$fc$inx.up | mSetObj$analSet$fc$inx.down;
+ blue.inx<- which(!inx.imp);
+ if(sum(blue.inx) > 0){
+ return(names(mSetObj$analSet$fc$fc.log)[blue.inx]);
+ }else{
+ return("NA");
+ }
+}
+
+GetFCSigColNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ colnames(mSetObj$analSet$fc$sig.mat);
+}
+
+GetAovSigMat <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(CleanNumber(as.matrix(mSetObj$analSet$aov$sig.mat[, 1:4])));
+}
+
+GetAovSigRowNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ rownames(mSetObj$analSet$aov$sig.mat);
+}
+
+GetAovSigColNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ colnames(mSetObj$analSet$aov$sig.mat[, 1:4]);
+}
+
+GetAovPostHocSig <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$analSet$aov$sig.mat[,5];
+}
+
+#'Sig Table for Anova
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@export
+GetSigTable.Anova <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ GetSigTable(mSetObj$analSet$aov$sig.mat, "One-way ANOVA and post-hoc analysis", mSetObj$dataSet$type);
+}
+
+GetAnovaUpMat <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ lod <- mSetObj$analSet$aov$p.log;
+ red.inx<- which(mSetObj$analSet$aov$inx.imp);
+ if(sum(red.inx) > 0){
+ return(as.matrix(cbind(red.inx, lod[red.inx])));
+ }else{
+ return(as.matrix(cbind(-1, -1)));
+ }
+}
+
+GetAovUpIDs <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ red.inx<- which(mSetObj$analSet$aov$inx.imp);
+ if(sum(red.inx) > 0){
+ return(names(mSetObj$analSet$aov$p.log)[red.inx]);
+ }else{
+ return("NA");
+ }
+}
+
+GetAnovaDnMat <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ lod <- mSetObj$analSet$aov$p.log;
+ blue.inx <- which(!mSetObj$analSet$aov$inx.imp);
+ if(sum(blue.inx) > 0){
+ return(as.matrix(cbind(blue.inx, lod[blue.inx])));
+ }else{
+ return(as.matrix(cbind(-1, -1)));
+ }
+}
+
+GetAovDnIDs <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ blue.inx<- which(!mSetObj$analSet$aov$inx.imp);
+ if(sum(blue.inx) > 0){
+ return(names(mSetObj$analSet$aov$p.log)[blue.inx]);
+ }else{
+ return("NA");
+ }
+}
+
+GetAnovaCmpds <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ names(mSetObj$analSet$aov$p.log);
+}
+
+GetAnovaSigFileName <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$analSet$aov$sig.nm;
+}
+
+#'Sig Table for T-test Analysis
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@export
+GetSigTable.TT <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ GetSigTable(mSetObj$analSet$tt$sig.mat, "t-tests", mSetObj$dataSet$type);
+}
+
+#'T-test matrix
+#'@description Return a double matrix with 2 columns - p values and lod
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+GetTTSigMat <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(CleanNumber(mSetObj$analSet$tt$sig.mat));
+}
+
+GetTTSigRowNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ rownames(mSetObj$analSet$tt$sig.mat);
+}
+
+GetTTSigColNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ colnames(mSetObj$analSet$tt$sig.mat);
+}
+
+GetTtUpMat <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ lod <- mSetObj$analSet$tt$p.log;
+ red.inx<- which(mSetObj$analSet$tt$inx.imp);
+ if(sum(red.inx) > 0){
+ return(as.matrix(cbind(red.inx, lod[red.inx])));
+ }else{
+ return(as.matrix(cbind(-1, -1)));
+ }
+}
+
+GetTtUpIDs <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ red.inx<-which(mSetObj$analSet$tt$inx.imp);;
+ if(sum(red.inx) > 0){
+ return(names(mSetObj$analSet$tt$p.log)[red.inx]);
+ }else{
+ return("NA");
+ }
+}
+
+GetTtDnMat <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ lod <- mSetObj$analSet$tt$p.log;
+ blue.inx <- which(!mSetObj$analSet$tt$inx.imp);
+
+ if(sum(blue.inx) > 0){
+ return(as.matrix(cbind(blue.inx, lod[blue.inx])));
+ }else{
+ return(as.matrix(cbind(-1, -1)));
+ }
+}
+
+GetTtDnIDs <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ blue.inx<-which(!mSetObj$analSet$tt$inx.imp);
+ if(sum(blue.inx) > 0){
+ return(names(mSetObj$analSet$tt$p.log)[blue.inx]);
+ }else{
+ return("NA");
+ }
+}
+
+GetTtCmpds <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ names(mSetObj$analSet$tt$p.log);
+}
+
+GetTtestSigFileName <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$analSet$tt$sig.nm;
+}
+
+#'Retrieve T-test p-values
+#'@description Utility method to get p values
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param paired Default set to FALSE
+#'@param equal.var Default set to TRUE
+#'@param nonpar Use non-parametric tests, default is set to FALSE
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+GetTtestRes <- function(mSetObj=NA, paired=FALSE, equal.var=TRUE, nonpar=F){
+
+ mSetObj <- .get.mSet(mSetObj);
+ inx1 <- which(mSetObj$dataSet$cls==levels(mSetObj$dataSet$cls)[1]);
+ inx2 <- which(mSetObj$dataSet$cls==levels(mSetObj$dataSet$cls)[2]);
+ if(length(inx1) ==1 || length(inx2) == 1){
+ equal.var <- TRUE; # overwrite use option if one does not have enough replicates
+ }
+ univ.test <- function(x){t.test(x[inx1], x[inx2], paired = paired, var.equal = equal.var)};
+ if(nonpar){
+ univ.test <- function(x){wilcox.test(x[inx1], x[inx2], paired = paired)};
+ }
+ my.fun <- function(x) {
+ tmp <- try(univ.test(x));
+ if(class(tmp) == "try-error") {
+ return(c(NA, NA));
+ }else{
+ return(c(tmp$statistic, tmp$p.value));
+ }
+ }
+ res <- apply(as.matrix(mSetObj$dataSet$norm), 2, my.fun);
+ return(t(res));
+}
+
+#'Utility method to perform the univariate analysis automatically
+#'@description The approach is computationally expensive,and fails more often
+#'get around: make it lazy unless users request, otherwise the default t-test will also be affected
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+GetUnivReport <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ paired <- mSetObj$analSet$tt$paired;
+ threshp <- mSetObj$analSet$tt$raw.thresh;
+
+ inx1 <- which(mSetObj$dataSet$cls==levels(mSetObj$dataSet$cls)[1]);
+ inx2 <- which(mSetObj$dataSet$cls==levels(mSetObj$dataSet$cls)[2]);
+
+ # output list (mean(sd), mean(sd), p-value, FoldChange, Up/Down)
+ univStat.mat <- apply(as.matrix(mSetObj$dataSet$norm), 2, function(x) {
+
+ # normality test for each group
+ # ks <- ks.test(x[inx1], x[inx2]);
+ if( var(x[inx1], na.rm=T) == 0 |var(x[inx2], na.rm=T) == 0 ){ # shapiro cannot work when all values are same
+ method = "";
+ }else{
+ sw.g1 <- shapiro.test(x[inx1]);
+ sw.g2 <- shapiro.test(x[inx2]);
+ method <- ifelse( ((sw.g1$p.value <= 0.05) | (sw.g2$p.value <= 0.05)), "(W)","")
+ }
+ if (method == "(W)") {
+ # wilcoxon test
+ tmp <- try(wilcox.test(x[inx1], x[inx2], paired = paired));
+ } else {
+ # t-test
+ equal.var <- TRUE;
+ if(var(x, na.rm=TRUE) != 0) {
+ anal.var <- var.test(x[inx1], x[inx2]);
+ equal.var <- ifelse(anal.var$p.value <= 0.05, FALSE, TRUE);
+ }
+
+ tmp <- try(t.test(x[inx1], x[inx2], paired = paired, var.equal = equal.var));
+ }
+ if(class(tmp) == "try-error") {
+ return(NA);
+ }else{
+ mean1 <- mean(x[inx1]);
+ mean2 <- mean(x[inx2]);
+ sd1 <- sd(x[inx1]);
+ sd2 <- sd(x[inx2]);
+ p.value <- paste(ifelse(tmp$p.value < 0.0001, "< 0.0001", sprintf("%.4f", tmp$p.value,4))," ", method, sep="");
+ p.value.origin <- tmp$p.value;
+ foldChange <- mean1 / mean2;
+ foldChange <- round(ifelse( foldChange >= 1, foldChange, (-1/foldChange) ), 2);
+ upDown <- ifelse(mean1 > mean2, "Up","Down");
+
+ univStat <- c(
+ meanSD1 = sprintf("%.3f (%.3f)", mean1, sd1),
+ meanSD2 = sprintf("%.3f (%.3f)", mean2, sd2),
+ p.value = p.value,
+ foldChange = foldChange,
+ upDown = upDown,
+ p.value.origin = sprintf("%.5f", p.value.origin)
+ );
+ return(univStat);
+ }
+ })
+
+ univStat.mat <- as.data.frame(t(univStat.mat));
+
+ # add FDR/q-value
+ q.value <- sprintf("%.4f", p.adjust(p=as.numeric(levels(univStat.mat$p.value.origin))[univStat.mat$p.value.origin], method='fdr'));
+ univStat.mat <- cbind(univStat.mat[, c(1,2,3)], q.value, univStat.mat[, c(4,5)], univStat.mat[,6]);
+ names(univStat.mat)[1] <- paste("Mean (SD) of ", levels(mSetObj$dataSet$cls)[1], sep='');
+ names(univStat.mat)[2] <- paste("Mean (SD) of ", levels(mSetObj$dataSet$cls)[2], sep='');
+ names(univStat.mat)[3] <- "p-value";
+ names(univStat.mat)[4] <- "q-value (FDR)";
+ names(univStat.mat)[5] <- "Fold Change";
+ names(univStat.mat)[6] <- paste(levels(mSetObj$dataSet$cls)[1],"/", levels(mSetObj$dataSet$cls)[2], sep='');
+ names(univStat.mat)[7] <- "p.value.origin";
+
+ univStat.mat <- cbind(Name=rownames(univStat.mat), univStat.mat);
+ rownames(univStat.mat) <- NULL
+
+ ## generate univariate report file (univAnalReport.csv).
+ ## mixed with t-test and wilcoxon test depend on each metabolite's distribution
+ univAnal.mat <- univStat.mat;
+ note.str <- paste("\n Univariate Analysis Result for each variable/metabolite\n\n",
+ "[NOTE]\n",
+ " p-value is calculated with t-test as a default.\n",
+ " p-value with (W) is calculated by the Wilcoxon Mann Whitney test\n\n\n", sep='');
+
+ cat(note.str, file="univAnalReport.csv", append=FALSE);
+ write.table(univAnal.mat, file="univAnalReport.csv", append=TRUE, sep=",", row.names=FALSE);
+
+ ## generate subset with the threshold (p-value)
+ sigones <- which(as.numeric(as.character(univAnal.mat$p.value.origin)) <= threshp);
+ orig.data<- qs::qread("data_orig.qs");
+ sigDataSet.orig <- cbind(SampleID=rownames(orig.data), Label=mSetObj$dataSet$cls, orig.data[,c(sigones)])
+ sigDataSet.norm <- cbind(SampleID=rownames(orig.data), Label=mSetObj$dataSet$cls, orig.data[,c(sigones)])
+
+ write.table(sigDataSet.orig, file=paste("data_subset_orig_p", threshp, ".csv", sep=''), append=FALSE, sep=",", row.names=FALSE);
+ write.table(sigDataSet.norm, file=paste("data_subset_norm_p", threshp, ".csv", sep=''), append=FALSE, sep=",", row.names=FALSE);
+}
+
+ContainInfiniteTT<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ if(sum(!is.finite(mSetObj$analSet$tt$sig.mat))>0){
+ return("true");
+ }
+ return("false");
+}
+
+GetVolcanoDnMat <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ vcn <- mSetObj$analSet$volcano;
+ imp.inx <- (vcn$inx.up | vcn$inx.down) & vcn$inx.p;
+ blue.inx <- which(!imp.inx);
+
+ if(sum(blue.inx)>0){
+ xs <- vcn$fc.log[blue.inx]
+ ys <- vcn$p.log[blue.inx];
+ return(as.matrix(cbind(xs, ys)));
+ }else{
+ return(as.matrix(cbind(-1, -1)));
+ }
+}
+
+GetVolcanoUpLftMat <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ vcn <- mSetObj$analSet$volcano;
+ imp.inx <- vcn$inx.down & vcn$inx.p;
+ red.inx <- which(imp.inx);
+ if(sum(red.inx)>0){
+ xs <- vcn$fc.log[red.inx]
+ ys <- vcn$p.log[red.inx];
+ return(as.matrix(cbind(xs, ys)));
+ }else{
+ return(as.matrix(cbind(-1, -1)));
+ }
+}
+
+GetVolcanoUpRgtMat <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ vcn <- mSetObj$analSet$volcano;
+ imp.inx <- vcn$inx.up & vcn$inx.p;
+ red.inx <- which(imp.inx);
+ if(sum(red.inx)>0){
+ xs <- vcn$fc.log[red.inx]
+ ys <- vcn$p.log[red.inx];
+ return(as.matrix(cbind(xs, ys)));
+ }else{
+ return(as.matrix(cbind(-1, -1)));
+ }
+}
+
+GetVolcanoUpLftIDs <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ vcn <- mSetObj$analSet$volcano;
+ imp.inx <- vcn$inx.down & vcn$inx.p;
+ red.inx <- which(imp.inx);
+ if(sum(red.inx)>0){
+ return(names(mSetObj$analSet$volcano$fc.log)[red.inx]);
+ }else{
+ return("NA");
+ }
+}
+
+GetVolcanoUpRgtIDs <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ vcn <- mSetObj$analSet$volcano;
+ imp.inx <- vcn$inx.up & vcn$inx.p;
+ red.inx <- which(imp.inx);
+ if(sum(red.inx)>0){
+ return(names(mSetObj$analSet$volcano$fc.log)[red.inx]);
+ }else{
+ return("NA");
+ }
+}
+
+GetVolcanoDnIDs <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ vcn <- mSetObj$analSet$volcano;
+ imp.inx <- (vcn$inx.up | vcn$inx.down) & vcn$inx.p;
+ blue.inx <- which(!imp.inx);
+ if(sum(blue.inx)>0){
+ return(names(mSetObj$analSet$volcano$fc.log)[blue.inx]);
+ }else{
+ return("NA");
+ }
+}
+
+GetVolcanoCmpds <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ names(mSetObj$analSet$volcano$fc.log);
+}
+
+#'Volcano indices
+#'@description Get indices of top n largest/smallest number
+#'@param vec Vector containing volcano indices
+#'@param n Numeric
+#'@param dec Logical, default set to TRUE
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+GetTopInx <- function(vec, n, dec=T){
+ inx <- order(vec, decreasing = dec)[1:n];
+ # convert to T/F vec
+ vec<-rep(F, length=length(vec));
+ vec[inx] <- T;
+ return (vec);
+}
+
+#'Sig table for Volcano Analysis
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@export
+GetSigTable.Volcano <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ GetSigTable(mSetObj$analSet$volcano$sig.mat, "volcano plot", mSetObj$dataSet$type);
+}
+
+GetVolcanoSigMat <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(CleanNumber(mSetObj$analSet$volcano$sig.mat));
+}
+
+GetVolcanoSigRowNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(rownames(mSetObj$analSet$volcano$sig.mat));
+}
+
+GetVolcanoSigColNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(colnames(mSetObj$analSet$volcano$sig.mat));
+}
+
+ContainInfiniteVolcano <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ if(sum(!is.finite(mSetObj$analSet$volcano$sig.mat))>0){
+ return("true");
+ }
+ return("false");
+}
+
+GetAovSigNum <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(mSetObj$analSet$aov$sig.num);
+}
+
+
+#'Calculate Fisher's Least Significant Difference (LSD)
+#'@description Adapted from the 'agricolae' package
+#'@param y Input Y
+#'@param trt Input trt
+#'@param alpha Numeric, default is 0.05
+#'@author Jeff Xia\email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+LSD.test <- function(y, trt, alpha = 0.05){
+ clase<-c("aov","lm")
+ name.y <- paste(deparse(substitute(y)))
+ name.t <- paste(deparse(substitute(trt)))
+ if("aov"%in%class(y) | "lm"%in%class(y)){
+ A<-y$model
+ DFerror<-df.residual(y)
+ MSerror<-deviance(y)/DFerror
+ y<-A[,1]
+ ipch<-pmatch(trt,names(A))
+ name.t <-names(A)[ipch]
+ trt<-A[,ipch]
+ name.y <- names(A)[1]
+ }
+ junto <- subset(data.frame(y, trt), is.na(y) == FALSE)
+ means <- tapply.stat(junto[, 1], junto[, 2], stat="mean") #change
+ sds <- tapply.stat(junto[, 1], junto[, 2], stat="sd") #change
+ nn <- tapply.stat(junto[, 1], junto[, 2], stat="length") #change
+ std.err <- sds[, 2]/sqrt(nn[, 2])
+ Tprob <- qt(1 - alpha/2, DFerror)
+ LCL <- means[,2]-Tprob*std.err
+ UCL <- means[,2]+Tprob*std.err
+ means <- data.frame(means, std.err, replication = nn[, 2], LCL, UCL)
+ names(means)[1:2] <- c(name.t, name.y)
+ #row.names(means) <- means[, 1]
+ ntr <- nrow(means)
+ nk <- choose(ntr, 2)
+ nr <- unique(nn[, 2])
+
+ comb <- combn(ntr, 2)
+ nn <- ncol(comb)
+ dif <- rep(0, nn)
+ LCL1<-dif
+ UCL1<-dif
+ sig<-NULL
+ pvalue <- rep(0, nn)
+ for (k in 1:nn) {
+ i <- comb[1, k]
+ j <- comb[2, k]
+ if (means[i, 2] < means[j, 2]){
+ comb[1, k]<-j
+ comb[2, k]<-i
+ }
+ dif[k] <- abs(means[i, 2] - means[j, 2])
+ sdtdif <- sqrt(MSerror * (1/means[i, 4] + 1/means[j,4]))
+ pvalue[k] <- 2 * (1 - pt(dif[k]/sdtdif, DFerror));
+ pvalue[k] <- round(pvalue[k],6);
+ LCL1[k] <- dif[k] - Tprob*sdtdif
+ UCL1[k] <- dif[k] + Tprob*sdtdif
+ sig[k]<-" "
+ if (pvalue[k] <= 0.001) sig[k]<-"***"
+ else if (pvalue[k] <= 0.01) sig[k]<-"**"
+ else if (pvalue[k] <= 0.05) sig[k]<-"*"
+ else if (pvalue[k] <= 0.1) sig[k]<-"."
+ }
+ tr.i <- means[comb[1, ],1]
+ tr.j <- means[comb[2, ],1]
+ output<-data.frame("Difference" = dif, pvalue = pvalue,sig,LCL=LCL1,UCL=UCL1)
+ rownames(output)<-paste(tr.i,tr.j,sep=" - ");
+ output;
+}
+
+
+tapply.stat <-function (y, x, stat = "mean"){
+ cx<-deparse(substitute(x))
+ cy<-deparse(substitute(y))
+ x<-data.frame(c1=1,x)
+ y<-data.frame(v1=1,y)
+ nx<-ncol(x)
+ ny<-ncol(y)
+ namex <- names(x)
+ namey <- names(y)
+ if (nx==2) namex <- c("c1",cx)
+ if (ny==2) namey <- c("v1",cy)
+ namexy <- c(namex,namey)
+ for(i in 1:nx) {
+ x[,i]<-as.character(x[,i])
+ }
+ z<-NULL
+ for(i in 1:nx) {
+ z<-paste(z,x[,i],sep="&")
+ }
+ w<-NULL
+ for(i in 1:ny) {
+ m <-tapply(y[,i],z,stat)
+ m<-as.matrix(m)
+ w<-cbind(w,m)
+ }
+ nw<-nrow(w)
+ c<-rownames(w)
+ v<-rep("",nw*nx)
+ dim(v)<-c(nw,nx)
+ for(i in 1:nw) {
+ for(j in 1:nx) {
+ v[i,j]<-strsplit(c[i],"&")[[1]][j+1]
+ }
+ }
+ rownames(w)<-NULL
+ junto<-data.frame(v[,-1],w)
+ junto<-junto[,-nx]
+ names(junto)<-namexy[c(-1,-(nx+1))]
+ return(junto)
+}
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_biomarker.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_biomarker.R
new file mode 100755
index 0000000000000000000000000000000000000000..2352b6acd2a5ea291d52e72e9bfb00c10ab61785
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_biomarker.R
@@ -0,0 +1,567 @@
+#'Create report of analyses (Biomarker)
+#'@description Report generation using Sweave
+#'Puts together the analysis report
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param usrName Input the name of the user
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateBiomarkerRnwReport<-function(mSetObj, usrName){
+
+ CreateHeader(usrName);
+ CreateBiomarkerIntr();
+
+ CreateBiomarkerOverview();
+ CreateBiomarkerInputDoc(mSetObj);
+ CreateNORMdoc(mSetObj);
+ CreateBiomarkerRatioOverview(mSetObj);
+
+ CreateUnivarBiomarkersDoc(mSetObj);
+ CreateMultiBiomarkersDoc(mSetObj);
+ CreateModelBiomarkersDoc(mSetObj);
+
+ CreateRHistAppendix();
+ CreateFooter();
+}
+
+
+#'Create biomarker analysis report: Introduction
+#'@description Report generation using Sweave
+#'Biomarker analysis report introduction
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateBiomarkerIntr<-function(){
+ descr <- c("\\section{Background}\n",
+ "The metabolome is well-known to be a sensitive measure of health and disease, reflecting alterations",
+ " to the genome, proteome, and transcriptome, as well as changes in life-style and environment. As such,",
+ " one common goal of metabolomic studies is biomarker discovery, which aims to identify a metabolite or a set",
+ " of metabolites capable of classifying conditions or disease with high sensitivity (true-positive rate) and",
+ " specificity (true negative rate). Biomarker discovery is achieved through building predictive models of one or multiple metabolites",
+ " and evaluating the performance, or robustness of the model, to classify new patients into diseased or healthy categories.",
+ " The Biomarker analysis module supports all common ROC-curve based biomarker analyses. It includes several options for single (classical)",
+ " or multiple biomarker analysis, as well as for predictive biomarker model creation and evaluation.",
+ " For a comprehensive introductory tutorial and further details concerning biomarker analysis, please refer to",
+ " \\textbf{Translational biomarker discovery in clinical metabolomics: an introductory tutorial} by Xia et al. 2013 (PMID: 23543913).\n"
+ );
+ cat(descr, file=rnwFile, append=TRUE);
+}
+
+
+#'Create biomarker analysis report: Overview
+#'@description Report generation using Sweave
+#'Power analysis report overview
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateBiomarkerOverview <- function(){
+ descr <- c("\\section{Biomarker Analysis Overview}\n",
+ "The module consists of five steps - uploading the data, data processing,",
+ " biomarker selection, performance evaluation, and model creation. There are several options within",
+ " MetaboAnalystR to perform each of these steps, supporting all common ROC-curve based biomarker analyses. \n"
+ );
+ cat(descr, file=rnwFile, append=TRUE);
+}
+
+#'Create biomarker analysis report: Data Input
+#'@description Report generation using Sweave
+#'Power analysis report, data input documentation.
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateBiomarkerInputDoc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ descr <- c("\\section{Data Input}\n",
+ "The biomarker analysis module accepts either a compound concentration table, spectral binned data, or a peak intensity",
+ " table. The format of the data must be specified, identifying whether the samples are in rows or columns, and whether",
+ " or not the data is paired. The data may either be .csv or .txt files.",
+ " \n\n");
+
+ cat(descr, file=rnwFile, append=TRUE);
+
+ # the data filtering
+ descr<-c("\\subsubsection{Data Filtering}\n",
+ " The purpose of data filtering is to identify and remove variables that are unlikely to be of",
+ " use when modeling the data. No phenotype information is used in the filtering process, so the result",
+ " can be used with any downstream analysis. This step can usually improve the results.",
+ " Data filtering is strongly recommended for datasets with a large number of variables (> 250) and",
+ " for datasets which contain a lot of noise (i.e.chemometrics data). Filtering can usually improve your",
+ " results\\footnote{Hackstadt AJ, Hess AM.\\textit{Filtering for increased power for microarray data analysis},",
+ " BMC Bioinformatics. 2009; 10: 11.}.",
+ " \n\n",
+ " \\textit{For data with < 250 of variables, filtering will reduce 5\\% of variables;",
+ " For a total number of variables between 250 and 500, 10\\% of variables will be removed;",
+ " For a total number of variables bewteen 500 and 1000, 25\\% of variables will be removed;",
+ " Finally, 40\\% of variables will be removed for data with over 1000 variables.}");
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+ filt.msg <- mSetObj$msgSet$filter.msg;
+ if(is.null(filt.msg)){
+ filt.msg <- "No data filtering was performed.";
+ }
+
+ cat(filt.msg, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+ descr<-c("\\subsubsection{Data Integrity Check}\n",
+ " Before data analysis, a data integrity check is performed to make sure that all of the necessary",
+ " information has been collected. The class labels must be present and must contain only two classes.",
+ " If the samples are paired, the class label must be from -n/2 to -1 for one group, and 1 to n/2 for the second group",
+ " (n is the sample number and must be an even number). Class labels with the same absolute value are assumed to be pairs.",
+ " Compound concentration or peak intensity values must all be non-negative numbers.",
+ " By default, all missing values, zeros and negative values will be replaced by the half of the minimum positive value",
+ " found within the data (see next section).");
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+ descr<-c("\\subsubsection{Missing value imputations}\n",
+ "Too many zeroes or missing values will cause difficulties in the downstream analysis.",
+ " MetaboAnalystR offers several different methods for this purpose. The default method replaces ",
+ " all the missing and zero values with a small values (the half of the minimum positive",
+ " values in the original data) assuming to be the detection limit. The assumption of this approach",
+ " is that most missing values are caused by low abundance metabolites (i.e.below the detection limit).",
+ " In addition, since zero values may cause problem for data normalization (i.e. log), they are also ",
+ " replaced with this small value. User can also specify other methods, such as replace by mean/median,",
+ " or use K-Nearest Neighbours (KNN), Probabilistic PCA (PPCA), Bayesian PCA (BPCA) method, Singular Value Decomposition (SVD)",
+ " method to impute the missing values \\footnote{Stacklies W, Redestig H, Scholz M, Walther D, Selbig J.",
+ " \\textit{pcaMethods: a bioconductor package, providing PCA methods for incomplete data.}, Bioinformatics",
+ " 2007 23(9):1164-1167}. Please select the one that is the most appropriate for your data.");
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+ if(is.null(mSetObj$msgSet$replace.msg)){
+ mSetObj$msgSet$replace.msg <- "No data filtering was performed.";
+ }
+
+ cat(mSetObj$msgSet$replace.msg, file=rnwFile, append=TRUE);
+
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+}
+
+#'Create biomarker analysis report: Normalization, ratio
+#'@description Report generation using Sweave
+#'Biomarker analysis, ratio option
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateBiomarkerRatioOverview <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ descr <- c("\\subsection{Biomarker Analysis Normalization}\n",
+ "The normalization step for the biomarker analysis module includes an additional option for",
+ " calculating ratios between metabolite concentrations. Ratios between two metabolite concentrations",
+ " may provide more information than the two metabolite concentrations separately. MetaboAnalystR",
+ " will compute ratios between all possible metabolite pairs and then select the top ranked ratios (based on p-values)",
+ " to include with the data for further biomarker analysis. Please note, there is a potential overfitting issue",
+ " associated with this procedure. The main purpose of computing ratios of metabolite concentrations is to improve the chances of biomarker discovery,",
+ " therefore users will need to validate their performance in future, independent studies. Log normalization of the data will be performed",
+ " during the process. \n"
+ );
+ cat(descr, file=rnwFile, append=TRUE);
+
+ if(exists('ratio', where=mSetObj$analSet)){
+
+ ratiotable<-c("<<echo=false, results=tex>>=",
+ "CreateRatioTable(mSet)",
+ "@");
+ cat(ratiotable, file=rnwFile, append=TRUE, sep="\n");
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+ }
+
+ else{
+ rationo <- "No ratios between metabolite concentration pairs were computed.";
+ cat(rationo, file=rnwFile, append=TRUE);
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+ }
+
+}
+
+#'Create report of analyses
+#'@description Report generation using Sweave
+#'Function to create a summary table for biomarker analysis: included metabolite ratios
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateRatioTable <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+ ratiodf <- mSetObj$dataSet$ratio
+ ldf <- lapply(ratiodf, mean)
+ mdf <- do.call(rbind.data.frame, mdf)
+ colnames(mdf)[1] <- "Mean concentration ratios across all samples"
+
+ print(xtable::xtable(mdf, caption="Top ranked included ratios for biomarker analysis"), caption.placement="top", size="\\scriptsize");
+
+}
+
+#'Create power analysis report: Biomarker Univariate Analysis
+#'@description Report generation using Sweave
+#'Biomarker analysis report, Univariate Analysis
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateUnivarBiomarkersDoc<-function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(is.null(mSetObj$imgSet$roc.univ.plot)){
+ return()
+ }
+
+ if(is.null(mSetObj$imgSet$roc.univ.boxplot)){
+ return()
+ }
+
+ descr <- c("\\section{Classical ROC curve analysis}\n",
+ "The aim of classical ROC curve analysis is to evaluate the performance of a single feature, either",
+ " one metabolite or a combined metabolite ratio pair, as a biomarker. The ROC curve summarizes the sensitivity",
+ " and specificity of that single feature to accurately classify data, which can then be used to compare",
+ " the overall accuracy of different biomarkers. \n");
+ cat(descr, file=rnwFile, append=TRUE);
+
+ descr <- paste("Figure", fig.count<<-fig.count+1, "ROC curve of an individual biomarker.")
+
+ cat(descr, file=rnwFile, append=TRUE);
+
+ descr <- paste("Figure", fig.count<<-fig.count+1, "Boxplot of an individual biomarker.")
+
+ cat(descr, file=rnwFile, append=TRUE);
+
+ ft.name <- paste(mSetObj$imgSet$roc.univ.name);
+
+ univbio<-c( "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$roc.univ.plot,"}", sep=""),
+ "\\caption{The ROC curve of an individual biomarker.",
+ " The sensitivity is on the y-axis, and the specificity is on the",
+ " x-axis. The area-under-the-curve (AUC) is in blue.",
+ "Selected individual biomarker name :", ft.name, "}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$roc.univ.plot,"}", sep=""),
+ "\\end{figure}",
+ "\\clearpage"
+ );
+ cat(univbio, file=rnwFile, append=TRUE, sep="\n");
+
+ ft.name <- paste(mSetObj$imgSet$roc.univ.name);
+
+ univbio<-c( "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=0.35\\textwidth]{", mSetObj$imgSet$roc.univ.boxplot,"}", sep=""),
+ "\\caption{Box-plot of the concentrations of the selected",
+ " feature between two groups within the dataset.",
+ " A horizontal line is in red indicating the optimal cutoff.",
+ "Selected individual biomarker name :", ft.name, "}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$roc.univ.boxplot,"}", sep=""),
+ "\\end{figure}",
+ "\\clearpage"
+ );
+ cat(univbio, file=rnwFile, append=TRUE, sep="\n");
+
+ if(exists("feat.rank.mat")){
+ univROCtable<-c("<<echo=false, results=tex>>=",
+ "CreateUnivROCTable()",
+ "@");
+ cat(univROCtable, file=rnwFile, append=TRUE, sep="\n");
+ }
+
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+
+}
+
+#'Create summary table for univariate ROC analysis
+#'@description Report generation using Sweave
+#'Function to create a summary table for univariate biomarker analysis
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateUnivROCTable<-function(){
+
+ univROCtable <- feat.rank.mat
+
+ colnames(univROCtable) <- c("Area-under-the-curve", "T-test", "Log 2 Fold-Change", "Cluster")
+
+ print(xtable::xtable(univROCtable, caption="AUC, Log2FC, T-test and K-Means Cluster for univariate biomarker analysis"), caption.placement="top", size="\\scriptsize");
+
+}
+
+#'Create biomarker analysis report: Multivariate Biomarker Analysis
+#'@description Report generation using Sweave
+#'Biomarker analysis report, Multivariate Biomarker Analysis
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateMultiBiomarkersDoc<-function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(is.null(mSetObj$analSet$multiROC$auc.vec)){
+ return()
+ }
+
+ descr <- c("\\section{Multivariate ROC curve exploration}\n",
+ "The aim of the multivariate exploratory ROC curve analysis is to evaluate the performance of biomarker models created",
+ " through automated important feature identification. There are three multivariate algorithms used for ROC curve analysis",
+ " partial least squares discriminant analysis (PLS-DA), random forest, and support vector machines (SVM). To begin,",
+ " ROC curves are generated by Monte-Carlo cross validation (MCCV) using balanced subsampling. In each MCCV, 2/3 of the samples",
+ " are used to evaluate feature importance, and the remaining 1/3 are used to validate the models created with the first step.",
+ " The top ranking features (max top 100) in terms of importance are used to build the biomarker classification models. This is repeated",
+ " several times to calculate the performance and confidence intervals of each model. Users",
+ " must specify the classification method and the feature ranking method for ROC curve analysis. For large datasets,",
+ " with more than 1000 features, the univariate feature ranking method is recommended to avoid long computation times. For",
+ " the PLS-DA method, users have the option to specify the number of latent variables (LV) to use. By default it is 2.",
+ " In the plots below, users have selected to create plots for all biomarker models, or a single biomarker model. The plot description",
+ " will indicate the model selected. If it is 0, it means the plot is for all biomarker models. A -1 means it used the best model, and an",
+ " input 1-6 to plot a ROC curve for one of the top six models.",
+ "\n\n",
+ paste("Figure", fig.count<<-fig.count+1, ". shows the ROC curves of all or a single biomarker model based on the average cross validation performance."),
+ paste("Figure", fig.count<<-fig.count+1, ". shows the predicted class probabilities of all samples using a selected biomarker model."),
+ paste("Figure", fig.count<<-fig.count+1, ". shows the predictive accuracy of biomarker models with an increasing number of features."),
+ paste("Figure", fig.count<<-fig.count+1, ". shows the significant features of single biomarker model ranked by importance."),
+ "\n");
+
+ cat(descr, file=rnwFile, append=TRUE);
+
+ # ROC plot
+
+ modelindex <- paste(mSetObj$imgSet$roc.multi.model)
+
+ ROCplot <- c( "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$roc.multi.plot,"}", sep=""),
+ "\\caption{", paste("Plot of ROC curves for all or a single biomarker model based on its average performance",
+ " across all MCCV runs. For a single biomarker, the 95 percent confidence interval",
+ " can be computed and will appear as a band around the ROC curve.", sep=""),"}",
+ "Selected model :", modelindex,
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$roc.multi.plot,"}", sep=""),
+ "\\end{figure}",
+ "\\clearpage"
+ );
+ cat(ROCplot, file=rnwFile, append=TRUE, sep="\n");
+
+ # Prob
+
+ modelindex2 <- paste(mSetObj$imgSet$roc.prob.name)
+
+ ROCplot <- c( "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$roc.prob.plot,"}", sep=""),
+ "\\caption{", paste("Plot of predicted class probabilities for all samples using a single biomarker model.",
+ " Due to balanced subsampling, the classification boundary is at the center (x=0.5, dotted line).", sep=""),"}",
+ "Selected model :", modelindex2,
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$roc.prob.plot,"}", sep=""),
+ "\\end{figure}",
+ "\\clearpage"
+ );
+ cat(ROCplot, file=rnwFile, append=TRUE, sep="\n");
+
+ # Pred
+
+ ROCplot <- c( "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$roc.pred,"}", sep=""),
+ "\\caption{", paste("Plot of the predictive accuracy of biomarker models with an increasing number of features.",
+ " The most accurate biomarker model will be highlighted with a red dot.", sep=""),"}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$roc.pred,"}", sep=""),
+ "\\end{figure}",
+ "\\clearpage"
+ );
+ cat(ROCplot, file=rnwFile, append=TRUE, sep="\n");
+
+ # Sig features
+
+ modelindex3 <- paste(mSetObj$imgSet$roc.imp.name)
+
+ ROCplot <- c( "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$roc.imp.plot,"}", sep=""),
+ "\\caption{", paste("Plot of the most important features of a selected model ranked from most to least important.",
+ " Selected model :", modelindex3, sep=""), "}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$roc.imp.plot,"}", sep=""),
+ "\\end{figure}",
+ "\\clearpage"
+ );
+ cat(ROCplot, file=rnwFile, append=TRUE, sep="\n");
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+
+}
+
+#'Create biomarker analysis report: ROC Curve Based Model Creation and Evaluation
+#'@description Report generation using Sweave
+#'Biomarker analysis report, ROC Curve Based Model Creation and Evaluation
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateModelBiomarkersDoc<-function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(is.null(mSetObj$analSet$ROCtest$auc.vec)){
+ return()
+ }
+
+ descr <- c("\\section{ROC Curve Based Model Creation and Evaluation}\n",
+ "The aim of ROC curve based model creation and evaluation is to allow users to manually select any combination of features to create biomarker",
+ " models using any of the three algorithms mentioned previously (PLS-DA, SVM, RF). The user also has the option to withhold a subset of samples",
+ " for extra validation purposes. Additionally, it allows a user to predict the class labels of new samples (unlabeled samples within the imported dataset).",
+ " Features should be selected based on the user's own judgement or prior knowledge. Note, selection of features based on overall ranks",
+ " (AUC, t-statistic, or fold-change) increases the risk of model-overfitting. These features may be the best biomarkers for a user's own data,",
+ " but not for new samples. Additionally, in order to get a decent ROC curve for validation, it is recommended that the hold-out data contains a balanced number",
+ " of samples from both groups and that it contain at least 8 hold-out samples (i.e. 4 from each group).",
+ "\n\n",
+ paste("Figure", fig.count<<-fig.count+1, ". shows the ROC curve of the created biomarker model based upon its average cross validation performance."),
+ paste("Figure", fig.count<<-fig.count+1, ". shows the predicted class probabilities of all samples using the user-created classifier."),
+ paste("Figure", fig.count<<-fig.count+1, ". shows the predictive accuracy of the user-created biomarker model."),
+ paste("Figure", fig.count<<-fig.count+1, ". shows the results of the permutation tests for the user-created biomarker model."),
+ "\n");
+
+ cat(descr, file=rnwFile, append=TRUE);
+
+ # ROC plot
+
+ modelindex <- paste(mSetObj$imgSet$roc.testcurve.name)
+ modelmethod <- paste(mSetObj$imgSet$roc.testcurve.method)
+
+ ROCplot <- c( "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$roc.testcurve.plot,"}", sep=""),
+ "\\caption{", paste("Plot of the ROC curve for the created biomarker model based upon its average performance",
+ " across all MCCV runs. The 95 percent confidence interval can be computed.", sep=""), "}",
+ "Selected model :", modelindex,
+ "Selected method :", modelmethod,
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$roc.testcurve.plot,"}", sep=""),
+ "\\end{figure}",
+ "\\clearpage"
+ );
+ cat(ROCplot, file=rnwFile, append=TRUE, sep="\n");
+
+ # Probability
+
+ modelindex2 <- paste(mSetObj$imgSet$roc.testprob.name)
+
+ probplot <- c( "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$roc.testprob.plot,"}", sep=""),
+ "\\caption{", paste("Plot of the predicted class probabilities for all samples using the created biomarker model.",
+ " Due to balanced subsampling, the classification boundary is at the center (x=0.5, dotted line)." , sep=""),"}",
+ "Selected model :", modelindex2,
+ "\\end{center}",
+ paste("\\label{", mSetObj$imgSet$roc.testprob.plot,"}", sep=""),
+ "\\end{figure}",
+ "\\clearpage"
+ );
+ cat(probplot, file=rnwFile, append=TRUE, sep="\n");
+
+ # Accuracy
+
+ acc.plot <- c( "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$roc.testpred,"}", sep=""),
+ "\\caption{", paste("Box plot of the predictive accuracy of the created biomarker model.", sep=""),"}",
+ "\\end{center}",
+ paste("\\label{", mSetObj$imgSet$roc.testpred,"}", sep=""),
+ "\\end{figure}",
+ "\\clearpage"
+ );
+ cat(acc.plot, file=rnwFile, append=TRUE, sep="\n");
+
+ # Permutation
+
+ if(is.null(mSetObj$imgSet$roc.perm.method)){
+ return()
+ }else{
+ permmethod <- paste(mSetObj$imgSet$roc.perm.method)
+
+ permplot <- c( "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$roc.perm.plot,"}", sep=""),
+ "\\caption{", paste("Plot of the permutations tests using the area under the ROC curve or the predictive accuracy",
+ " of the model as a measure of performance. The plot shows the AUC of all permutations, highlighting",
+ " the actual observed AUC in blue, along with showing the empirical p-value.", sep=""),"}",
+ "Selected permutation method :", permmethod,
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$roc.perm.plot,"}", sep=""),
+ "\\end{figure}",
+ "\\clearpage"
+ );
+ cat(permplot, file=rnwFile, append=TRUE, sep="\n");
+ }
+
+ if(is.null(mSetObj$analSet$ROCtest$pred.samples.table)){
+ return()
+ }else{
+ ROCLabelstable <- c("<<echo=false, results=tex>>=",
+ "CreateROCLabelsTable(mSet)",
+ "@");
+ cat(ROCLabelstable, file=rnwFile, append=TRUE, sep="\n");
+
+ }
+
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+
+}
+
+#'Create a table of newly classified samples
+#'@description Function to create the table of newly classified samples
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'Function to create the table of newly classified samples
+#'@export
+#'@importFrom tibble remove_rownames column_to_rownames
+ROCPredSamplesTable <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ groups <- as.data.frame(GetNewSampleGrps(mSetObj));
+ prob <- as.data.frame(GetNewSampleProbs(mSetObj));
+ predtable <- merge(prob, groups, by="row.names");
+ pred.samples.table <- predtable %>% remove_rownames %>% column_to_rownames(var="Row.names");
+ colnames(pred.samples.table) <- c("Probability", "Class Label");
+
+ mSetObj$analSet$ROCtest$pred.samples.table <- pred.samples.table;
+ .set.mSet(mSetObj);
+}
+
+
+#'Create a x-table for newly classified samples
+#'@description Report generation using Sweave
+#'Function to create a table for newly classified samples
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateROCLabelsTable<-function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+ predlabeltable <- mSetObj$analSet$ROCtest$pred.samples.table;
+ print(xtable::xtable(predlabeltable, caption="Predicted class labels with probability for new samples"), caption.placement="top", size="\\scriptsize");
+
+}
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_enrichment.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_enrichment.R
new file mode 100755
index 0000000000000000000000000000000000000000..b82012f3e7bfbbdd12fa4ff201b6a9354c3b53b5
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_enrichment.R
@@ -0,0 +1,359 @@
+#'Create report of analyses (Met Enrichment)
+#'@description Report generation using Sweave
+#'Metabolite enrichment analysis report
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param usrName Input the name of the user
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateEnrichRnwReport<-function(mSetObj, usrName){
+
+ CreateHeader(usrName);
+ CreateEnrichIntr();
+
+ CreateEnrichOverview();
+ CreateEnrichInputDoc(mSetObj);
+ CreateEnrichProcessDoc(mSetObj);
+ CreateEnrichAnalDoc();
+
+ if(mSetObj$analSet$type == "msetora"){
+ CreateEnrichORAdoc(mSetObj);
+ }else if(mSetObj$analSet$type == "msetssp"){
+ CreateEnrichSSPdoc(mSetObj);
+ CreateEnrichORAdoc(mSetObj);
+ }else{
+ CreateEnrichQEAdoc(mSetObj);
+ }
+
+ CreateRHistAppendix();
+ CreateFooter();
+}
+
+#'Create report of analyses (Met Enrichment)
+#'@description Report generation using Sweave
+#'Metabolite enrichment analysis report introduction
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateEnrichIntr <- function(){
+ descr <- c("\\section{Background}\n",
+ "MSEA or Metabolite Set Enrichment Analysis is a way to identify biologically meaningful",
+ "patterns that are significantly enriched in quantitative metabolomic data. In conventional",
+ "approaches, metabolites are evaluated individually for their significance under conditions",
+ "of study. Those compounds that have passed certain significance level are then combined to",
+ "see if any meaningful patterns can be discerned. In contrast, MSEA directly investigates if",
+ "a set of functionally related metabolites without the need to preselect compounds based on",
+ "some arbitrary cut-off threshold. It has the potential to identify subtle but consistent changes",
+ "among a group of related compounds, which may go undetected with the conventional approaches.",
+ "\n\n",
+ "Essentially, MSEA is a metabolomic version of the popular GSEA (Gene Set Enrichment Analysis)",
+ "software with its own collection of metabolite set libraries as well as an implementation of",
+ "user-friendly web-interfaces. GSEA is widely used in genomics data analysis and has proven to",
+ "be a powerful alternative to conventional approaches. For more information, please refer to",
+ "the original paper by Subramanian A, and a nice review paper by Nam D, Kim SY.",
+ "\\footnote{Subramanian\\textit{Gene set enrichment analysis: A knowledge-based approach for interpreting",
+ "genome-wide expression profiles.}, Proc Natl Acad Sci USA. 2005 102(43): 15545-50}.",
+ "\\footnote{Nam D, Kim SY. \\textit{Gene-set approach for expression pattern analysis},",
+ "Briefings in Bioinformatics. 2008 9(3): 189-197.}\n"
+ );
+ cat(descr, file=rnwFile, append=TRUE);
+}
+
+#'Create report of analyses (Met Enrichment)
+#'@description Report generation using Sweave
+#'Metabolite enrichment analysis report overview
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateEnrichOverview <- function(){
+ descr <- c("\\section{MSEA Overview}\n",
+ "Metabolite set enrichment analysis consists of four steps - data input, data processing,",
+ "data analysis, and results download. Different analysis procedures are performed based on",
+ "different input types. In addition, users can also browse and search the metabolite set",
+ "libraries as well as upload their self-defined metabolite sets for enrichment analysis.",
+ "Users can also perform metabolite name mapping between a variety of compound names, synonyms,",
+ "and major database identifiers."
+ );
+ cat(descr, file=rnwFile, append=TRUE);
+}
+
+#'Create report of analyses (Met Enrichment)
+#'@description Report generation using Sweave
+#'Metabolite enrichment analysis report data input
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateEnrichInputDoc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ descr <- c("\\section{Data Input}\n",
+ "There are three enrichment analysis algorithms offered by MSEA. Accordingly, three",
+ "different types of data inputs are required by these three approaches:\n"
+ );
+
+ cat(descr, file=rnwFile, append=TRUE);
+ descr <- c(
+ "\\begin{itemize}",
+ "\\item{A list of important compound names - entered as a one column data",
+ "(\\textit{Over Representation Analysis (ORA)});}",
+ "\\item{A single measured biofluid (urine, blood, CSF) sample- entered as",
+ "tab separated two-column data with the first column for compound name,",
+ "and the second for concentration values",
+ "(\\textit{Single Sample Profiling (SSP)});}",
+ "\\item{A compound concentration table - entered as a comma separated (.csv) file",
+ "with the each sample per row and each metabolite concentration per column.",
+ "The first column is sample names and the second column for sample phenotype labels",
+ "(\\textit{Quantitative Enrichment Analysis (QEA)})}",
+ "\\end{itemize}",
+ "\n\n");
+
+ cat(descr, file=rnwFile, append=TRUE, sep="\n");
+
+ if(mSetObj$analSet$type == "msetora"){
+ descr <- c("You selected Over Representation Analysis (ORA) which requires a list of compound",
+ "names as input. \n\n"
+ );
+ }else if(mSetObj$analSet$type == "msetssp"){
+ descr <- c("You selected Single Sample Profiling (SSP) which requires a two-column data from",
+ "measurement of a single biofluid sample. Currently, only data from blood, urine and CSF",
+ "can be analysed as restricted by the availability of reference concentration data. \n\n"
+ );
+ }else{
+ descr <- c("You selected Quantitative Enrichment Analysis (QEA) which requires a concentration table.",
+ "This is the most common data format generated from quantitative metabolomics studies.",
+ "The phenotype label can be can be discrete (binary or multi-class) or continuous. \n\n"
+ );
+ }
+
+ cat(descr, file=rnwFile, append=TRUE, sep="\n");
+}
+
+#'Create report of analyses (Met Enrichment)
+#'@description Report generation using Sweave
+#'Metabolite enrichment analysis report enrichment process
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateEnrichProcessDoc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ descr <- c("\\section{Data Process}\n",
+ "The first step is to standardize the compound labels. It is an essential step since the compound",
+ "labels will be subsequently compared with compounds contained in the metabolite set library.",
+ "MSEA has a built-in tool to convert between compound common names, synonyms, identifiers used in",
+ "HMDB ID, PubChem, ChEBI, BiGG, METLIN, KEGG, or Reactome.",
+ "\\textbf{Table 1} shows the conversion results. Note: \\textit{1} indicates exact match, \\textit{2}",
+ "indicates approximate match, and \\textit{0} indicates no match. A text file contain the result can be",
+ "found the downloaded file \\textit{name\\_map.csv}\n\n"
+ );
+ cat(descr, file=rnwFile, append=TRUE, sep="\n");
+
+ descr <- c("<<echo=false, results=tex>>=",
+ "GetMapTable(mSet)",
+ "@",
+ "\\clearpage\n\n"
+ );
+ cat(descr, file=rnwFile, append=TRUE, sep="\n");
+
+ descr <- c("The second step is to check concentration values. For SSP analysis,",
+ "the concentration must be measured in \\textit{umol} for blood and CSF samples.",
+ "The urinary concentrations must be first converted to \\textit{umol/mmol\\_creatinine}",
+ "in order to compare with reported concentrations in literature. No missing or negative values",
+ "are allowed in SSP analysis. The concentration data for QEA analysis is more flexible.",
+ "Users can upload either the original concentration data or normalized data. Missing or negative values",
+ "are allowed (coded as \\textit{NA}) for QEA."
+ );
+ cat(descr, file=rnwFile, append=TRUE, sep="\n");
+}
+
+#'Create report of analyses (Met Enrichment)
+#'@description Report generation using Sweave
+#'Metabolite enrichment analysis report, analysis
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateEnrichAnalDoc <- function(){
+
+ descr <- c("\\section{Selection of Metabolite Set Library}\n",
+ "Before proceeding to enrichment analysis, a metabolite set library has to be chosen.",
+ "There are seven built-in libraries offered by MSEA:\n"
+ );
+ cat(descr, file=rnwFile, append=TRUE, sep="\n");
+
+ descr <- c(
+ "\\begin{itemize}",
+ "\\item{Metabolic pathway associated metabolite sets",
+ "(\\textit{currently contains 99 entries});}",
+ "\\item{Disease associated metabolite sets (reported in blood)",
+ "(\\textit{currently contains 344 entries});}",
+ "\\item{Disease associated metabolite sets (reported in urine)",
+ "(\\textit{currently contains 384 entries})}",
+ "\\item{Disease associated metabolite sets (reported in CSF)",
+ "(\\textit{currently contains 166 entries})}",
+ "\\item{Metabolite sets associated with SNPs",
+ "(\\textit{currently contains 4598 entries})}",
+ "\\item{Predicted metabolite sets based on computational enzyme knockout model",
+ "(\\textit{currently contains 912 entries})}",
+ "\\item{Metabolite sets based on locations",
+ "(\\textit{currently contains 73 entries})}",
+ "\\item{Drug pathway associated metabolite sets",
+ "(\\textit{currently contains 461 entries})}",
+ "\\end{itemize}",
+ "\n\n");
+ cat(descr, file=rnwFile, append=TRUE, sep="\n");
+
+ descr <- c("In addition, MSEA also allows user-defined metabolite sets to be uploaded to perform",
+ "enrichment analysis on arbitrary groups of compounds which researchers want to test.",
+ "The metabolite set library is simply a two-column comma separated text file with the",
+ "first column for metabolite set names and the second column for its compound names (\\textbf{must use HMDB compound name})",
+ "separated by \"; \". Please note, the",
+ "built-in libraries are mainly from human studies. The functional grouping of metabolites",
+ "may not be valid. Therefore, for data from subjects other than human being, users are",
+ "suggested to upload their self-defined metabolite set libraries for enrichment analysis."
+ );
+ cat(descr, file=rnwFile, append=TRUE, sep="\n");
+ cat("\\section{Enrichment Analysis}\n",file=rnwFile, append=TRUE, sep="\n");
+}
+
+#'Create report of analyses (Met Enrichment)
+#'@description Report generation using Sweave
+#'Metabolite enrichment analysis report, over
+#'representation analysis (ORA)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateEnrichORAdoc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ descr <- c(
+ "Over Representation Analysis (ORA) is performed when",
+ "a list of compound names is provided. The list of compound list can be obtained through",
+ "conventional feature selection methods, or from a clustering algorithm,",
+ "or from the compounds with abnormal concentrations detected in SSP,",
+ "to investigate if some biologically meaningful patterns can be identified.",
+ "\n\n",
+ "ORA was implemented using the \\textit{hypergeometric test} to evaluate whether a particular",
+ "metabolite set is represented more than expected by chance within the given compound list.",
+ "One-tailed p values are provided after adjusting for multiple testing. \\textbf{Figure 2} below",
+ "summarizes the result."
+ );
+ cat(descr, file=rnwFile, append=TRUE);
+ fig <- c( "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{",mSetObj$imgSet$ora,"}",sep=""),
+ "\\caption{Summary Plot for Over Representation Analysis (ORA)}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$ora,"}", sep=""),
+ "\\end{figure}",
+ "\\clearpage\n\n"
+ );
+ cat(fig, file=rnwFile, append=TRUE, sep="\n");
+
+ descr <- c("<<echo=false, results=tex>>=",
+ "GetORATable(mSet)",
+ "@",
+ "\\clearpage\n\n"
+ );
+ cat(descr, file=rnwFile, append=TRUE, sep="\n");
+}
+
+#'Create report of analyses (Met Enrichment)
+#'@description Report generation using Sweave
+#'Metabolite enrichment analysis report
+#'Single sampling profiling
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateEnrichSSPdoc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ descr <- c(
+ "Single Sample Profiling (SSP) is designed to detect whether certain compound",
+ "concentrations measured from a particular sample are higher or lower compared",
+ "to their normal ranges reported in literature. Those selected",
+ "compound list are then subject to over representation analysis (ORA) to see",
+ "if certain biologically meaningful patterns can be identified. Please note,",
+ "those reference concentrations could be measured from heterogeneous analytical",
+ "technologies. It is advisable to compare only to those values that were",
+ "measured by similar technologies by referring to the original literature.",
+ "By default, if measured concentration values are higher or lower",
+ "than \\textbf{all} those reported concentration ranges will be selected for",
+ "enrichment analysis. Users can overwrite the default selections by manually",
+ "selecting or de-selecting them.",
+ "\n\n",
+ "\\textbf{Table 2} shows the comparison between the measured concentrations",
+ "and the reference concentrations. \\textit{L, M, H} means to the",
+ "measured concentration are \\textit{Lower, Within (Medium), Higher} compared",
+ "to the reference values. \\textit{0} means not selected for",
+ "subsequent enrichment analysis, while \\textit{1} means the corresponding",
+ "compound was selected."
+ );
+ cat(descr, file=rnwFile, append=TRUE, sep="\n")
+ descr<-c("<<echo=false, results=tex>>=",
+ "GetSSPTable(mSet)",
+ "@",
+ "\\clearpage\n\n"
+ );
+ cat(descr, file=rnwFile, append=TRUE, sep="\n");
+}
+
+#'Create report of analyses (Met Enrichment)
+#'@description Report generation using Sweave
+#'Metabolite enrichment analysis report
+#'Quantitative enrichment analysis
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateEnrichQEAdoc<-function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ descr <- c(
+ "Quantitative enrichment analysis (QEA) will be performed when the user uploads",
+ "a concentration table. The enrichment analysis is performed using package",
+ "\\textbf{globaltest} \\footnote{Jelle J. Goeman, Sara A. van de Geer, Floor de Kort",
+ "and Hans C. van Houwelingen.\\textit{A global test for groups of genes: testing",
+ "association with a clinical outcome}, Bioinformatics Vol. 20 no. 1 2004, pages 93-99}.",
+ "It uses a generalized linear model to estimate a",
+ "\\textit{Q-statistic} for each metabolite set, which describes the correlation",
+ "between compound concentration profiles, X, and clinical outcomes, Y. The \\textit{Q statistic}",
+ "for a metabolite set is the average of the Q statistics for each metabolite in the set.",
+ "\\textbf{Figure 2} below summarizes the result."
+ );
+ cat(descr, file=rnwFile, append=TRUE);
+ fig <- c( "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{",mSetObj$imgSet$qea, "}", sep=""),
+ "\\caption{Summary plot for Quantitative Enrichment Analysis (QEA).}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$qea, "}", sep=""),
+ "\\end{figure}",
+ "\\clearpage\n\n"
+ );
+ cat(fig, file=rnwFile, append=TRUE, sep="\n");
+
+ descr <- c("<<echo=false, results=tex>>=",
+ "GetQEATable(mSet)",
+ "@",
+ "\\clearpage\n\n"
+ );
+ cat(descr, file=rnwFile, append=TRUE, sep="\n");
+}
\ No newline at end of file
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_integmex.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_integmex.R
new file mode 100755
index 0000000000000000000000000000000000000000..bc1e37e27c09ffe0538792cd6bb67d23b98753c7
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_integmex.R
@@ -0,0 +1,237 @@
+#'Create report of analyses (IntegPathwayAnalysis)
+#'@description Report generation using Sweave
+#'Puts together the analysis report
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param usrName Input the name of the user
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateIntegPathwayAnalysisRnwReport<-function(mSetObj, usrName){
+
+ CreateHeader(usrName);
+ CreateIntegratedPathwayAnalIntr();
+
+ CreateIntegratedPathwayAnalInputDoc(mSetObj);
+
+ CreateIntegratedPathwayDoc(mSetObj);
+
+ CreateRHistAppendix();
+ CreateFooter();
+}
+
+#'Create integrated pathway analysis report: Introduction
+#'@description Report generation using Sweave
+#'Integrated pathwayr analysis report introduction
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateIntegratedPathwayAnalIntr <- function(){
+ descr <- c("\\section{Background}\n",
+ "This module performs integrated metabolic pathway analysis on results obtained from combined metabolomics ",
+ "and gene expression studies conducted under the same experimental conditions. This approach exploits KEGG metabolic ",
+ "pathway models to complete the analysis. The underlying assumption behind this module is that by combining evidence ",
+ "from both changes in gene expression and metabolite concentrations, one is more likely to pinpoint the pathways involved ",
+ "in the underlying biological processes. To this end, users need to supply a list of genes and metabolites of interest that",
+ " have been identified from the same samples or obtained under similar conditions. The metabolite list can be selected from the results",
+ " of a previous analysis downloaded from MetaboAnalyst. Similarly, the gene list can be easily obtained using many excellent web-based",
+ " tools such as GEPAS or INVEX. After users have uploaded their data, the genes and metabolites are then mapped to KEGG metabolic pathways for",
+ " over-representation analysis and pathway topology analysis. Topology analysis uses the structure of a given pathway to evaluate the relative",
+ " importance of the genes/compounds based on their relative location. Inputting the name of a specific pathway will generate a graphical representation",
+ " of that pathway highlighted with the matched genes/metabolites. Users must keep in mind that unlike transcriptomics, where the entire transcriptome",
+ " is routinely mapped, current metabolomic technologies only capture a small portion of the metabolome. This difference can lead to potentially biased",
+ " results. To address this issue, the current implementation of this omic integration module allows users to explore the enriched pathways based either",
+ " on joint evidence or on the evidence obtained from one particular omic platform for comparison.\n"
+ );
+ cat(descr, file=rnwFile, append=TRUE);
+}
+
+#'Create integrated pathway report: Data Input
+#'@description Report generation using Sweave
+#'integrated pathway report, data input documentation.
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jasmine Chong
+#'McGill University, viewingCanada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateIntegratedPathwayAnalInputDoc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ descr <- c("\\section{Data Input}\n",
+ "The integrated pathway analysis module accepts a gene list with optional fold changes, the ID type must either be an Entrez ID,",
+ " a RefSeq ID, a Genbank Accession Number, a ENSEMBL Gene Accession Number, or an Official Gene Symbol. The module also accepts ",
+ "a metabolite list, with optional fold changes. Here, the ID type must be the compound name, the HMDB ID, or the KEGG ID. Finally",
+ " the organism must be specified, either Homo sapiens (human), Mus musculus (mouse), or Rattus norvegicus (rat). The genes and the metabolites",
+ " will be mapped to the respective databases collected within MetaboAnalyst. ",
+ "\n\n");
+
+ cat(descr, file=rnwFile, append=TRUE);
+
+ if(exists('map.table', where=mSetObj$dataSet)){
+ nametable<-c("<<echo=false, results=tex>>=",
+ "CreateIntegratedPathwayNameMapTable(mSet)",
+ "@");
+ cat(nametable, file=rnwFile, append=TRUE, sep="\n");
+ }
+
+ if (exists('gene.map.table', where=mSetObj$dataSet)){
+
+ genetable<-c("<<echo=false, results=tex>>=",
+ "CreateIntegratedPathwayGeneMapTable(mSet)",
+ "@");
+ cat(genetable, file=rnwFile, append=TRUE, sep="\n");
+ }
+
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+}
+
+#'Create a x-table for compound name mapping
+#'@description Report generation using Sweave
+#'Function to create a table for compound name mapping
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateIntegratedPathwayNameMapTable <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ namemapped <- mSetObj$dataSet$map.table;
+
+ colnames(namemapped) <- c("Query", "Match", "HMDB", "PubChem", "KEGG", "Comment");
+
+ print(xtable::xtable(namemapped, caption="Compound Name Mapping"), caption.placement="top", size="\\scriptsize");
+
+}
+
+#'Create a x-table for gene name mapping
+#'@description Report generation using Sweave
+#'Function to create a table for gene name mapping
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateIntegratedPathwayGeneMapTable <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ genemapped <- mSetObj$dataSet$gene.map.table;
+
+ colnames(genemapped) <- c("Query", "Entrez", "Symbol", "Name", "Comment");
+
+ print(xtable::xtable(genemapped, caption="Gene Name Mapping"), caption.placement="top", size="\\scriptsize");
+
+}
+
+#'Create integrated pathway analysis report
+#'@description Report generation using Sweave
+#'Biomarker analysis report, ROC Curve Based Model Creation and Evaluation
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateIntegratedPathwayDoc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+ if(is.null(mSetObj$dataSet$path.mat)){
+ return()
+ }
+
+ descr <- c("\\section{Integrated Pathway Analysis Overview}\n",
+ "The aim of Integrated Pathway Analysis is to perform integrated metabolic pathway analysis on results obtained from combined metabolomics and gene expression",
+ " studies conducted under the same experimental conditions. Users must select the method of enrichment analysis, which aims to evaluate whether the observed genes",
+ " and metabolites in a particular pathway are significantly enriched (appear more than expected by random chance) within the dataset. Users can choose ",
+ "over-representation analysis (ORA) based on either hypergenometrics analysis or Fisher's exact method.",
+ " Users must also select the method for topology analysis, which aims to evaluate whether a given gene or metabolite plays an important role in a biological",
+ "response based on its position within a pathway. One method is Degree Centrality, which measures the number of links that connect to a node (representing either",
+ " a gene or metabolite) within a pathway. A second method is Closeness Centrality, which measures the overall distance from a given node to all other nodes in a pathway.",
+ " Finally there is Betweenness Centrality, which measures the number of shortest paths from all nodes to all the others that pass through a given node within a pathway.",
+ " Users must finally choose one of three different kinds of pathways for analysis: the gene-metabolite mode (default) which allows for joint-analysis and visualization",
+ " of both significant genes and metabolites. There are also gene-centric or metabolite-centric pathways which allows users to identify enriched pathways",
+ " driven by significant genes or metabolites, respectively.",
+ "\n\n");
+
+ cat(descr, file=rnwFile, append=TRUE);
+
+ # PlotInmexPath
+ descr <- c("\\section{Pathway Analysis Result}\n",
+ "The results from pathway analysis are presented graphically as well as in a detailed table.",
+ "The graphical output contains three levels of view: \\textbf{overview}, \\textbf{pathway view},",
+ "and \\textbf{molecule view}. Only the overview is shown below.",
+ "Pathway views and molecule views are generated dynamically based on your interactions with the",
+ "visualization system. They are available in your downloaded files. \n",
+ paste("Figure", fig.count<<-fig.count+1, " shows the overview of all pathways with hits to your queries."),
+ paste("Figure", fig.count<<-fig.count+1, " shows the last pathway you inspected."),
+ "\n"
+ );
+ cat(descr, file=rnwFile, append=TRUE, sep="\n");
+ fig <- c( "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{",mSetObj$imgSet$path.overview,"}",sep=""),
+ "\\caption{Summary of Joint Pathway Analysis}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$path.overview,"}", sep=""),
+ "\\end{figure}",
+ "\\clearpage\n\n"
+ );
+ cat(fig, file=rnwFile, append=TRUE, sep="\n");
+
+ # PlotReKEGGPath
+
+ if(!is.null(mSetObj$imgSet$pathinteg.path)){
+ rekeggplot <- c( "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$pathinteg.path,"}", sep=""),
+ "\\caption{", paste("A selected pathway from the joint pathway analysis.",
+ " The matched nodes are highlighted in different colors - red (upregulated), yellow (unknown), green (downregulated)",
+ " based on fold change (FC) values.", sep=""),"}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$pathinteg.path,"}", sep=""),
+ "\\end{figure}",
+ "\\clearpage"
+ );
+ cat(rekeggplot, file=rnwFile, append=TRUE, sep="\n");
+ }
+
+ if(is.null(mSetObj$dataSet$path.mat)){
+ return()
+ }else{
+ resultstable<-c("<<echo=false, results=tex>>=",
+ "CreateIntegratedPathwayResultsTable(mSet)",
+ "@");
+ cat(resultstable, file=rnwFile, append=TRUE, sep="\n");
+
+ }
+
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+
+}
+
+#'Create a x-table for pathway results
+#'@description Report generation using Sweave
+#'Function to create a table for pathway results
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateIntegratedPathwayResultsTable <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ results <- mSetObj$dataSet$path.mat;
+ colnames(results) <- c("Total", "Expected", "Hits", "Raw p", "-log10(p)", "Holm adjust", "FDR", "Impact");
+ path.nms <- names(rownames(results));
+ rownames(results) <- path.nms;
+
+ print(xtable::xtable(results, caption="Enriched pathways based on the integrated pathway analysis."), caption.placement="top", size="\\scriptsize");
+
+}
+
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_meta_analysis.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_meta_analysis.R
new file mode 100755
index 0000000000000000000000000000000000000000..6ea478930bf576d63d4e74698bede1eae6fe6394
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_meta_analysis.R
@@ -0,0 +1,324 @@
+#'Create report of analyses (Meta-Analysis)
+#'@description Report generation using Sweave
+#'Puts together the analysis report
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param usrName Input the name of the user
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateMetaAnalysisRnwReport<-function(mSetObj, usrName){
+
+ CreateHeader(usrName);
+ CreateMetaAnalysisIntr();
+ CreateMetaAnalysisOverview();
+
+ CreateMetaAnalysisInputDoc(mSetObj);
+ CreateMetaAnalysisNORMdoc(mSetObj);
+ CreateMetaAnalysisDEdoc(mSetObj);
+
+ CreateMetaAnalysisOutput(mSetObj);
+ CreateRHistAppendix();
+ CreateFooter();
+
+}
+
+#'Create MetaAnalysis analysis report: Introduction
+#'@description Report generation using Sweave
+#'MetaAnalysis analysis report introduction
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateMetaAnalysisIntr<-function(){
+ descr <- c("\\section{Background}\n",
+ "The combination of multiple independent metabolomics studies investigating the same condition in similar populations, ",
+ "which is often termed horizontal integration, or metabolomic meta-analysis. The aim of metabolomic ",
+ "meta-analysis is to leverage the collective power of multiple studies to overcome potential noise, bias, and small ",
+ "effect sizes to improve the precision in identifying true patterns within data. Specifically, biomarker ",
+ "identification remains a large area of research in metabolomics, and their validation is challenging due to ",
+ "inconsistencies in identified biomarkers amongst similar experiments. Performing meta-analysis across similar ",
+ "studies will thereby increase the sample size and the power to identify robust and precise biomarkers of disease. ",
+ " The aim of the Meta-Analysis module for the integration of individual metabolomic studies to identify consistent and ",
+ "robust biomarkers of disease. This module supports three methods for performing meta-analysis: 1) Combining p-values,",
+ " 2) Vote counting, and 3) Direct merging of data into a mega-dataset.\n"
+ );
+ cat(descr, file=rnwFile, append=TRUE);
+}
+
+#'Create MetaAnalysis analysis report: Overview
+#'@description Report generation using Sweave
+#'Power analysis report overview
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateMetaAnalysisOverview <- function(){
+ descr <- c("\\section{Meta-Analysis Overview}\n",
+ "The Meta-Analysis module consists of six steps: 1) uploading the individual datasets; 2) data processing of each individual dataset,",
+ " however it is suggested that the data-processing steps are consistent amongst the studies; 3) differential expression analysis of individual datasets; ",
+ "4) data integrity check prior to meta-analysis ; 5) selection of the statistical method for meta-analysis, ",
+ "and 6) visualization of results as a Venn diagram to view all possible combinations of shared features between the datasets. \n"
+ );
+ cat(descr, file=rnwFile, append=TRUE);
+}
+
+#'Create MetaAnalysis analysis report: Data Input
+#'@description Report generation using Sweave
+#'Power analysis report, data input documentation.
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateMetaAnalysisInputDoc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ descr <- c("\\section{Data Input}\n",
+ "The Meta-Analysis module accepts individual datasets which must be prepared by users prior to being uploaded. ",
+ "In general, the datasets must have been collected under comparable experimental conditions/share the same hypothesis",
+ " or have the same mechanistic underpinnings. At the moment, the module only supports two-group comparisons (ex: control vs disease).",
+ "Further, the module accepts either a compound concentration table, spectral binned data, or a peak intensity",
+ " table. The format of the data must be specified, identifying whether the samples are in rows or columns, ",
+ "or may either be .csv or .txt files.",
+ " \n\n");
+
+ cat(descr, file=rnwFile, append=TRUE);
+
+ descr<-c("\\subsubsection{Sanity Check}\n",
+ " Before data analysis, a sanity check is performed to make sure that all of the necessary",
+ " information has been collected. The class labels must be present and must contain only two classes.",
+ " If the samples are paired, the class label must be from -n/2 to -1 for one group, and 1 to n/2 for the second group",
+ " (n is the sample number and must be an even number). Class labels with the same absolute value are assumed to be pairs.",
+ " Compound concentration or peak intensity values must all be non-negative numbers.",
+ " By default, all missing values, zeros and negative values will be replaced by the half of the minimum positive value",
+ " found within the data (see next section).");
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+}
+
+#'Create MetaAnalysis analysis report: Data Normalization
+#'@description Report generation using Sweave
+#'Meta-Analysis, data normalization documentation.
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateMetaAnalysisNORMdoc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ descr<-c("\\subsubsection{Normalization of Individual Data}\n",
+ " Before differential expression analysis, datasets may be normalized using Log2 transformation.",
+ " Additionally, users may choose to auto-scale their data."
+ );
+ cat(descr, file=rnwFile, append=TRUE);
+
+ if(exists("norm.msg")){
+ norm.desc <- paste(norm.msg);
+ }else{
+ norm.desc <- " No normalization methods were applied.";
+ }
+ cat(norm.desc, file=rnwFile, append=TRUE, sep="\n");
+
+ if(mSetObj$dataSet$auto_opt == 1){
+ autoscale <- " Autoscaling of data was performed.";
+ }else{
+ autoscale <- " No data autoscaling was performed.";
+ }
+ cat(autoscale, file=rnwFile, append=TRUE, sep="\n");
+}
+
+#'Create MetaAnalysis analysis report: Data Normalization
+#'@description Report generation using Sweave
+#'Meta-Analysis, data normalization documentation.
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateMetaAnalysisDEdoc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ descr<-c("\\subsubsection{Differential Expression Analysis of Individual Data}\n",
+ " Before meta-analysis, differential expression analysis using linear models (Limma) may be performed",
+ " for exploratory analysis. Here, users must specify the p-value (FDR) cut-off and the fold-change (FC) cutoff."
+ );
+ cat(descr, file=rnwFile, append=TRUE);
+
+ if(!is.null(mSetObj$dataSet[["deparam"]])){
+ de.desc <- paste(mSetObj$dataSet$deparam);
+ }else{
+ de.desc <- " No differential-expression analysis was performed."
+ }
+ cat(de.desc, file=rnwFile, append=TRUE, sep="\n");
+
+ if(!is.null(mSetObj$dataSet[["desig"]])){
+ de.sig <- paste(mSetObj$dataSet$desig);
+ cat(de.sig, file=rnwFile, append=TRUE, sep="\n");
+ }
+
+ descr<-c("\\subsection{Data Integrity Check}\n",
+ " Before meta-analysis, one final data integrity check is performed to ensure meta-data are consistent between datasets and",
+ " that there are at least more than 25 percent common features between the collective datasets.");
+ cat(descr, file=rnwFile, append=TRUE);
+}
+
+#'Create MetaAnalysis analysis report: Data Normalization
+#'@description Report generation using Sweave
+#'MetaAnalysis analysis, data normalization documentation.
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateMetaAnalysisOutput <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ descr<-c("\\section{Meta-Analysis Output}\n",
+ "After the data has passed the final integrity check, users have the option to select one of three methods to perform meta-analysis: ",
+ "1) Combining p-values, 2) vote counting, or 3) directly merging the datasets into a mega-dataset.");
+ cat(descr, file=rnwFile, append=TRUE);
+
+ descr<-c("\\subsection{Combining P-Values}\n",
+ "Calculating and combining p-values for the meta-analysis of microarray studies has been a long standing method and now we apply it to metabolomics studies.",
+ " It includes two popular approaches, the Fisher's method and the Stouffer's method, which have similar levels of performance",
+ " and are generally interpreted as larger scores reflecting greater differential abundance. The main difference between",
+ " the two methods are weights (which are based on sample size), which are used in the Stouffer's method but not used in the Fisher's method.",
+ " It should be noted that larger sample sizes do not warrant larger weights, as study quality can be variable. Further, users should ",
+ "use the Stouffer's method only when all studies are of similar quality.");
+ cat(descr, file=rnwFile, append=TRUE);
+
+ descr<-c("\\subsection{Vote Counting}\n",
+ "Vote counting is considered the most simple",
+ " yet most intuitive method for meta-analysis. Here, significant features are selected based on a selected criteria (i.e. an adjusted p-value",
+ " <0.05 and the same direction of FC) for each dataset. The votes are then calculated for each feature by counting the total of number of times",
+ " a feature is significant across all included datasets. However, this method is statistically inefficient and should be considered the",
+ " last resort in situations where other methods to perform meta-analysis cannot be applied.");
+ cat(descr, file=rnwFile, append=TRUE);
+
+
+ descr<-c("\\subsection{Direct Merging}\n",
+ "The final method of meta-analysis is the direct merging of individual data into",
+ " a mega-dataset, which results in an analysis of that mega-dataset as if the individual data were derived from the same experiment. This",
+ " method thereby ignores any inherent bias and heterogeneity between the different data. Because of this, there exists several confounders",
+ " such as different experimental protocols, technical platforms, and raw data processing procedures that can mask true underlying differences.",
+ " It is therefore highly suggested that this approach be used only when individual data are very similar (i.e. from the same lab, same platform,",
+ " without batch effects).");
+ cat(descr, file=rnwFile, append=TRUE);
+
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+
+ if(metastat.method=="metap"){
+ method <- paste("P-value combination was the selected method to perform meta-analysis.",
+ "The method of p-value combination used is: ", mSetObj$dataSet$pvalmethod,
+ " The p-value significance threshold is: ", mSetObj$dataSet$pvalcutoff);
+ }else if(metastat.method=="votecount"){
+ method <- paste("Vote counting was the selected method to perform meta-analysis.",
+ "The minimum vote count used is: ", mSetObj$dataSet$vote,
+ " The p-value significance threshold is: ", mSetObj$dataSet$pvalcutoff);
+ }else{
+ method <- paste("Direct merging of individual data was the selected method to perform meta-analysis.",
+ " The p-value significance threshold is: ", mSetObj$dataSet$pvalcutoff);
+
+ }
+ cat(method, file=rnwFile, append=TRUE, sep="\n");
+
+ if(is.null(mSetObj$analSet$meta.mat)){
+ return();
+ }else{
+ MetaAnalysisTable <- c("<<echo=false, results=tex>>=",
+ "CreateMetaTable(mSet)",
+ "@",
+ "\\clearpage\n\n");
+ cat(MetaAnalysisTable, file=rnwFile, append=TRUE, sep="\n");
+ }
+
+ metafeature <- mSetObj$imgSet$meta.anal$feature
+
+ if(!is.null(mSetObj$imgSet$meta.anal$plot)){
+ featplot <- c( "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$meta.anal$plot,"}", sep=""),
+ "\\caption{", paste("Box plot of the expression pattern of the selected feature between the two experimental groups across all studies.",
+ " The expression pattern is on the y-axis, and the group labels are on the x-axis.",
+ " The median expression for the feature is indicated with a black dot in the centre of the boxplot.", sep=""),"}",
+ "Selected feature: ", metafeature,
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$meta.anal$plot,"}", sep=""),
+ "\\end{figure}",
+ "\\clearpage"
+ );
+ cat(featplot, file=rnwFile, append=TRUE, sep="\n");
+ }
+
+ if(!is.null(mSetObj$imgSet$venn)){
+ featplot <- c( "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$venn,"}", sep=""),
+ "\\caption{", paste("Venn diagram of the top differentially expressed features from the meta-analysis. ",
+ "On the left side are features that are DE only from the meta-analysis,",
+ " in the center are DE features that were identified in both the meta-analysis and the individual studies, ",
+ "and on the right side are features that were DE in the individual analysis, but did not show up as DE during meta-analysis.", sep=""),"}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$venn,"}", sep=""),
+ "\\end{figure}",
+ "\\clearpage"
+ );
+ cat(featplot, file=rnwFile, append=TRUE, sep="\n");
+ }
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+
+ if(!is.null(mSetObj$analSet$sigfeat.matrix)){
+ MetaAnalysisVennTable <- c("<<echo=false, results=tex>>=",
+ "CreateVennMetaTable(mSet)",
+ "@",
+ "\\clearpage\n\n");
+ cat(MetaAnalysisVennTable, file=rnwFile, append=TRUE, sep="\n");
+ }
+
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+
+}
+
+#'Create MetaAnalysis table of results
+#'@description Report generation using Sweave
+#'Function to create a table containing meta-analysis results.
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateMetaTable <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ metatable <- mSetObj$analSet$meta.mat;
+
+ print(xtable::xtable(metatable, caption="Predicted top-ranking features from meta-analysis"), caption.placement="top", size="\\scriptsize");
+
+}
+
+#'Create MetaAnalysis table of results for Venn Diagram
+#'@description Report generation using Sweave
+#'Function to create a table containing meta-analysis results.
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateVennMetaTable <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ metatable <- mSetObj$analSet$sigfeat.matrix;
+
+ print(xtable::xtable(metatable, caption="Differentially expressed features by individual study and from meta-analysis"), caption.placement="top", size="\\scriptsize", scalebox = "0.6");
+
+}
+
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_mummichog.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_mummichog.R
new file mode 100755
index 0000000000000000000000000000000000000000..4be7179c3edeebd8b95c15efe78fcbea1276b10c
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_mummichog.R
@@ -0,0 +1,584 @@
+#'Create report of analyses (Biomarker)
+#'@description Report generation using Sweave
+#'Puts together the analysis report
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param usrName Input the name of the user
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+CreateMummichogRnwReport<-function(mSetObj, usrName){
+
+ CreateHeader(usrName);
+
+ if(exists("metaFiles")){
+ CreateMummichogMetaAnalReport(mSetObj)
+ }else{
+ CreateMummichogIntro();
+ CreateMummichogOverview();
+ CreateMummichogInputDoc(mSetObj);
+ CreateMummichogAnalysisDoc(mSetObj);
+ }
+
+ CreateRHistAppendix();
+ CreateFooter();
+}
+
+#'Create analysis report: Functional Meta-Analysis
+#'@description Report generation using Sweave
+#'Functional Meta-Analysis Report
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateMummichogMetaAnalReport<-function(mSetObj){
+ CreateMetaMummichogIntro()
+ CreateMetaMummichogInputDoc(mSetObj)
+ CreateMetaMummichogResults(mSetObj)
+}
+
+#'Create analysis report: Functional Meta-Analysis Introduction
+#'@description Report generation using Sweave
+#'Mummichog analysis report introduction
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateMetaMummichogIntro <- function(){
+
+ back.descr <- c("\\section{Background}\n",
+ "Metabolomics is becoming an increasingly popular tool for biological research, however while individual studies may identify certain biological functions to be important,",
+ " such results may not be reproducible in other independent studies researching the same biological question due to low sample size, sample heterogeneity,",
+ " the type of LC-MS platform used, or even metrics used for interpreting results. Meta-analysis, which is the combination of findings from independent studies,",
+ " can be used to overcome such limitations and ultimately increase the power, precision, and generalizability of a single study.",
+ "With the increased use of metabolomics and global efforts towards science transparency and reproducibility, the amount of publicly available metabolomics data deposited in",
+ " dedicated metabolomics repositories such as The Metabolomics Workbench, MetaboLights and OmicsDI has grown tremendously. The potential for researchers in the",
+ " metabolomics community to enhance their findings with publicly available data is immense, but little effort has been applied for the meta-analysis of untargeted",
+ " metabolomics data. Such a method would also reduce the bias individual studies may carry towards specific sample processing protocols or LC-MS instruments. \n"
+ );
+ cat(back.descr, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+ mum.descr <- c("\\section{Algorithm Overview}\n",
+ "High-resolution LC-MS has become dominant platform for global metabolomics. The typical LC-MS workflow starts with data acquisition, followed by data pre-processing,",
+ " feature selection, compound identification and then pathway analysis. However, peak identification requires significant effort and is a major challenge for downstream",
+ " functional interpretation. One strategy is to completely bypass the bottleneck of metabolite identification and directly infer functional activity from MS peaks by leveraging",
+ " the collective knowledge of metabolic pathways and networks. This is the idea of the mummichog algorithm (Li et al. 2013). Using this algorithm, a list of significant peaks,",
+ " are matched to potential compounds using their molecular weight considering different adducts/isotopes. These putatively matched compounds are then mapped onto known biological pathways.",
+ "If a list of truly significant features reflect biological activity, then the representation of these true metabolites would be enriched on functional structures,",
+ " while false matches would be distributed at random. We have extended this idea to support the meta-analysis of untargeted metabolomics data. \n"
+
+ );
+ cat(mum.descr, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+ meta.descr <- c("\\section{Functional Meta-Analysis Workflow}\n",
+ "The Functional Meta-Analysis module supports meta-analysis at either i) the pathway level or ii) by pooling all MS peaks. Each method of integration has their own merits,",
+ " for instance at the pathway level, compounds do not have to be matched across all studies whereas pooling all MS peaks will better bring out weaker signals.",
+ "The workflow also considers data heterogeneity, meaning that the accuracy of the LC-MS instrument and the MS ionization mode are taken into account when performing putative",
+ " metabolite annotation. Ultimately, the goal of this workflow is to enable the reuse/repurposong of multiple datasets to identify a robust meta-signature for the phenotype in question. \n"
+
+ );
+ cat(meta.descr, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+ descr <- c("\\section{Functional Meta-Analysis Overview}\n",
+ "The Functional Meta-Analysis module consists of three steps - 1) uploading the user's data, 2) parameter selection,",
+ " and 3) functional enrichment meta-analysis. \n"
+ );
+ cat(descr, file=rnwFile, append=TRUE);
+}
+
+#'Create analysis report: Functional Meta-Analysis Data Input
+#'@description Report generation using Sweave
+#'Mummichog analysis report, data input documentation.
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateMetaMummichogInputDoc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ descr <- c("\\section{Data Input}\n",
+ "The Functional Meta-Analysis module accepts multiple peak tables with or without retention time information.",
+ "All inputted files must be in .csv format. \n");
+
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+ sanity_msg <- vector("list")
+
+ for(i in 1:length(metaFiles)){
+ metaSetObj <- qs::qread(metaFiles[i])
+ sanity_msg[metaFiles[i]] <- paste0(gsub("mummichoginput.qs", "", metaFiles[i]), ": ", paste0(metaSetObj$msgSet$check.msg, collapse = " "))
+ }
+
+ cat(unlist(sanity_msg), file=rnwFile, append=TRUE, sep="\n");
+
+ if(exists("mum.version")){
+
+ descr <- c("\\subsubsection{Parameters}\n",
+ "Depending on the meta-analysis method, users must select the algorithm (original mummichog or GSEA), p-value cutoff",
+ " to delineate between significantly and non-significantly enriched pathways (pathway-level only), and pathway library used.",
+ " Currently, MetaboAnalyst 5.0 only supports the handling of peaks obtained from high-resolution MS instruments",
+ " such as Orbitrap, or Fourier Transform (FT)-MS instruments as recommended by the original mummichog implementation.",
+ "\n");
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+ if(mSetObj$metaLevel == "pathway"){
+ if(!is.null("mSet$meta_results")){
+ # pathway level
+ metaLevel <- paste("The selected method for meta-analysis is 'Pathway-Level Integration'.")
+ anal.descr <- paste("The selected algorithm is: ", anal.type, ".", sep = "");
+ integ.desrc <- paste("The selected p-value cutoff for integrating pathways is: ", mSetObj$meta.pval.method, ".", sep = "");
+
+ cat(anal.descr, file=rnwFile, append=TRUE, sep="\n");
+ cat(metaLevel, file=rnwFile, append=TRUE, sep="\n");
+ cat(integ.desrc, file=rnwFile, append=TRUE, sep="\n");
+ }
+ }else{
+ # pooled
+ metaLevel <- paste("The selected method for meta-analysis is 'Pooled Peaks'.")
+ anal.descr <- paste("The selected algorithm is: ", anal.type, " ", mum.version, ".", sep = "");
+ pval.descr <- paste("The selected p-value cutoff: ", mSetObj$pooled_cutoff, ".", sep = "");
+
+ cat(metaLevel, file=rnwFile, append=TRUE, sep="\n");
+ cat(anal.descr, file=rnwFile, append=TRUE, sep="\n");
+ cat(pval.descr, file=rnwFile, append=TRUE, sep="\n");
+ }
+ }
+
+ if(!is.null(mSetObj$lib.organism)){
+
+ descr <- c("\\subsubsection{Pathway Library}\n",
+ "The knowledge-base for this module consists of five genome-scale metabolic models obtained",
+ " from the original Python implementation which have either been manually curated or downloaded from BioCyc,",
+ " as well as an expanded library of 21 organisms derived from KEGG metabolic pathways. ",
+ "Users must select one of 21 KEGG pathway libraries, or one of five metabolic models.\n");
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+ mum.descr <- paste("The user's selected library is: ", gsub("_", ".", mSetObj$lib.organism), ".");
+
+ cat(mum.descr, file=rnwFile, append=TRUE, sep="\n");
+
+ }
+
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+}
+
+#'Create analysis report: Functional Meta-Analysis Results
+#'@description Report generation using Sweave
+#'Mummichog analysis report overview
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateMetaMummichogResults <- function(mSetObj){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(mSetObj$metaLevel == "pathway"){
+
+ if(!is.null("mSet$meta_results")){
+ descr <- c("\\section{Pathway-Level Integration Results}\n",
+ "The aim of the Pathway-Level Integration method is to improve the biological consistency across studies to identify a robust meta-signature for the phenotype in question.",
+ " For pathway-level integration, each individual study undergoes the steps of calculating m/z level statistics and",
+ " putative metabolite annotation, followed by pathway activity prediction to ultimately create a unified matrix of pathway-level results (keeping only pathways found across all-studies).",
+ " Pathway activity scores are then combined using one of several p-value integration methods. \n");
+ cat(descr, file=rnwFile, append=TRUE);
+ }
+
+ if(!is.null(mSetObj$imgSet$mummi.meta.path.plot)){
+
+ descr <- c("\\subsection{Pathway-Level Integration Plot}\n",
+ "The bubble plot below represents the results of the Pathway-Level Integration. The plot displays all matched pathways per study as circles.",
+ "The color and size of each circle corresponds to its p-value and enrichment factor, respectively. The enrichment factor of a pathway is calculated as the ratio between the number of significant",
+ " hits and the expected number of hits within the pathway. \n");
+ cat(descr, file=rnwFile, append=TRUE);
+
+ fig <- c( "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{",mSetObj$imgSet$mummi.meta.path.plot,"}",sep=""),
+ "\\caption{Summary of Pathway-Level Integration Meta-Analysis}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$mummi.meta.path.plot,"}", sep=""),
+ "\\end{figure}",
+ "\\clearpage\n\n"
+ );
+ cat(fig, file=rnwFile, append=TRUE, sep="\n");
+
+ descr <- c("\\subsection{Pathway-Level Integration Meta-Analysis Results Table}\n",
+ "The output of the Pathway-Level Integration Meta-Analysis consists of a table of results containing ranked pathways that are enriched in ",
+ "the user-uploaded datasets. The table includes the raw p-values (per individual study), the mean enrichment ratio and finally the integrated p-value (Meta.P). \n");
+ cat(descr, file=rnwFile, append=TRUE);
+
+ pathMetatable<-c("<<echo=false, results=tex>>=",
+ "CreateMummichogMetaAnalPathTable(mSet)",
+ "@",
+ "\\clearpage\n\n");
+ cat(pathMetatable, file=rnwFile, append=TRUE, sep="\n");
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+ }
+ }else{
+
+ descr <- c("\\section{Pooled Peaks Results}\n",
+ "The aim of of the Pooling Peaks method is to computationally combine the outputs from different instruments that measure the same set of samples.",
+ " In this case, all uploaded peaks are merged into a single input for putative compound annotation (with consideration for different mass tolerances)",
+ " followed by pathway activity prediction. This method should be used when samples are homogeneous but instruments are complementary,",
+ " for instance samples that comes from the same lab but were obtained using different columns, extraction methods or data collected using complementary LC-MS instruments. \n");
+ cat(descr, file=rnwFile, append=TRUE);
+
+ CreateMummichogAnalysisDoc(mSetObj)
+ }
+}
+
+#'Create analysis report: Functional Meta-Analysis Results Table
+#'@description Report generation using Sweave
+#'Function to create a summary table of mummichog analysis
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateMummichogMetaAnalPathTable <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ mummitable <- mSetObj$meta_results
+ print(xtable::xtable(mummitable, caption="Results of the Pathway-Level Integration Meta-Analysis"), caption.placement="top", size="\\scriptsize");
+}
+
+####################################################
+####################################################
+
+#'Create mummichog analysis report: Introduction
+#'@description Report generation using Sweave
+#'Mummichog analysis report introduction
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateMummichogIntro <- function(){
+ descr <- c("\\section{Background}\n",
+ "Even with high mass accuracy afforded by current high-resolution MS platforms, it is often impossible to uniquely identify a given peak based on its ",
+ "mass alone. To get around this issue, a key concept is to shift the unit of analysis from individual compounds to individual pathways or a group of ",
+ "functionally related compounds (i.e. metabolite sets (PMID: 20457745)). The general assumption is that the collective behavior of a group is more ",
+ "robust against a certain degree of random errors of individuals. The mummichog algorithm is the first implementation of this concept to infer ",
+ "pathway activities from a ranked list of MS peaks identified by untargeted metabolomics. The original algorithm implements an over-representation analysis (ORA) ",
+ "method to evaluate pathway-level enrichment based on significant features. Users need to specify a pre-defined cutoff based on p-values. ",
+ "For further details about the original implementation, please refer to Li et al. 2013 (PMC3701697). ",
+ "A complementary approach is the Gene Set Enrichment Analysis (GSEA) method, a widely used method to extract biological ",
+ "meaning from a ranked gene list (PMID: 16199517). Unlike ORA, this method considers the overall ranks of MS peaks without using a significance cutoff. ",
+ "It is able to detect subtle and consistent changes which can be missed from ORA methods. Both the mummichog algorithm (Version 1.0.10), ",
+ "which has been carefully translated from the Python programming to R, and the adapted GSEA method have been implemented in the MS Peaks to Paths module. ",
+ "The module also includes an expanded knowledgebase of 21 organisms for pathway analysis.\n"
+ );
+ cat(descr, file=rnwFile, append=TRUE);
+}
+
+#'Create Mummichog analysis report: Overview
+#'@description Report generation using Sweave
+#'Mummichog analysis report overview
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateMummichogOverview <- function(){
+ descr <- c("\\section{Overview}\n",
+ "The MS Peaks to Pathways module consists of three steps - uploading the user's data, selection of a pathway library,",
+ " and pathway analysis. \n"
+ );
+ cat(descr, file=rnwFile, append=TRUE);
+}
+
+#'Create Mummichog analysis report: Data Input
+#'@description Report generation using Sweave
+#'Mummichog analysis report, data input documentation.
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateMummichogInputDoc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ descr <- c("\\section{Data Input}\n",
+ "The MS Peaks to Pathways module accepts either a three column table containing the m/z features, p-values, and statistical scores,",
+ " a two-column table containing m/z features and either p-values or t-scores, or a one-column table ranked by either",
+ " p-values or t-scores. All inputted files must be in .txt format. If the input is a three column table, both the mummichog",
+ " and GSEA algorithms can be applied. If only p-values (or ranked by p-values) are provided, only the mummichog algorithm will be applied.",
+ " If only t-scores (or ranked by t-scores) are provided, only the GSEA algorithm will be applied.",
+ " \n\n");
+
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+ cat(mSetObj$msgSet$check.msg, file=rnwFile, append=TRUE, sep="\n");
+
+ if(!is.null(mSetObj$dataSet$instrument)){
+
+ descr <- c("\\subsubsection{Parameters}\n",
+ "Users also need to specify the mass accuracy (ppm), the ion mode (positive or negative), and the p-value cutoff",
+ " to delineate between significantly enriched and non-significantly enriched m/z features (for mummichog only). ",
+ "Currently, MetaboAnalyst 5.0 only supports the handling of peaks obtained from high-resolution MS instruments",
+ " such as Orbitrap, or Fourier Transform (FT)-MS instruments as recommended by the original mummichog implementation.",
+ "\n");
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+ mum.descr <- paste("The selected p-value cutoff is: ",mSetObj$dataSet$cutoff , ".", sep = "");
+
+ cat(mum.descr, file=rnwFile, append=TRUE, sep="\n");
+
+ }
+
+ if(!is.null(mSetObj$lib.organism)){
+
+ descr <- c("\\subsubsection{Library}\n",
+ "The knowledge-base for this module consists of five genome-scale metabolic models obtained",
+ " from the original Python implementation which have either been manually curated or downloaded from BioCyc,",
+ " an expanded library of 21 organisms derived from KEGG metabolic pathways, and 10 distinct metabolite set libraries. ",
+ "Users must select one of 21 KEGG pathway libraries, or one of five metabolic models.\n");
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+ mum.descr <- paste("The user's selected library is: ", mSetObj$lib.organism, ".");
+
+ cat(mum.descr, file=rnwFile, append=TRUE, sep="\n");
+
+ }
+
+ if(!is.null(mSetObj$curr.cust) && mSetObj$curr.cust){
+
+ descr.cust <- c("\\subsubsection{Analysis Customization}\n",
+ "The aim of this module is to use the mummichog algorithm (Li et al. 2013) to predict pathway-level activity from untargeted",
+ "metabolomics, bypassing the need for conventional metabolite identification prior",
+ "to functional enrichment analysis. In brief, the algorithm uses the collective power of the organizational",
+ "structure of metabolic pathways/networks and maps m/z features, including all of its adducts and forms, onto",
+ "these structures to infer activity. Here, the assumption is that if a list of significant m/z features truly reflects",
+ "biological activity, then the true metabolites will show enrichment on the pathways/networks, while falsely matched",
+ "metabolites will be more randomly distributed.\n");
+ cat(descr.cust, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+ descr.curr <- c("\\subsubsection{Analysis Customization: Currency Metabolites}\n",
+ "Currency metabolites are abundant substances such as water and carbon dioxide known to occur in normal",
+ " functioning cells and participate in a large number of metabolic reactions (Huss and Holme 2007, PMID 17907676). ",
+ "Because of their ubiquitous nature, they will be removed from further analysis. There is no formal consensus of a set of currency ",
+ "metabolites, therefore users who are unsatisfied with the default list of currency metabolites",
+ " are provided an option to select the metabolites to use as currency.\n");
+ cat(descr.curr, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+ curr.desc <- paste("The user's selected list of currency metabolites is: ", currency, ".");
+ cat(curr.desc, file=rnwFile, append=TRUE, sep="\n");
+
+ descr.add <- c("\\subsubsection{Analysis Customization: Adducts}\n",
+ "In addition to pathway information, the mummichog libraries contain a set of adducts tailored to the analytical mode of the MS instrument.",
+ "These options however, may not be optimal for users data, therefore users are provided the option",
+ "to customize the adduct list used in the mummichog analysis.\n");
+ cat(descr.add, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+ }
+
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+}
+
+#'Create Mummichog report of analyses
+#'@description Report generation using Sweave
+#'Function to create a summary table of mummichog analysis
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateMummichogAnalTable <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+ mummitable <- mSetObj$mummi.resmat
+ print(xtable::xtable(mummitable, caption="Results of the Mummichog Pathway Analysis"), caption.placement="top", size="\\scriptsize");
+
+}
+
+#'Create Mummichog report of analyses
+#'@description Report generation using Sweave
+#'Function to create a summary table of mummichog analysis
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateGSEAAnalTable <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+ mummitable <- mSetObj$mummi.gsea.resmat
+ print(xtable::xtable(mummitable, caption="Results of the GSEA Pathway Analysis"), caption.placement="top", size="\\scriptsize");
+
+}
+
+#'Create Mummichog report of analyses
+#'@description Report generation using Sweave
+#'Function to create a summary table of mummichog analysis
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateMetaAnalTable <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+ mummitable <- mSetObj$integ.resmat
+ print(xtable::xtable(mummitable, caption="Meta-Analysis of Mummichog and GSEA Results"), caption.placement="top", size="\\scriptsize");
+
+}
+
+#'Create mummichog analysis report
+#'@description Report generation using Sweave
+#'Mummichog analysis report
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateMummichogAnalysisDoc<-function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(!is.null(mSetObj$mummi.resmat)){
+
+ descr <- c("\\section{Mummichog Output}\n",
+ "The aim of of this module is to leverage the power of known metabolic models/pathways to gain functional insight ",
+ "directly from m/z features. There are three steps for the mummichog algorithm, 1) Permutations: A list of metabolites (the same length as the number ",
+ "of significant m/z features) are inferred from the user's uploaded set of m/z features, considering all potential matches ",
+ "(isotopes/adducts). These tentative compounds are then mapped onto known metabolic pathways for the selected organism. ",
+ "For each pathway, a hypergeometric p-value is calculated.",
+ " 2) Step 1 is repeated multiple times to calculate the null distribution of p-values for all pathways, and ",
+ "is modeled as a Gamma distribution. 3) Following this, the significant m/z features are used to calculate the p-values for each pathway (Step 1).",
+ " These p-values are then adjusted for the permutations. \n");
+ cat(descr, file=rnwFile, append=TRUE);
+
+ # Because mummi.resmat is created for meta-analysis
+ if(!is.null(mSetObj$imgSet$mummi.plot)){
+
+ descr <- c("\\subsection{Mummichog Pathway Analysis Plot}\n",
+ "The pathway summary plot below displays all matched pathways as circles. The color and size of each circle corresponds",
+ " to its p-value and enrichment factor, respectively. The enrichment factor of a pathway is calculated as the ratio between the number of significant",
+ " pathway hits and the expected number of compound hits within the pathway. \n");
+ cat(descr, file=rnwFile, append=TRUE);
+
+ fig <- c( "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{",mSetObj$imgSet$mummi.plot,"}",sep=""),
+ "\\caption{Summary of Pathway Analysis}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$mummi.plot,"}", sep=""),
+ "\\end{figure}",
+ "\\clearpage\n\n"
+ );
+ cat(fig, file=rnwFile, append=TRUE, sep="\n");
+ }
+
+ descr <- c("\\subsection{Mummichog Pathway Analysis Results Table}\n",
+ "The output of the mummichog analysis consists of a table of results containing ranked pathways that are enriched in ",
+ "the user-uploaded data. The table includes the total number of hits per pathway (all, significant, and expected), the raw p-values (",
+ "Hypergeometric), and the p-value modeled on user data using a Gamma distribution. \n");
+ cat(descr, file=rnwFile, append=TRUE);
+
+ univROCtable<-c("<<echo=false, results=tex>>=",
+ "CreateMummichogAnalTable(mSet)",
+ "@",
+ "\\clearpage\n\n");
+ cat(univROCtable, file=rnwFile, append=TRUE, sep="\n");
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+ }
+
+ if(!is.null(mSetObj$mummi.gsea.resmat)){
+ descr <- c("\\section{GSEA Pathway Analysis Results}\n",
+ "The output of the GSEA analysis consists of a table of results containing ranked pathways that are enriched in ",
+ "the user-uploaded data. The table includes the total number of hits (all and expected), their raw p-values and adjusted p-values.",
+ " On the web, user's can explore the results in an interactive volcano plot. \n");
+ cat(descr, file=rnwFile, append=TRUE);
+
+ # Because mummi.gsea.resmat is created for meta-analysis
+ if(!is.null(mSetObj$imgSet$mummi.plot)){
+
+ descr <- c("\\subsection{GSEA Pathway Analysis Plot}\n",
+ "The pathway summary plot below displays all matched pathways as circles. The color and size of each circle corresponds",
+ " to its p-value and enrichment factor, respectively. The enrichment factor of a pathway is calculated as the ratio between the number of significant",
+ " pathway hits and the expected number of compound hits within the pathway. \n");
+ cat(descr, file=rnwFile, append=TRUE);
+
+ fig <- c( "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{",mSetObj$imgSet$mummi.plot,"}",sep=""),
+ "\\caption{Summary of Pathway Analysis}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$mummi.plot,"}", sep=""),
+ "\\end{figure}",
+ "\\clearpage\n\n"
+ );
+ cat(fig, file=rnwFile, append=TRUE, sep="\n");
+ }
+
+ univROCtable<-c("<<echo=false, results=tex>>=",
+ "CreateGSEAAnalTable(mSet)",
+ "@",
+ "\\clearpage\n\n");
+ cat(univROCtable, file=rnwFile, append=TRUE, sep="\n");
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+ }
+
+ if(!is.null(mSetObj$integ.resmat)){
+ descr <- c("\\section{Meta-Analysis of mummichog and GSEA results}\n",
+ "The MS Peaks to Paths module uses the (Fisher's method) for combining the mummichog and GSEA p-values.",
+ "It takes the raw p-values per pathway to perform p-value combination.",
+ "The Integrated MS Peaks to Paths plot below summarizes the results of the",
+ " Fisher's method for combining mummichog (y-axis) and GSEA (x-axis) p-values. ",
+ "The size and color of the circles correspond to their transformed combined p-values.",
+ " Large and red circles are considered the most perturbed pathways.",
+ " The blue and pink areas highlight the significant pathways based on either GSEA ",
+ "(pink) or mummichog (blue), and the purple area highlights significant pathways identified by both algorithms. \n");
+ cat(descr, file=rnwFile, append=TRUE);
+
+ fig <- c( "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{",mSetObj$imgSet$integpks.plot,"}",sep=""),
+ "\\caption{Summary of Pathway Analysis}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$integpks.plot,"}", sep=""),
+ "\\end{figure}",
+ "\\clearpage\n\n"
+ );
+ cat(fig, file=rnwFile, append=TRUE, sep="\n");
+
+ univROCtable<-c("<<echo=false, results=tex>>=",
+ "CreateMetaAnalTable(mSet)",
+ "@",
+ "\\clearpage\n\n");
+ cat(univROCtable, file=rnwFile, append=TRUE, sep="\n");
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+
+ }
+
+ descr <- c("\\section{Compound Matching Table}\n",
+ "The output of the MS Peaks to Pathways module also consists of a comprehensive table containing the compound matching",
+ " information for all user-uploaded m/z features. The table has four columns, containing the Query.Mass of each feature, the predicted Matched.Compound for each feature,",
+ "the Matched.Form, and the Mass.Diff. As the file can be very long (>40 pages), please download it separately on the Downloads page of MetaboAnalyst. \n");
+ cat(descr, file=rnwFile, append=TRUE);
+
+ descr <- c("\\section{Network Visualization}\n",
+ "The MS Peaks to Pathways module also allows users to interactively view their data in a global KEGG metabolic network.",
+ "Users will be able to their network as a SVG or PNG file on the Network Viewer page of MetaboAnalyst. \n");
+ cat(descr, file=rnwFile, append=TRUE);
+
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+
+}
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_network.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_network.R
new file mode 100755
index 0000000000000000000000000000000000000000..7ab6a045ee441293742c87b1f080fc4fd9797beb
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_network.R
@@ -0,0 +1,211 @@
+#'Create report of analyses (Network Explorer)
+#'@description Report generation using Sweave
+#'Puts together the analysis report
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param usrName Input the name of the user
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateNetworkExplorerRnwReport<-function(mSetObj, usrName){
+
+ CreateHeader(usrName);
+ CreateNetworkExplorerIntr();
+
+ CreateNetworkExplorerOverview();
+ CreateNetworkExplorerInputDoc(mSetObj);
+ CreateNetworkExplorerDoc(mSetObj);
+
+ CreateRHistAppendix();
+ CreateFooter();
+}
+
+#'Create integrated pathway analysis report: Introduction
+#'@description Report generation using Sweave
+#'Network explorer report introduction
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateNetworkExplorerIntr <- function(){
+ descr <- c("\\section{Background}\n",
+ "The aim of the Network Explorer module is to provide a comprehensive tool to describe user's biological data as a network,",
+ " as well as to explore interactions between biological entities and their potential impacts to help inform hypothesis generation.",
+ " This module supports network visualization of both metabolomic and gene list data. Here, we aim to provide support for the",
+ " integration of transcriptomics and metabolomics data, as well as metagenomics and metabolomics data. MetaboAnalyst 5.0 implements ",
+ "a knowledge-based network approach, whereby user's data (metabolites and genes) can be projected onto five existing biological",
+ " networks: 1) Pathway-based network discovery, 2) Gene-metabolite interaction network, 3) Metabolite-phenotype interaction network, ",
+ "4) Metabolite-metabolite interaction network, and 5) Metabolite-gene-phenotype interaction network.\n"
+ );
+ cat(descr, file=rnwFile, append=TRUE);
+}
+
+#'Create network explorer report: Overview
+#'@description Report generation using Sweave
+#'for the network explorer report overview
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateNetworkExplorerOverview <- function(){
+ descr <- c("\\section{Network Explorer Overview}\n",
+ "The Network Explorer module consists of three steps: uploading the data, compound name/gene id mapping,",
+ " selecting the network analysis option, and then viewing the generated network in greater detail. \n"
+ );
+ cat(descr, file=rnwFile, append=TRUE);
+}
+
+#'Create network explorer: Data Input
+#'@description Report generation using Sweave
+#'network explorer report, data input documentation.
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jasmine Chong
+#'McGill University, viewingCanada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateNetworkExplorerInputDoc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ descr <- c("\\section{Data Input}\n",
+ "For this module, users may upload either a list of metabolites, a list of genes, or both metabolites and genes. ",
+ "MetaboAnalyst 5.0 currently accepts only compound names, HMDB IDs, or KEGG IDs as metabolite identifiers. As well,",
+ "we only accept Entrez IDs, RefSeqIDs, Genbank accession numbers, ENSEMBL gene accession numbers, Official Gene Symbol IDs, ",
+ "or KEGG orthologs (KO) as gene identifiers. The uploaded list of metabolites and/or genes is then mapped using our internal ",
+ "databases of metabolites and gene annotations. Following this step, users can select which of the five networks to begin",
+ " exploring their data.",
+ "\n\n");
+
+ cat(descr, file=rnwFile, append=TRUE);
+
+ if(exists('map.table', where=mSetObj$dataSet)){
+ nametable<-c("<<echo=false, results=tex>>=",
+ "CreateNetworkNameMapTable(mSet)",
+ "@");
+ cat(nametable, file=rnwFile, append=TRUE, sep="\n");
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+ }
+
+ if (exists('gene.map.table', where=mSetObj$dataSet)){
+
+ genetable<-c("<<echo=false, results=tex>>=",
+ "CreateNetworkGeneMapTable(mSet)",
+ "@");
+ cat(genetable, file=rnwFile, append=TRUE, sep="\n");
+ }
+
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+}
+
+#'Create a x-table for compound name mapping
+#'@description Report generation using Sweave
+#'Function to create a table for compound name mapping
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateNetworkNameMapTable <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ namemapped <- mSetObj$dataSet$map.table;
+ print(xtable::xtable(namemapped, caption="Compound Name Mapping"), table.placement="!h", caption.placement="top", size="\\scriptsize");
+}
+
+#'Create a x-table for gene name mapping
+#'@description Report generation using Sweave
+#'Function to create a table for gene name mapping
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateNetworkGeneMapTable <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ genemapped <- mSetObj$dataSet$gene.map.table;
+
+ colnames(genemapped) <- c("Query", "Entrez", "Symbol", "KO", "Name", "Comment");
+
+ print(xtable::xtable(genemapped, caption="Gene Name Mapping"), table.placement="!h", tabular.environment = "longtable", caption.placement="top", size="\\tiny");
+
+}
+
+#'Create integrated pathway analysis report
+#'@description Report generation using Sweave
+#'Biomarker analysis report, ROC Curve Based Model Creation and Evaluation
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateNetworkExplorerDoc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ descr <- c("\\section{Network Explorer}\n",
+ "The Network Explorer analysis module complements MetaboAnalyst's joint-Pathway Analysis module by allowing the ",
+ "identification of connections that cross pathway boundaries (e.g. metabolite-disease interactions) as well as ",
+ "enabling a more global view of the pathways which may not be obvious when examined individually.",
+ "The Network Explorer module currently supports five types of biological networks including the ",
+ "KEGG global metabolic network, a gene-metabolite interaction network, a metabolite-disease interaction network, ",
+ "a metabolite-metabolite interaction network, and a metabolite-gene-disease interaction network. The last four",
+ " networks are created based on information gathered from HMDB and STITCH databases, and are applicable to ",
+ "human studies only. The integration of network topological analysis, interactive network exploration, and ",
+ "functional enrichment analysis provides users with different views on their data. Interpreting metabolomic ",
+ "data and/or gene expression data in such a context is far more insightful, and will lead to the generation of ",
+ "testable experimental hypotheses.",
+ "\n\n");
+
+ cat(descr, file=rnwFile, append=TRUE);
+
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+
+ if(exists('network.type')){
+
+ if(network.type=="gene_metabolites"){
+ network = "Gene-Metabolite Interaction Network."
+
+ }else if(network.type=="metabo_phenotypes"){
+ network = "Metabolite-Disease Interaction Network."
+
+ }else if(network.type=="metabo_metabolites"){
+ network = "Metabolite-Metabolite Interaction Network."
+
+ }else{
+ network = "Metabolite-Gene-Disease Interaction Network."
+ }
+
+ net.type <- paste("The selected interaction network is: ", network);
+ cat(net.type, file=rnwFile, append=TRUE);
+ image <- paste(" Figure 1. shows the plot of the created interaction network.");
+ cat(image, file=rnwFile, append=TRUE);
+ note <- paste (" The plot (Figure 1) shows feature names, which may be hard for users to decipher in the generated plot within
+ this report. It is therefore recommended that users with large datasets to use the Network Explorer to visually explore their data
+ online, where high-quality SVG/PNG images can be saved.")
+ cat(note, file=rnwFile, append=TRUE);
+
+ }else{
+ net.type <- paste("The selected network is the KEGG Global Metabolic Network. Please use the web-server to visualize your data as a network and save the file as a PNG/SVG file.");
+ cat(net.type, file=rnwFile, append=TRUE);
+ }
+
+ if(exists('network.type')){
+
+ networkplot <- c( "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", "network.png","}", sep=""),
+ "\\caption{", "Plot of the selected interaction network","}",
+ "\\end{center}",
+ paste("\\label{", "network.png" ,"}", sep=""),
+ "\\end{figure}",
+ "\\clearpage"
+ );
+
+ cat(networkplot, file=rnwFile, append=TRUE, sep="\n");
+ }
+
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+}
\ No newline at end of file
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_pathway.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_pathway.R
new file mode 100755
index 0000000000000000000000000000000000000000..bf1365c32ae6cc4354c4b8ef06fd7e30d1ab19d4
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_pathway.R
@@ -0,0 +1,284 @@
+#'Create report of analyses (Met Pathway)
+#'@description Report generation using Sweave
+#'Metabolomic pathway analysis
+#'write .Rnw file template
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param usrName Input the name of the user
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+CreatePathRnwReport <- function(mSetObj, usrName){
+
+ CreateHeader(usrName);
+
+ CreatePathIntr();
+ CreatePathInputDoc();
+ CreatePathProcessDoc(mSetObj);
+ CreatePathAnalDoc(mSetObj);
+ CreatePathResultDoc(mSetObj);
+
+ CreateRHistAppendix();
+ CreateFooter();
+
+}
+
+#'Create report of analyses (Met Pathway)
+#'@description Report generation using Sweave
+#'Metabolomic pathway analysis
+#'Introduction
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+CreatePathIntr<-function(){
+ descr <- c("\\section{Background}\n",
+ "The Pathway Analysis module combines results from powerful pathway",
+ " enrichment analysis with pathway topology analysis to help researchers identify the most",
+ "relevant pathways involved in the conditions under study.",
+ "\n\n",
+ "There are many commercial pathway analysis software tools such as Pathway Studio, MetaCore, or",
+ "Ingenuity Pathway Analysis (IPA), etc. Compared to these commercial tools, the pathway analysis module was specifically developed",
+ " for metabolomics studies. It uses high-quality KEGG metabolic pathways as the backend knowledgebase.",
+ " This module integrates many well-established (i.e. univariate analysis, over-representation analysis) methods,",
+ "as well as novel algorithms and concepts (i.e. Global Test, GlobalAncova, network topology analysis) into",
+ "pathway analysis. Another feature is a Google-Map style interactive visualization system to deliver",
+ " the analysis results in an intuitive manner.\n"
+ );
+ cat(descr, file=rnwFile, append=TRUE);
+}
+
+#'Create report of analyses (Met Pathway)
+#'@description Report generation using Sweave
+#'Metabolomic pathway analysis
+#'Create data input doc
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreatePathInputDoc<-function(){
+
+ descr <- c("\\section{Data Input}\n",
+ "The Pathway Analysis module accepts either a list of compound labels (common names, HMDB IDs or KEGG IDs) with one compound per row,",
+ " or a compound concentration table with samples in rows and compounds in columns. The second column must be",
+ " phenotype labels (binary, multi-group, or continuous). The table is uploaded as comma separated values (.csv).",
+ "\n\n");
+
+ cat(descr, file=rnwFile, append=TRUE);
+}
+
+#'Create report of analyses (Met Pathway)
+#'@description Report generation using Sweave
+#'Metabolomic pathway analysis
+#'Create MetPA process
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreatePathProcessDoc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ descr <- c("\\section{Compound Name Matching}\n",
+ "The first step is to standardize the compound labels used in user uploaded data. This is a necessary step since",
+ "these compounds will be subsequently compared with compounds contained in the pathway library.",
+ "There are three outcomes from the step - exact match, approximate match (for common names only), and no match.",
+ "Users should click the textbf{View} button from the approximate matched results to manually select the correct one.",
+ "Compounds without match will be excluded from the subsequently pathway analysis.",
+ "\n\n",
+ "\\textbf{Table 1} shows the conversion results. Note: \\textit{1} indicates exact match, \\textit{2}",
+ "indicates approximate match, and \\textit{0} indicates no match. A text file contain the result can be",
+ "found the downloaded file \\textit{name\\_map.csv}\n\n"
+ );
+ cat(descr, file=rnwFile, append=TRUE, sep="\n");
+
+ descr<-c("<<echo=false, results=tex>>=",
+ "GetMapTable(mSet)",
+ "@",
+ "\\clearpage\n\n"
+ );
+ cat(descr, file=rnwFile, append=TRUE, sep="\n");
+}
+
+#'Create report of analyses (Met Pathway)
+#'@description Report generation using Sweave
+#'Metabolomic pathway analysis
+#'Create pathway analysis doc
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreatePathAnalDoc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ descr <- c("\\section{Pathway Analysis}\n",
+ "In this step, users are asked to select a pathway library, as well as specify the algorithms for pathway",
+ "enrichment analysis and pathway topology analysis. \n");
+ cat(descr, file=rnwFile, append=TRUE, sep="\n");
+
+ descr <- c("\\subsection{Pathway Library}\n",
+ "There are 15 pathway libraries currently supported, with a total of 1173 pathways :\n",
+ "\\begin{itemize}",
+ "\\item{Homo sapiens (human) [80]}",
+ "\\item{Mus musculus (mouse) [82]}",
+ "\\item{Rattus norvegicus (rat) [81]}",
+ "\\item{Bos taurus (cow) [81]}",
+ "\\item{Danio rerio (zebrafish) [81]}",
+ "\\item{Drosophila melanogaster (fruit fly) [79]}",
+ "\\item{Caenorhabditis elegans (nematode) [78]}",
+ "\\item{Saccharomyces cerevisiae (yeast) [65]}",
+ "\\item{Oryza sativa japonica (Japanese rice) [83]}",
+ "\\item{Arabidopsis thaliana (thale cress) [87]}",
+ "\\item{Escherichia coli K-12 MG1655 [87]}",
+
+ "\\item{Bacillus subtilis [80]}",
+ "\\item{Pseudomonas putida KT2440 [89]}",
+ "\\item{Staphylococcus aureus N315 (MRSA/VSSA)[73]}",
+ "\\item{Thermotoga maritima [57]}",
+ "\\end{itemize}",
+ "\n\n",
+ mSetObj$msgSet$lib.msg,
+ "\n");
+ cat(descr, file=rnwFile, append=TRUE, sep="\n");
+
+ if(mSetObj$analSet$type == "pathora"){
+ descr <- c("\\subsection{Over Representation Analysis}\n",
+ "Over-representation analysis tests if a particular group of compounds",
+ "is represented more than expected by chance within the user uploaded compound",
+ "list. In the context of pathway analysis, we are testing if compounds involved",
+ "in a particular pathway are enriched compared to random hits. MetPA offers two of the",
+ "most commonly used methods for over-representation analysis: \n",
+ "\\begin{itemize}",
+ "\\item{Fishers'Exact test}",
+ "\\item{Hypergeometric Test}",
+ "\\end{itemize}",
+ "\\textit{Please note, MetPA uses one-tailed Fisher's exact test which will give essentially",
+ "the same result as the result calculated by the hypergeometric test.}",
+ "\n\n",
+ mSetObj$msgSet$rich.msg,
+ "\n\n");
+ }else{
+ descr <- c("\\subsection{Pathway Enrichment Analysis}\n",
+ "Pathway enrichment analysis usually refers to quantitative enrichment analysis directly",
+ "using the compound concentration values, as compared to compound lists used by over-representation",
+ "analysis. As a result, it is more sensitive and has the potential to identify",
+ "\\textbf{subtle but consistent} changes amongst compounds involved in the same biological pathway.",
+ "\n\n",
+ "Many procedures have been developed in the last decade for quantitative enrichment analysis, the most famous",
+ "being the Gene Set Enrichment Analysis. Many new and improved methods have been implemented since.",
+ "The enrichment analysis is based on GlobalTest and GlobalAncova. Both methods support enrichment analysis with",
+ "binary, multi-group, as well as continuous phenotypes. The p-values can be approximated based on the asymptotic",
+ "distribution without using permutations which is computationally very intensive and is not suitable for web applications.",
+ "Please note, when sample sizes are small, the approximated p values may be slightly less accurate compared to",
+ "p values obtained by using a permutation-based method (for details, please refer to the paper by Goeman, J.J. et al.",
+ "\\footnote{Jelle J. Goeman and Peter Buhlmann. \\textit{Analyzing gene expression data in terms of gene",
+ "sets: methodological issues}, Bioinformatics 2007 23(8):980-987}",
+ "and by Hummel, M. et al.",
+ "\\footnote{Manuela Hummel, Reinhard Meister and Ulrich Mansmann. \\textit{GlobalANCOVA: exploration and assessment of gene group",
+ "effects}, Bioinformatics 2008 24(1):78-85})",
+ "However, since our focus is to identify the most relevant pathways within the pathways in the library,",
+ "we are more interested in the rank of the pathway, not its absolute p-value. Therefore, this disadvantage may be tolerated.",
+ "\n\n",
+ mSetObj$msgSet$rich.msg,
+ "\n\n"
+ );
+ }
+ cat(descr, file=rnwFile, append=TRUE, sep="\n");
+
+ descr <- c("\\subsection{Pathway Topology Analysis}\n",
+ "The structure of biological pathways represent our knowledge about the complex relationships among molecules",
+ "within a cell or a living organism. However, most pathway analysis algorithms fail to take structural information",
+ "into consideration when estimating which pathways are significantly changed under conditions of study. ",
+ "It is well-known that changes in more important positions of a network will trigger a more severe",
+ "impact on the pathway than changes occurred in marginal or relatively isolated positions.",
+ "\n\n",
+ "The pathway topology analysis uses two well-established node centrality measures to estimate node importance - \\textbf{degree centrality}",
+ "and \\textbf{betweenness centrality}. Degree centrality is defined as the number of links occurred upon a node.",
+ "For a directed graph there are two types of degree: in-degree for links come from other nodes, and out-degree",
+ "for links initiated from the current node. Metabolic networks are directed graph. Here we only consider the",
+ "out-degree for node importance measure. It is assumed that nodes upstream will have regulatory roles for",
+ "the downstream nodes, not vice versa. The betweenness centrality measures the number of shortest paths going",
+ "through the node. Since the metabolic network is directed, we use the relative betweenness centrality for a metabolite",
+ "as the importance measure. The degree centrality measure focuses more on local connectivities, while the betweenness",
+ "centrality measure focuses more on global network topology. For more detailed discussions on various graph-based",
+ "methods for analyzing biological networks, please refer to the article by Tero Aittokallio, T. et al.",
+ "\\footnote{Tero Aittokallio and Benno Schwikowski. \\textit{Graph-based methods for analyzing networks in cell biology},",
+ "Briefings in Bioinformatics 2006 7(3):243-255}",
+ "\n\n",
+ "\\textit{Please note, for comparison among different pathways, the node importance values calculated from centrality measures",
+ "are further normalized by the sum of the importance of the pathway. Therefore, the total/maximum importance of each pathway",
+ "is 1; the importance measure of each metabolite node is actually the percentage w.r.t the total pathway importance,",
+ "and the pathway impact value is the cumulative percentage from the matched metabolite nodes.}",
+ "\n\n",
+ mSetObj$msgSet$topo.msg,
+ "\n");
+ cat(descr, file=rnwFile, append=TRUE, sep="\n");
+}
+
+#'Create report of analyses (Met Pathway)
+#'@description Report generation using Sweave
+#'Metabolomic pathway analysis
+#'Create MetPA results doc
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreatePathResultDoc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ descr <- c("\\section{Pathway Analysis Result}\n",
+ "The results from pathway analysis are presented graphically as well as in a detailed table.",
+ "\n\n",
+ "A Google-map style interactive visualization system was implemented to facilitate data exploration.",
+ "The graphical output contains three levels of view: \\textbf{metabolome view}, \\textbf{pathway view},",
+ "and \\textbf{compound view}. Only the metabolome view is shown below.",
+ "Pathway views and compound views are generated dynamically based on your interactions with the",
+ "visualization system. They are available in your downloaded files. \n");
+ cat(descr, file=rnwFile, append=TRUE, sep="\n");
+ fig <- c( "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{",mSetObj$imgSet$path.overview,"}",sep=""),
+ "\\caption{Summary of Pathway Analysis}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$path.overview,"}", sep=""),
+ "\\end{figure}",
+ "\\clearpage\n\n"
+ );
+ cat(fig, file=rnwFile, append=TRUE, sep="\n");
+
+ descr <- c(
+ "The table below shows the detailed results from the pathway analysis. Since",
+ "we are testing many pathways at the same time, the statistical p values from",
+ "enrichment analysis are further adjusted for multiple testings. In particular, ",
+ "the \\textbf{Total} is the total number of compounds in the pathway;",
+ "the \\textbf{Hits} is the actually matched number from the user uploaded data;",
+ "the \\textbf{Raw p} is the original p value calculated from the enrichment analysis;",
+ "the \\textbf{Holm p} is the p value adjusted by Holm-Bonferroni method;",
+ "the \\textbf{FDR p} is the p value adjusted using False Discovery Rate;",
+ "the \\textbf{Impact} is the pathway impact value calculated from pathway topology analysis.",
+ "\n");
+ cat(descr, file=rnwFile, append=TRUE, sep="\n");
+ if(mSetObj$analSet$type == "pathora"){
+ descr<-c("<<echo=false, results=tex>>=",
+ "GetORATable(mSet)",
+ "@",
+ "\\clearpage\n\n"
+ );
+ }else{
+ descr<-c("<<echo=false, results=tex>>=",
+ "GetQEATable(mSet)",
+ "@",
+ "\\clearpage\n\n"
+ );
+ }
+ cat(descr, file=rnwFile, append=TRUE, sep="\n");
+
+}
+
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_power.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_power.R
new file mode 100755
index 0000000000000000000000000000000000000000..955343ce0eb924f5dcd8e040fe0a7020c8564845
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_power.R
@@ -0,0 +1,226 @@
+#'Create report of analyses (Power)
+#'@description Report generation using Sweave
+#'Put together the analysis report
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param usrName Input the name of the user
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreatePowerRnwReport <- function(mSetObj, usrName){
+
+ CreateHeader(usrName);
+ CreatePowerIntr();
+
+ CreatePowerOverview();
+ CreatePowerInputDoc(mSetObj);
+ CreateNORMdoc(mSetObj)
+
+ CreatePowerParametersDoc(mSetObj);
+ CreatePowerAnalDoc(mSetObj);
+
+ CreateRHistAppendix();
+ CreateFooter();
+}
+
+#'Create power analysis report: Introduction
+#'@description Report generation using Sweave
+#'Power analysis report introduction
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreatePowerIntr <- function(){
+ descr <- c("\\section{Background}\n",
+ "The Power analysis module supports sample size estimation and power analysis for designing",
+ " population-based or clinical metabolomic studies. As metabolomics is becoming a more accessible",
+ " and widely used tool, methods to ensure proper experimental design are crucial to allow for accurate",
+ " and robust identification of metabolites linked to disease, drugs, environmental or genetic differences.",
+ " Traditional power analysis methods are unsuitable for metabolomics data as the high-throughput nature of",
+ " this data means that it is highly dimensional and often correlated. Further, the number of metabolites",
+ " identified greatly outnumbers the sample size. Thus, modified methods of power analysis are needed to",
+ " address such concerns. One solution is to use the average power of all metabolites, and to correct",
+ " for multiple testing using methods such as the false discovery rate (FDR) instead of raw p-values.",
+ " MetaboAnalystR uses the SSPA R package to perform power analysis.",
+ " For more information, please refer to the original paper by van Iterson et al. (PMID: 19758461)\n."
+ );
+ cat(descr, file=rnwFile, append=TRUE);
+}
+
+#'Create power analysis report: Overview
+#'@description Report generation using Sweave
+#'Power analysis report overview
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreatePowerOverview <- function(){
+ descr <- c("\\section{Power Analysis Overview}\n",
+ "The power analysis module consists of four steps - uploading pilot data, data processing,",
+ " selecting parameters for power analysis, and viewing the results. The analysis will use",
+ " the entire set of uploaded pilot data \n."
+ );
+ cat(descr, file=rnwFile, append=TRUE);
+}
+
+#'Create power analysis report: Data Input
+#'@description Report generation using Sweave
+#'Power analysis report, data input documentation.
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jasmine Chong
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreatePowerInputDoc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ descr <- c("\\section{Data Input}\n",
+ "The power analysis module accepts either a compound concentration table, spectral binned data, or a peak intensity",
+ " table. The format of the data must be specified, identifying whether the samples are in rows or columns, and whether",
+ " or not the data is paired. The data may either be .csv or .txt files.",
+ " \n\n");
+
+ cat(descr, file=rnwFile, append=TRUE);
+
+ # the data filtering
+ descr <- c("\\subsubsection{Data Filtering}\n",
+ "The purpose of data filtering is to identify and remove variables that are unlikely to be of",
+ " use when modeling the data. No phenotype information is used in the filtering process, so the result",
+ " can be used with any downstream analysis. This step can usually improve the results.",
+ " Data filtering is strongly recommended for datasets with a large number of variables (> 250) and",
+ " for datasets which contain a lot of noise (i.e.chemometrics data). Filtering can usually improve your",
+ " results\\footnote{Hackstadt AJ, Hess AM.\\textit{Filtering for increased power for microarray data analysis},",
+ " BMC Bioinformatics. 2009; 10: 11.}.",
+ " \n\n",
+ " \\textit{For data with < 250 of variables, filtering will reduce 5\\% of variables;",
+ " For a total number of variables between 250 and 500, 10\\% of variables will be removed;",
+ " For a total number of variables bewteen 500 and 1000, 25\\% of variables will be removed;",
+ " Finally, 40\\% of variables will be removed for data with over 1000 variables.}");
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+ filt.msg <- mSetObj$msgSet$filter.msg;
+ if(is.null(filt.msg)){
+ filt.msg <- "No data filtering was performed.";
+ }
+ cat(filt.msg, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+ descr <- c("\\subsubsection{Data Integrity Check}\n",
+ "Before data analysis, a data integrity check is performed to make sure that all of the necessary",
+ " information has been collected. The class labels must be present and must contain only two classes.",
+ " If the samples are paired, the class label must be from -n/2 to -1 for one group, and 1 to n/2 for the second group",
+ " (n is the sample number and must be an even number). Class labels with the same absolute value are assumed to be pairs.",
+ " Compound concentration or peak intensity values must all be non-negative numbers.",
+ " By default, all missing values, zeros and negative values will be replaced by the half of the minimum positive value",
+ " found within the data (see next section).");
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+ descr <- c("\\subsubsection{Missing value imputations}\n",
+ "Too many zeroes or missing values will cause difficulties in the downstream analysis.",
+ " MetaboAnalystR offers several different methods for this purpose. The default method replaces ",
+ " all the missing and zero values with a small values (the half of the minimum positive",
+ " values in the original data) assuming to be the detection limit. The assumption of this approach",
+ " is that most missing values are caused by low abundance metabolites (i.e.below the detection limit).",
+ " In addition, since zero values may cause problem for data normalization (i.e. log), they are also ",
+ " replaced with this small value. User can also specify other methods, such as replace by mean/median,",
+ " or use K-Nearest Neighbours, Probabilistic PCA (PPCA), Bayesian PCA (BPCA) method, Singular Value Decomposition (SVD)",
+ " method to impute the missing values \\footnote{Stacklies W, Redestig H, Scholz M, Walther D, Selbig J.",
+ " \\textit{pcaMethods: a bioconductor package, providing PCA methods for incomplete data.}, Bioinformatics",
+ " 2007 23(9):1164-1167}. Please select the one that is the most appropriate for your data.");
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+ if(is.null(mSetObj$msgSet$replace.msg))
+ mSetObj$msgSet$replace.msg <- "No data replacement was performed."
+
+ cat(mSetObj$msgSet$replace.msg, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+ cmdhist2 <- c("<<echo=false, results=tex>>=",
+ "CreateSummaryTable(mSet)",
+ "@");
+ cat(cmdhist2, file=rnwFile, append=TRUE, sep="\n");
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+}
+
+#'Create power analysis report: Power Parameter Selection
+#'@description Report generation using Sweave
+#'Power analysis report, parameter selection
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreatePowerParametersDoc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ descr <- c("\\section{Parameter Selection}\n",
+ "Before proceeding to the power analysis, the two groups on which to perform said analysis",
+ " must be selected. Further, there will be four diagnostic plots which display a visual overview",
+ " of the test-statistics and p-values, providing context for whether or not the normalization was sufficient.",
+ " The shape of the test-statistic should follow a near-normal distribution, and the majority of p-values",
+ " should be close to zero. \n",
+ paste("Figure", fig.count<<-fig.count+1, "shows various diagnostic plots of the pilot data for power analysis."));
+ cat(descr, file=rnwFile, append=TRUE);
+
+ powerparamhist <- c( "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$powerstat,"}", sep=""),
+ "\\caption{", paste("Various plots overviewing the test-statistics and p-values calculated from the pilot data",
+ " to evaluate if they follow a normal distribution. The top left bar chart shows the",
+ " distribution of the test-statistic, which should show a bell-curve.",
+ " The top right bar chart shows the distribution of the p-values, with an",
+ " expectation that the majority of p-values hover around 0.",
+ " The bottom plots are Quantile-Quantile plots (QQ plots), with an expectation that",
+ " if the test-statistics and the p-values follow a standard normal distribution",
+ " the data points will follow the straight line. For the qq-plot, the p-values are sorted against",
+ " their ranks.", sep=""),"}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$powerstat,"}", sep=""),
+ "\\end{figure}",
+ "\\clearpage"
+ );
+ cat(powerparamhist, file=rnwFile, append=TRUE, sep="\n");
+}
+
+#'Create power analysis report: Power Analysis
+#'@description Report generation using Sweave
+#'Power analysis report, analysis
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreatePowerAnalDoc <- function(mSetObj){
+ descr <- c("\\section{Power Analysis}\n",
+ "Following parameter selection, power analysis can begin. The ultimate aim of power analysis",
+ " is to determine the minimum sample size used to detect an effect size of interest.",
+ " The sample size x statistical power relationship will be used to guide future",
+ " study design based upon the pilot data. To begin, the false-discovery rate and the",
+ " maximum sample size (between 60-1000) must be specified. The false-discovery rate will represent the",
+ " significance criterion or the alpha level. The magnitude of the effect of interest in the population",
+ " (effect size) will be calculated from the pilot data. Two plots will be created to visualize the",
+ " density of estimated effect sizes, and to visualize the predicted power curve. From these plots,",
+ " users will be able to determine the most appropriate sample size and its associated predicted power for future studies.",
+ " The power analysis provides invaluable insight for proper experimental design, as well as strengthens the ability to detect",
+ " true differences within a metabolomic data set.",
+ paste("Figure", fig.count<<-fig.count+1," shows the density of estimated effect sizes, and "),
+ paste("Figure", fig.count<<-fig.count+1," shows the predicted power curve."))
+ cat(descr, file=rnwFile, append=TRUE)
+
+ powerprofile <- c( "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$powerprofile,"}", sep=""),
+ "\\caption{Plot of the predicted power curve.", "}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$powerstat,"}", sep=""),
+ "\\end{figure}",
+ "\\clearpage"
+ )
+ cat(powerprofile, file=rnwFile, append=TRUE, sep="\n")
+}
+
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_raw_spectra.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_raw_spectra.R
new file mode 100644
index 0000000000000000000000000000000000000000..98971c1b57c4aa06d52aaaa4300e9a57623781ce
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_raw_spectra.R
@@ -0,0 +1,557 @@
+#'Create report for raw spectra module
+#'@description Report generation using Sweave
+#'Write .Rnw file template
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param usrName Input the name of the user
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+CreateRawAnalysisRnwReport <- function(mSetObj, usrName){
+
+ load("mSet.rda");
+ # Creat the header & introduction of the report
+ CreateHeader(usrName); # done
+ CreateRawIntr(); # done
+
+ CreateSpectraIOdoc(); # done
+
+ CreateRawAnalMethod(); # done
+ CreateRawAnalDetails(); # doing
+
+ CreateSampleSum(); # done
+ CreateFeatureSum(); # done
+
+
+ CreateRHistAppendix(); # done
+ CreateFooter(); # done
+
+}
+
+
+
+
+### Section 1 - Background
+CreateRawIntr <- function(){
+ descr0 <- c("\\section{Raw Spectra Processing}\n",
+ "Global or untargeted metabolomics is increasingly used to investigate metabolic changes of various biological
+ or environmental systems in an unbiased manner. Liquid chromatography coupled to high-resolution mass
+ spectrometry (LC-HRMS) has become the main workhorse for global metabolomics. The typical LC-HRMS metabolomics
+ workflow involves spectra collection, raw data processing, statistical and functional analysis.\n\n")
+
+ descr1 <- c("MetaboAnalyst aims to provide an efficient pipeline to support end-to-end analysis of LC-HRMS metabolomics
+ data in a high-throughput manner. \n\n")
+
+ descr <- c(descr0, descr1,
+ "This module is designed to provide an automated workflow to process the raw spectra. 5 steps including parameters ",
+ "optimization/custimization, peak picking, peak alignment, peak gap filing and peak annotation.");
+
+ cat(descr, file=rnwFile, append=TRUE);
+}
+
+### Section 2 - Method Description
+CreateSpectraIOdoc <- function(){
+
+ descr <- c("\\subsection{Reading and Processing the Raw Data}\n",
+ "MetaboAnalyst MS Spectral Processing Module accepts several common MS formats",
+ "including mzXML, mzML, mzData, CDF formats. Other vendor format will be supported soon.
+ But all of them have to be centroided before processing.",
+ "The Data Integrity Check is performed before the data processing starts. The basic information",
+ "of all spetra is summaried in Table", table.count<<-table.count+1,"shows the details of all spectra."
+ );
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+ cmdhist2 <- c("<<echo=false, results=tex>>=",
+ "CreateSpectraInfoTable()",
+ "@");
+ cat(cmdhist2, file=rnwFile, append=TRUE, sep="\n");
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+
+};
+CreateSpectraInfoTable <- function(){
+
+ if(file.exists("mSet.rda")){
+ load("mSet.rda"); require("OptiLCMS"); require(MSnbase)
+
+ filesize <- file.size(fileNames(mSet@rawOnDisk))/(1024*1024);
+ filename <- basename(fileNames(mSet@rawOnDisk));
+ Centroid <- rep("True",length(filename));
+ GroupInfo <- as.character(mSet@rawOnDisk@phenoData@data[["sample_group"]]);
+
+ sum.dat<-matrix(ncol = 4, nrow = length(filename));
+
+ sum.dat[,1] <- filename;
+ sum.dat[,2] <- Centroid;
+ sum.dat[,3] <- round(filesize,2);
+ sum.dat[,4] <- GroupInfo;
+
+ colnames(sum.dat)<-c("Spectra","Centroid", "Size (MB)", "Group");
+ print(xtable::xtable(sum.dat,
+ caption="Summary of data uploading results"),
+ caption.placement="top",
+ size="\\scriptsize");
+ } else {
+ # If processing is not done. Just read the data infomation directly.
+ if(dir.exists("upload")){
+ files <- list.files("upload", full.names = T, recursive = T)
+
+ snames <- gsub("\\.[^.]*$", "", basename(files))
+ sclass <- gsub("^\\.$", "sample", dirname(files))
+
+ scomp <- strsplit(substr(sclass, 1, min(nchar(sclass))), "", fixed = TRUE)
+ scomp <- matrix(c(scomp, recursive = TRUE), ncol = length(scomp))
+
+ i <- 1
+ while (all(scomp[i, 1] == scomp[i, -1]) && i < nrow(scomp)) {
+ i <- i + 1
+ }
+
+ i <-
+ min(i, tail(c(0, which(
+ scomp[1:i, 1] == .Platform$file.sep
+ )), n = 1) + 1)
+
+ if (i > 1 && i <= nrow(scomp)) {
+ sclass <- substr(sclass, i, max(nchar(sclass)))
+ }
+
+ if (.on.public.web &
+ unique(sclass)[1] == "upload" &
+ length(unique(sclass)) == 1) {
+ sclass <- rep("Unknown", length(sclass))
+ }
+
+ fileFullName <- list.files("upload", recursive = T, full.names = T);
+ sum.dat<-matrix(ncol = 4, nrow = length(fileFullName));
+
+ sum.dat[,1] <- basename(fileFullName);
+ sum.dat[,2] <- unname(sapply(fileFullName, function(x){CentroidCheck(x)}));
+ sum.dat[,3] <- round(file.size(fileFullName),2);
+ sum.dat[,4] <- sclass;
+
+ } else {
+ #do nothing
+ }
+ }
+
+};
+CreateRawAnalMethod <- function(){
+ descr <- c("\\subsection{Raw Spectral Processing and Analyzing}",
+ "MetaboAnalyst offers several algorithms to process the spectral raw file,
+ including MatchedFilter, centWave and Massifquant (launch soon) for peak pciking, and obiwarp and loess for Retention time alignment.",
+ "Here the detailed algorithms and parameters' used in this study.");
+ cat(descr, file=rnwFile, append=TRUE, sep="\n");
+
+ load("params.rda");
+
+ paramVec <- vector();
+ for (i in seq(length(peakParams))){
+
+ if(names(peakParams[i]) == "Peak_method"){
+ paramVec <- c(paramVec, paste0("\\item{Peak Picking Algorithm: ", peakParams[["Peak_method"]], "}"))
+ } else if(names(peakParams[i]) == "RT_method"){
+ paramVec <- c(paramVec, paste0("\\item{RT Alignment Algorithm: ", peakParams[["RT_method"]], "}"))
+ } else {
+ paramVec <- c(paramVec, paste0("\\item{", gsub(pattern = "_", replacement = " ",names(peakParams[i])), ": ", peakParams[i], "}"))
+ }
+
+ }
+
+ descr2 <- c(
+ "\\begin{enumerate}",
+ paramVec,
+ "\\end{enumerate}",
+ "\\texttt{All parameters used to do the raw spectral processing are shown as above.
+ The detailed usage of every parameters are explanied in next page.}",
+ "\\clearpage"
+ );
+ cat(descr2, file=rnwFile, append=TRUE, sep="\n");
+
+ descr3 <- c(
+ "\\begin{enumerate}",
+
+ "\\item{Peak Picking Algorithm -- centWave (For high resolution): }",
+ "\\begin{itemize}",
+ "\\item{peakwidth min: expected approximate minimum peak width in chromatographic space. }",
+ "\\item{peakwidth max: expected approximate maximum peak width in chromatographic space.}",
+ "\\item{snthresh: defining the signal to noise ratio cutoff.}",
+ "\\item{prefilter: ROI detection prefilter values: 'prefilter' minimum scan number;}",
+ "\\item{value-of-prefilter: minimum peak intensity.}",
+ "\\item{noise: allowing to set a minimum intensity cut-off to be considered as a peak.}",
+ "\\item{mzdiff: minimum difference in m/z for peaks with overlapping retention times.}",
+ "\\end{itemize}",
+
+ "\\item{Peak Picking Algorithm -- MatchedFilter (For low resolution):}",
+ "\\begin{itemize}",
+ "\\item{fwhm: full width at half maximum of matched filtration gaussian model peak.}",
+ "\\item{sigma: specifying the standard deviation (width) of the matched filtration model peak.}",
+ "\\item{steps: defining the number of bins to be merged before filtration.}",
+ "\\item{max: the maximum number of peaks that are expected/will be identified per slice.}",
+ "\\end{itemize}",
+
+ "\\item{Retention Time Alignment Algorithm -- loess:}",
+ "\\begin{itemize}",
+ "\\item{Bandwidth: bandwidth (standard deviation or half width at half maximum) of gaussian smoothing kernel.}",
+ "\\item{minFraction: minimum fraction of samples necessary in at least one of the sample groups for it to be a valid group.}",
+ "\\item{integrate: Integration method. Can be 1 and 2.}",
+ "\\item{extra: number of extra peaks to allow in retention time correction correction groups }",
+ "\\item{span: degree of smoothing for local polynomial regression fitting }",
+ "\\item{profStep: step size (in m/z) to use for profile generation}",
+ "\\end{itemize}",
+
+ "\\item{Retention Time Alignment Algorithm -- obiwarp:}",
+ "\\begin{itemize}",
+ "\\item{binSize: bin size (in mz dimension) to be used for the profile matrix generation.}",
+ "\\end{itemize}",
+
+ "\\item{Peak Grouping -- Group-density:}",
+ "\\begin{itemize}",
+ "\\item{Bandwidth: bandwidth (standard deviation or half width at half maximum) of gaussian smoothing kernel.}",
+ "\\item{maxFeatures: maximum number of peak groups to be identified in a single mz slice.}",
+ "\\item{minSamples: minimum number of samples necessary in at least one of the sample groups for it to be a valid group.}",
+ "\\end{itemize}",
+
+ "\\item{Others:}",
+ "\\begin{itemize}",
+ "\\item{polarity: ion mode, can be negative or positive.}",
+ "\\item{max charge: maximum number of charge for adducts annotation.}",
+ "\\item{max iso: maximum number of charge for isotopes annotation.}",
+ "\\item{rmConts: whether to remove the potentail contaminants for further parameters' optimization.}",
+ "\\end{itemize}",
+
+ "\\end{enumerate}",
+ "\\clearpage"
+ );
+
+ cat(descr3, file=rnwFile, append=TRUE, sep="\n");
+
+};
+CreateRawAnalDetails <- function(){
+
+ descr <- c("\\subsection{Raw Spectral Processing Platform}",
+ paste0("The spectra files are processed with OptiLCMS R package (", packageVersion("OptiLCMS"), ")
+ based on Intel Xeon Processor equiped platform. Total of 4 cores are allocated for this task." ),
+ "The customized or automated pipeline has been implemented based on your previous choice. \n\n",
+ "Detailed description of the mechanism of automated pipeline has been published. Please find out more
+ introduction on the optimization process from the following paper.",
+ "\\begin{itemize}",
+ "\\item{Pang Z, Chong J, Li S, Xia J. MetaboAnalystR 3.0: Toward an Optimized Workflow for Global Metabolomics. Metabolites. 2020 May 7;10(5):186. doi: 10.3390/metabo10050186. PMID: 32392884; PMCID: PMC7281575.}",
+ "\\end{itemize}",
+ "\n\n",
+ "Please cite this publication if you are using this module to do your processing.");
+
+ cat(descr, file=rnwFile, append=TRUE, sep="\n");
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+
+}
+
+### Section 3 - Processing result
+CreateSampleSum <- function(){
+ descr <- c("\\section{Raw Spectra Processing - Spectra Summary}\n",
+ "All spectra files included for processing in this module have been processed.",
+ "All sample processing result are shown as below, including the Base Peak Ion (BPI), Total Ion Chromatogram (TIC),
+ Peak intensity stats and a breif PCA display (under log transformation).
+ Meanwhile, the statistics of all spectra files has also been provided in this section.");
+ cat(descr, file=rnwFile, append=TRUE);
+
+ descr1 <- c(
+ "Here is a brief content of this section",
+ "\\begin{itemize}",
+ "\\item{Total Ion Chromatogram (TIC) }",
+ "\\item{Base Peak Ion (BPI) Chromatogram}",
+ "\\item{Spectral Intensity Stats}",
+ "\\item{Principal Component Analysis (PCA)}",
+ "\\item{Spectral peaks summary}",
+ "\\end{itemize}")
+
+ cat(descr1, file=rnwFile, append=TRUE);
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+
+ CreateTIC(); # Done
+ CreateBPI(); # Done
+ CreateIntensityStats(); # Done
+ CreatePCA(); # Done
+ createSpectraSumDoc(); # Done
+ createSpectraTIC(); # Done
+
+};
+CreateTIC<- function(){
+
+ descr <- c("\\subsection{Total Ion Chromatogram (TIC)}\n",
+ "TIC is a chromatogram summed the intensities of all mass spectral peaks from same scan.",
+ "All signals including noise and peak components are included in TIC",
+ "In other words, TIC is a sum of all the separate ion contributing to a mass spectrum",
+ "The spectra TIC signal (ion) flow of all files is displayed in Figure", fig.count<<-fig.count+1,", as below."
+ );
+
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\n", file=rnwFile, append=TRUE);
+
+ cmdhist <- c( "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=0.75\\textwidth]{TICS_72.png}", sep=""),
+ "\\caption{Total Ion Chromatogram plot of the spectral processing.}",
+ "\\end{center}",
+ "\\end{figure}",
+ "\\clearpage"
+ );
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+
+};
+CreateIntensityStats<- function(){
+
+ descr <- c("\\subsection{Peak Intensity Statistics}\n",
+ "The general peaks' intensity is analyzed from different spectral files to show the peaks' intensity distribution",
+ "The statistics all spectral peaks is displayed in Figure", fig.count<<-fig.count+1,", as below."
+ );
+
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\n", file=rnwFile, append=TRUE);
+
+ cmdhist <- c( "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=0.75\\textwidth]{Peak_Intensity.png}", sep=""),
+ "\\caption{Peak Intensity Statistics of all spectral files.}",
+ "\\end{center}",
+ "\\end{figure}",
+ "\\clearpage"
+ );
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+
+};
+CreatePCA<- function(){
+
+ descr <- c("\\subsection{Principal component analysis (PCA)}\n",
+ "PCA is a dimension-reduction method used to increase the interpretability of high-dimension datasets and minimizing the information loss.",
+ "Here a primary PCA was performed with the log-transformed data.",
+ "The PCA score plot is shown in ", fig.count<<-fig.count+1,", as below. Please try to play your data with different modules (e.g. Statistic Analysis) to find out more statistic sense."
+ );
+
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\n", file=rnwFile, append=TRUE);
+
+ cmdhist <- c( "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=0.75\\textwidth]{PCA.png}", sep=""),
+ "\\caption{Principal component analysis (PCA). Samples from different groups are marked with different colors.}",
+ "\\end{center}",
+ "\\end{figure}",
+ "\\clearpage"
+ );
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+
+};
+createSpectraSumDoc<- function(){
+
+ descr <- c("\\subsection{Spectra Summary}\n",
+ "The peaks information from different spectra after processing is summarized in",
+ table.count<<-table.count+1,", as below."
+ );
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+ cmdhist2 <- c("<<echo=false, results=tex>>=",
+ "createSpectraSumTable()",
+ "@");
+ cat(cmdhist2, file=rnwFile, append=TRUE, sep="\n");
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+
+};
+createSpectraSumTable <- function(){
+ if(file.exists("peak_result_summary.txt")){
+ dt <- read.table("peak_result_summary.txt")
+ colnames(dt)<-c("Spectra","Groups", " RT range", "m/z Range", "Peak Number", "Missing (%)");
+ print(xtable::xtable(dt,
+ caption="Summary of peaks information of all spectra after processing"),
+ caption.placement="top",
+ size="\\scriptsize");
+ }
+};
+CreateBPI<- function(){
+
+ descr <- c("\\subsection{Base Peak Ion (BPI) Chromatogram}\n",
+ "The base peak chromatogram is similar to the TIC, however it only shows the intensity of the most intense signal at every scan across the whole spectrum.",
+ "Base peak chromatograms always have a cleaner and clearer shape and thus are more informative than TIC.",
+ "The spectra signal (ion) flow of all files is displayed in Figure", fig.count<<-fig.count+1,", as below."
+ );
+
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\n", file=rnwFile, append=TRUE);
+
+ cmdhist <- c( "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=0.75\\textwidth]{BPIS_72.png}", sep=""),
+ "\\caption{Base Peak Ion plot of the spectral processing.}",
+ "\\end{center}",
+ "\\end{figure}",
+ "\\clearpage"
+ );
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+};
+createSpectraTIC <- function(){
+
+ descr <- c("\\subsection{TIC of individual spectra}\n",
+ "The TIC plots you are interested in are shown as below."
+ );
+
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\n", file=rnwFile, append=TRUE);
+
+ load("mSet.rda");
+ files <- mSet@rawOnDisk@phenoData@data[["sample_name"]];
+
+ for (i in files){
+ if(file.exists(paste0(i, ".png"))){
+ fig.count<<-fig.count+1;
+ cmdhist <- c( "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=0.75\\textwidth]{", paste0(i, ".png"), "}", sep=""),
+ paste0("\\caption{TIC plot of this spectra: ", gsub("_","-",sub(".png","",i)) ,".}"),
+ "\\end{center}",
+ "\\end{figure}",
+ "\\clearpage"
+ );
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+ }
+ }
+
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+};
+
+### Section 4 - Processing feature
+CreateFeatureSum <- function(){
+ descr <- c("\\section{Raw Spectra Processing - Feature summary}\n",
+ "All spectra files included for processing in this module have been processed.",
+ "All features processing result across the different spectra are shown as below, including peak feature summary,
+ and the corresponding Extracted Ion Chromatogram (EIC/XIC) of the features you are interested in.");
+ cat(descr, file=rnwFile, append=TRUE);
+
+ descr1 <- c(
+ "Here is a brief content of this section",
+ "\\begin{itemize}",
+ "\\item{EIC/XIC}",
+ "\\item{Feature (EIC/XIC) Stats}",
+ #"\\item{Peak Feature Detail}",
+ "\\end{itemize}")
+
+ cat(descr1, file=rnwFile, append=TRUE);
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+
+ createFeatureEIC(); # Done
+ createFeatureEICStats(); # Done
+ #createFeatureSumDoc(); # Cancelled
+
+ # Adding more and do some optimization in future
+
+};
+createFeatureEIC <- function(){
+
+ descr <- c("\\subsection{EIC/XIC of individual feature}\n",
+ "The ones you are interested in at the analyzing stage are shown as below."
+ );
+
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\n", file=rnwFile, append=TRUE);
+
+ files <- list.files(pattern = "^EIC.*mz@")
+
+ for (i in files){
+ if(file.exists(i)){
+
+ if(grepl("s_sample_", i)){
+ fig.count<<-fig.count+1;
+ cmdhist <- c( "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=0.75\\textwidth]{", i, "}", sep=""),
+ paste0("\\caption{EIC of feature of individual samples: ", gsub("_","-",sub(".png","",i)),"}"),
+ "\\end{center}",
+ "\\end{figure}",
+ "\\clearpage"
+ )
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+ }
+
+ if(grepl("s_group_", i)){
+ fig.count<<-fig.count+1;
+ cmdhist <- c( "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=0.75\\textwidth]{", i, "}", sep=""),
+ paste0("\\caption{EIC of feature of groups: ", gsub("_","-",sub(".png","",i)),"}"),
+ "\\end{center}",
+ "\\end{figure}",
+ "\\clearpage"
+ )
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+ }
+
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+ }
+ }
+
+};
+createFeatureEICStats <- function(){
+
+ descr <- c("\\subsection{EIC/XIC Stats of individual feature}\n",
+ "The ones you are interested in at the analyzing stage are shown as below."
+ );
+
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\n", file=rnwFile, append=TRUE);
+
+ files <- list.files(pattern = "^[^(EIC)].*mz@.*s.png")
+
+ for (i in files){
+ if(file.exists(i)){
+ if(grepl("mz@", i)){
+ fig.count<<-fig.count+1;
+ cmdhist <- c( "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=0.75\\textwidth]{", i, "}", sep=""),
+ paste0("\\caption{Feature intensity statis box plot of different groups: ", gsub("_","-",sub(".png","",i)),"}"),
+ "\\end{center}",
+ "\\end{figure}",
+ "\\clearpage"
+ )
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+ #cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+ }
+ }
+ }
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+};
+createFeatureSumDoc <- function(){
+
+ descr <- c("\\subsection{Spectra Summary}\n",
+ "The features basic information and its annotation results after processing is summarized in",
+ table.count<<-table.count+1,", as below."
+ );
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+ cmdhist2 <- c("<<echo=false, results=tex>>=",
+ "createFeatureSumTable()",
+ "@");
+ cat(cmdhist2, file=rnwFile, append=TRUE, sep="\n");
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+
+};
+createFeatureSumTable <- function(){
+
+ # if(file.exists("peak_feature_summary.csv")){
+ # dt <- read.csv("peak_feature_summary.csv");
+ # print(xtable::xtable(dt,
+ # caption="Summary of features information after processing"),
+ # caption.placement="top",
+ # size="\\scriptsize",tabular.environment = "longtable");
+ # }
+
+};
+
+
+
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_stats.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_stats.R
new file mode 100755
index 0000000000000000000000000000000000000000..eaf38dd3b30ecff4255d62892a2cba464cfe63ea
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_stats.R
@@ -0,0 +1,1415 @@
+#'Create report for statistical analysis module
+#'@description Report generation using Sweave
+#'Write .Rnw file template
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param usrName Input the name of the user
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+CreateStatRnwReport <- function(mSetObj, usrName){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ CreateHeader(usrName);
+ CreateStatIntr();
+
+ CreateStatIOdoc(mSetObj);
+ CreateNORMdoc(mSetObj);
+
+ InitStatAnalMode();
+ if(exists("analSet", where = mSetObj)){
+ CreateUNIVdoc(mSetObj);
+ CreateANOVAdoc(mSetObj);
+ CreateCorrDoc(mSetObj);
+ CreatePCAdoc(mSetObj);
+ CreatePLSdoc(mSetObj);
+ CreateOPLSDAdoc(mSetObj);
+ CreateSPLSDAdoc(mSetObj);
+ CreateSAMdoc(mSetObj);
+ CreateEBAMdoc(mSetObj);
+ CreateHCdoc(mSetObj);
+ CreateKMdoc(mSetObj);
+ CreateSOMdoc(mSetObj);
+ CreateRFdoc(mSetObj);
+ CreateSVMdoc(mSetObj);
+ }else{
+ CreateAnalNullMsg();
+ }
+ CreateRHistAppendix();
+ CreateFooter();
+
+}
+
+#'Create report of analyses
+#'@description Report generation using Sweave
+#'Create header
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+CreateStatIntr <- function(){
+ descr <- c("\\section{Data Processing and Normalization}\n");
+ cat(descr, file=rnwFile, append=TRUE);
+}
+
+#'Create report of analyses
+#'@description Report generation using Sweave
+#'Read and process raw data
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+CreateStatIOdoc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ descr <- c("\\subsection{Reading and Processing the Raw Data}\n",
+ "MetaboAnalyst accepts a variety of data types generated in metabolomic studies,",
+ "including compound concentration data, binned NMR/MS spectra data, NMR/MS peak",
+ "list data, as well as MS spectra (NetCDF, mzXML, mzDATA).",
+ "Users need to specify the data types when uploading their data in order for",
+ "MetaboAnalyst to select the correct algorithm to process them.\n",
+ paste("Table", table.count<<-table.count+1,"summarizes the result of the data processing steps.\n")
+ );
+ cat(descr, file=rnwFile, append=TRUE);
+
+ # error checking
+ if(is.null(mSetObj$dataSet$orig.var.nms) | is.null(mSetObj$dataSet$proc) | is.null(mSetObj$dataSet$cls)){
+ errorMsg <- c(descr, "Error occured during reading the raw data ....",
+ "Failed to proceed. Please check if the data format you uploaded is correct.",
+ "Please visit our FAQs, Data Formats, and TroubleShooting pages for more information!\n");
+ cat(errorMsg, file=rnwFile, append=TRUE);
+ return();
+ }
+
+ if(mSetObj$dataSet$type=="conc"){
+ descr <- c("\\subsubsection{Reading Concentration Data}\n",
+ "The concentration data should be uploaded in comma separated values (.csv) format.",
+ "Samples can be in rows or columns, with class labels immediately following the sample IDs.\n");
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+ cat(mSetObj$msgSet$read.msg, file=rnwFile, append=TRUE, sep="\n");
+
+ }else if(mSetObj$dataSet$type=="specbin"){
+ descr <- c("\\subsubsection{Reading Binned Spectral Data}\n",
+ "The binned spectra data should be uploaded in comma seperated values (.csv) format.",
+ "Samples can be in rows or columns, with class labels immediately following the sample IDs.\n");
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+ cat(mSetObj$msgSet$read.msg, file=rnwFile, append=TRUE, sep="\n");
+
+ }else if(mSetObj$dataSet$type=="pktable"){
+ descr <- c("\\subsubsection{Reading Peak Intensity Table}\n",
+ "The peak intensity table should be uploaded in comma separated values (.csv) format.",
+ "Samples can be in rows or columns, with class labels immediately following the sample IDs.\n");
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+ cat(mSetObj$msgSet$read.msg, file=rnwFile, append=TRUE, sep="\n");
+
+ }else if(mSetObj$dataSet$type=="nmrpeak"){
+ descr <- c("\\subsubsection{Reading NMR Peak List and Intensities Data}\n",
+ "NMR peak list and intensities data should be uploaded as one zip file. It contains subfolders, one for",
+ "each group. Each folder contains peak list files, one per spectrum. The peak list format",
+ "is a a two-column comma separated values - the first column indicates peak position (ppm)",
+ "and the second one for peak intensities. The first line is assumed to be column labels.",
+ "The files should be saved in .csv format. For paired analysis, users need to upload",
+ "a text file specifying the paired information. Each pair is indicated by their sample names",
+ "seperated by a colon \":\" with one pair per line.\n");
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+ cat(mSetObj$msgSet$read.msg, file=rnwFile, append=TRUE, sep="\n");
+
+ descr <- c("\\subsubsection{Peak List Alignment}\n",
+ "Proximal peaks are first grouped together based on their position using a moving window of 0.03 ppm",
+ "and a step of 0.015 ppm. Peaks of the same group are aligned to their median positions across all samples.",
+ "If more than one peak from the same sample appear in the same group, they will be replaced by their sum.",
+ "Some peaks that are detected in very few samples (less than half in both classes) are excluded.",
+ "The aligned peaks are reorganized into a single data matrix for further analysis. The name of the parent",
+ "folder is used as class label for each sample.\n");
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+ cat(mSetObj$msgSet$proc.msg, file=rnwFile, append=TRUE, sep="\n");
+
+ }else if(mSetObj$dataSet$type=="mspeak"){
+ descr <- c("\\subsubsection{Reading MS Peak List and Intensities Data}\n",
+ "MS peak list and intensities data should be uploaded as one zip file. It contains subfoulders with one for",
+ "each group. Each folder contains peak list files, one per spectrum. The MS peak list format",
+ "is either a two-column (mass and intensities) or three-column (mass, retention time, and intensities)",
+ "comma separated values. The first line is assumed to be column labels.",
+ "The files should be saved in .csv format. For paired analysis, users need to upload separately",
+ "a text file specifying the paired information. Each pair is indicated by their sample names",
+ "seperated by a colon \":\" with one pair per line.\n");
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+ cat(mSetObj$msgSet$read.msg, file=rnwFile, append=TRUE, sep="\n");
+
+ descr <- c("\\subsubsection{Peak Matching and Alignment}\n",
+ "Peaks need to be matched across samples in order to be compared. For two-column data, the",
+ "program matches peaks by their m/z values. For three-column data, the program will further",
+ "group peaks based on their retention time. During the process, mz and rt of each peak will",
+ "be changed to their group median values. If a sample has more than one peak in a group,",
+ "they will be replaced by their sum. Some peaks are excluded if they appear in less than half",
+ "of both classes. The aligned peaks are reorganized into a single data matrix for further analysis.",
+ "The name of the parent folder is used as class label for each sample.\n");
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+ cat(mSetObj$msgSet$proc.msg, file=rnwFile, append=TRUE, sep="\n");
+
+ }else{ # spectra
+ descr <- c("\\subsubsection{Reading GC/LC-MS Spectra}\n",
+ "The spectra processing is carried out using the XCMS package.",
+ "\\footnote{Colin A. Smith and Ralf Tautenhahn. \\textit{xcms: LC\\slash MS and",
+ "GC\\slash MS Data Analysis}, 2008, R package version 1.14.0}",
+ "Raw GC/LC-MS spectra can be in either NetCDF, mzXML or mzData format.",
+ "You should create a separate folder for each group and create a",
+ "single zip file to upload to MetaboAnalyst. The size limit for each uploaded file is 50M.\n");
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+ cat(mSetObj$msgSet$read.msg, file=rnwFile, append=TRUE, sep="\n");
+
+ descr <- c("\\subsubsection{Peak Alignment and Retention Time Correction}\n",
+ "In this step, the program automatically performs peak detection and peak alignment based on mass and",
+ "retention time. The aligned peaks are reorganized into a data matrix for further analysis.",
+ "Please note, the name of the parent folder is used as class label for each sample.\n");
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+ cat(c(mSetObj$msgSet$xset.msg, paste("Please see Figure", fig.count<<-fig.count+1, "for a summary graph.")), file=rnwFile, append=TRUE, sep="\n");
+
+ cmdhist <- c(
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$msrt,"}", sep=""),
+ "\\caption{Retention time deviation profiles used for sample alignment.
+ The data points used for generating each profile are also shown.
+ All times are in seconds. A negative number indicates a sample was eluting
+ before most of the others, and vice versa.}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$msrt,"}", sep=""),
+ "\\end{figure}"
+ );
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+}
+
+ # the last step is sanity check
+ descr <- c("\\subsubsection{Data Integrity Check}\n",
+ "Before data analysis, a data integrity check is performed to make sure that all the necessary",
+ "information has been collected. The class labels must be present and contain only two classes.",
+ "If samples are paired, the class label must be from -n/2 to -1 for one group, and 1 to n/2 for the other group",
+ "(n is the sample number and must be an even number). Class labels with same absolute value are assumed to be pairs.",
+ "Compound concentration or peak intensity values should all be non-negative numbers.",
+ "By default, all missing values, zeros and negative values will be replaced by the half of the minimum positive value",
+ "found within the data (see next section)");
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+ descr <- c("\\subsubsection{Missing value imputations}\n",
+ "Too many zeroes or missing values will cause difficulties for downstream analysis.",
+ "MetaboAnalyst offers several different methods for this purpose. The default method replaces ",
+ "all the missing and zero values with a small values (the half of the minimum positive",
+ "values in the original data) assuming to be the detection limit. The assumption of this approach",
+ "is that most missing values are caused by low abundance metabolites (i.e.below the detection limit).",
+ "In addition, since zero values may cause problem for data normalization (i.e. log), they are also ",
+ "replaced with this small value. User can also specify other methods, such as replace by mean/median,",
+ "or use K-Nearest Neighbours (KNN), Probabilistic PCA (PPCA), Bayesian PCA (BPCA) method, Singular Value Decomposition (SVD)",
+ "method to impute the missing values \\footnote{Stacklies W, Redestig H, Scholz M, Walther D, Selbig J.",
+ "\\textit{pcaMethods: a bioconductor package, providing PCA methods for incomplete data.}, Bioinformatics",
+ "2007 23(9):1164-1167}. Please choose the one that is the most appropriate for your data.");
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+ cat(mSetObj$msgSet$replace.msg, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+ # the data filtering
+ descr <- c("\\subsubsection{Data Filtering}\n",
+ "The purpose of the data filtering is to identify and remove variables that are unlikely to be of",
+ "use when modeling the data. No phenotype information are used in the filtering process, so the result",
+ "can be used with any downstream analysis. This step can usually improves the results.",
+ "Data filter is strongly recommended for datasets with large number of variables (> 250)",
+ "datasets contain much noise (i.e.chemometrics data). Filtering can usually improve your",
+
+ "results\\footnote{Hackstadt AJ, Hess AM.\\textit{Filtering for increased power for microarray data analysis},",
+ "BMC Bioinformatics. 2009; 10: 11.}.",
+ "\n\n",
+ "\\textit{For data with number of variables < 250, this step will reduce 5\\% of variables;",
+ "For variable number between 250 and 500, 10\\% of variables will be removed;",
+ "For variable number bwteen 500 and 1000, 25\\% of variables will be removed;",
+ "And 40\\% of variabled will be removed for data with over 1000 variables.",
+ "The None option is only for less than 5000 features. Over that, if you choose None,",
+ "the IQR filter will still be applied. In addition, the maximum allowed number of variables is \\textbf{10000}}");
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+ filt.msg <- mSetObj$msgSet$filter.msg;
+ if(is.null(filt.msg)){
+ filt.msg <- "No data filtering was performed.";
+ }
+ cat(filt.msg, file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+ cmdhist2 <- c("<<echo=false, results=tex>>=",
+ "CreateSummaryTable(mSet)",
+ "@");
+ cat(cmdhist2, file=rnwFile, append=TRUE, sep="\n");
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+}
+
+#'Introduction for statistical analysis module report
+#'Initialize Statistical Analysis Report
+#'@export
+InitStatAnalMode <- function(){
+ descr <- c("\\section{Statistical and Machine Learning Data Analysis}",
+ "MetaboAnalyst offers a variety of methods commonly used in metabolomic data analyses.",
+ "They include:\n");
+ cat(descr, file=rnwFile, append=TRUE, sep="\n");
+
+ descr2 <- c(
+ "\\begin{enumerate}",
+ "\\item{Univariate analysis methods: }",
+ "\\begin{itemize}",
+ "\\item{Fold Change Analysis }",
+ "\\item{T-tests}",
+ "\\item{Volcano Plot}",
+ "\\item{One-way ANOVA and post-hoc analysis}",
+ "\\item{Correlation analysis}",
+ "\\end{itemize}",
+ "\\item{Multivariate analysis methods: }",
+ "\\begin{itemize}",
+ "\\item{Principal Component Analysis (PCA) }",
+ "\\item{Partial Least Squares - Discriminant Analysis (PLS-DA) }",
+ "\\end{itemize}",
+ "\\item{Robust Feature Selection Methods in microarray studies }",
+ "\\begin{itemize}",
+ "\\item{Significance Analysis of Microarray (SAM)}",
+ "\\item{Empirical Bayesian Analysis of Microarray (EBAM)}",
+ "\\end{itemize}",
+ "\\item{Clustering Analysis}",
+ "\\begin{itemize}",
+ "\\item{Hierarchical Clustering}",
+ "\\begin{itemize}",
+ "\\item{Dendrogram}",
+ "\\item{Heatmap}",
+ "\\end{itemize}",
+ "\\item{Partitional Clustering}",
+ "\\begin{itemize}",
+ "\\item{K-means Clustering}",
+ "\\item{Self-Organizing Map (SOM)}",
+ "\\end{itemize}",
+ "\\end{itemize}",
+ "\\item{Supervised Classification and Feature Selection methods}",
+ "\\begin{itemize}",
+ "\\item{Random Forest}",
+ "\\item{Support Vector Machine (SVM)}",
+ "\\end{itemize}",
+ "\\end{enumerate}",
+ "\\texttt{Please note: some advanced methods are available only for two-group sample analyais.}",
+ "\\clearpage"
+ );
+ cat(descr2, file=rnwFile, append=TRUE, sep="\n");
+}
+
+
+#'Create null message for analysis
+#'Creates a message for the Sweave report
+#'@description Creates a message stating that no analyses were performed on your data.
+#'@export
+CreateAnalNullMsg <- function(){
+ descr <- c("No analysis was performed on your data.\n");
+ cat(descr, file=rnwFile, append=TRUE, sep="\n");
+}
+
+#'Create report of analyses
+#'@description Report generation using Sweave
+#'Create univariate analyses document
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateUNIVdoc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # need to check if this process is executed
+ if(is.null(mSetObj$analSet$fc) & is.null(mSetObj$analSet$tt) & is.null(mSetObj$analSet$volcano)){
+ return();
+ }
+
+ if(isEmptyMatrix(mSetObj$analSet$fc$sig.mat)){
+ fc.img <- fc.tab<-NULL;
+ }else{
+ fc.img <- paste("Figure", fig.count<<-fig.count+1,"shows the important features identified by fold change analysis.");
+ fc.tab<-paste("Table", table.count<<-table.count+1,"shows the details of these features;");
+ }
+ if(isEmptyMatrix(mSetObj$analSet$tt$sig.mat)){
+ tt.img <- tt.tab<-NULL;
+ }else{
+ tt.img <- paste("Figure", fig.count<<-fig.count+1,"shows the important features identified by t-tests.");
+ tt.tab<-paste("Table", table.count<<-table.count+1,"shows the details of these features;");
+ }
+ if(isEmptyMatrix(mSetObj$analSet$volcano$sig.mat)){
+ volcano.img <- volcano.tab<-NULL;
+ }else{
+ volcano.img <-paste("Figure", fig.count<<-fig.count+1,"shows the important features identified by volcano plot.");
+ volcano.tab<-paste("Table", table.count<<-table.count+1,"shows the details of these features.");
+ }
+
+ descr <- c("\\subsection{Univariate Analysis}\n",
+ "Univariate analysis methods are the most common methods used for exploratory data analysis. ",
+ "For two-group data, MetaboAnalyst provides Fold Change (FC) analysis, t-tests, and volcano",
+ "plot which is a combination of the first two methods. All three these methods support both",
+ "unpaired and paired analyses. For multi-group analysis, MetaboAnalyst provides two types of",
+ "analysis - one-way analysis of variance (ANOVA) with associated post-hoc analyses, and correlation",
+ "analysis to identify signficant compounds that follow a given pattern. The univariate analyses provide",
+ "a preliminary overview about features that are potentially significant in discriminating",
+ "the conditions under study.",
+ "\n\n",
+ "For paired fold change analysis, the algorithm first counts the total number of pairs with fold changes",
+ "that are consistently above/below the specified FC threshold for each variable. A variable will be",
+ "reported as significant if this number is above a given count threshold (default > 75\\% of pairs/variable)",
+ "\n\n",
+ fc.img,
+ fc.tab,
+ tt.img,
+ tt.tab,
+ volcano.img,
+ volcano.tab,
+ "\n\n",
+ "Please note, the purpose of fold change is to compare absolute value changes between two group means.",
+ "Therefore, the data before column normalization will be used instead. Also note, the result is plotted",
+ "in log2 scale, so that same fold change (up/down regulated) will have the same distance to the zero baseline.",
+ "\n");
+
+ cat(descr, file=rnwFile, append=TRUE);
+
+ # Fold change
+ if(!(isEmptyMatrix(mSetObj$analSet$fc$sig.mat))){
+ cmdhist <- c(
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$fc,"}", sep=""),
+ "\\caption{", paste("Important features selected by fold-change analysis with threshold ", mSetObj$analSet$fc$raw.thresh, ". ",
+ "The red circles represent features above the threshold. Note the values are on log scale, so that both up-regulated ",
+ "and down-regulated features can be plotted in a symmetrical way", sep=""), "}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$fc,"}", sep=""),
+ "\\end{figure}"
+ );
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+ cat("\n\n", file=rnwFile, append=TRUE, sep="\n");
+
+ cmdhist2 <- c("<<echo=false, results=tex>>=",
+ "GetSigTable.FC(mSet)",
+ "@");
+ cat(cmdhist2, file=rnwFile, append=TRUE, sep="\n");
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+ }
+
+ # T-tests
+ if(!(isEmptyMatrix(mSetObj$analSet$tt$sig.mat))){
+ cmdhist <- c(
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$tt,"}", sep=""),
+ "\\caption{", paste("Important features selected by t-tests with threshold ", mSetObj$analSet$tt$raw.thresh, ". ",
+ "The red circles represent features above the threshold. Note the p values are transformed by -log10 so that the more significant ",
+ "features (with smaller p values) will be plotted higher on the graph. ", sep=""),"}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$tt,"}", sep=""),
+ "\\end{figure}"
+ );
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+ cat("\n\n", file=rnwFile, append=TRUE, sep="\n");
+
+ cmdhist2<-c("<<echo=false, results=tex>>=",
+ "GetSigTable.TT(mSet)",
+ "@");
+ cat(cmdhist2, file=rnwFile, append=TRUE, sep="\n");
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+ }
+
+ # Volcano plot
+ if(!(isEmptyMatrix(mSetObj$analSet$volcano$sig.mat))){
+ cmdhist <- c(
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$volcano,"}", sep=""),
+ "\\caption{", paste("Important features selected by volcano plot with fold change threshold (x) ",
+ mSetObj$analSet$volcano$raw.threshx, " and t-tests threshold (y) ", mSetObj$analSet$volcano$raw.threshy, ". ",
+ "The red circles represent features above the threshold. Note both fold changes and p values are log ",
+ "transformed. The further its position away from the (0,0), the more significant the feature is. ", sep=""),"}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$volcano,"}", sep=""),
+ "\\end{figure}"
+ );
+
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+ cat("\n\n", file=rnwFile, append=TRUE, sep="\n");
+
+ cmdhist2 <- c("<<echo=false, results=tex>>=",
+ "GetSigTable.Volcano(mSet)",
+ "@");
+ cat(cmdhist2, file=rnwFile, append=TRUE, sep="\n");
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+ }
+}
+
+#'Create report of analyses
+#'@description Report generation using Sweave
+#'Create ANOVA document
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateANOVAdoc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # need to check if this process is executed
+ if(is.null(mSetObj$analSet$aov)){
+ return();
+ }
+
+ if(isEmptyMatrix(mSetObj$analSet$aov$sig.mat)){
+ anova.tab<-NULL;
+ }else{
+ anova.tab <- paste("Table", table.count<<-table.count+1,"shows the details of these features.",
+ "The \\texttt{post-hoc Sig. Comparison} column shows the comparisons between different levels",
+ "that are significant given the p value threshold. ");
+ }
+
+ descr <- c("\\subsection{One-way ANOVA}\n",
+ "Univariate analysis methods are the most common methods used for exploratory data analysis. ",
+ "For multi-group analysis, MetaboAnalyst provides one-way Analysis",
+ "of Variance (ANOVA). As ANOVA only tells whether the overall comparison is significant or not,",
+ "it is usually followed by post-hoc analyses in order to identify which two levels are different.",
+ "MetaboAnalyst provides two most commonly used methods for this purpose - Fisher's",
+ "least significant difference method (Fisher's LSD) and Tukey's Honestly Significant Difference",
+ "(Tukey's HSD). The univariate analyses provide a preliminary overview about features that are",
+ "potentially significant in discriminating the conditions under study.",
+ "\n\n",
+ paste("Figure", fig.count<<-fig.count+1,"shows the important features identified by ANOVA analysis."),
+ anova.tab,
+ "\n");
+
+ cat(descr, file=rnwFile, append=TRUE);
+
+ # ANOVA
+ cmdhist<-c(
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$anova,"}", sep=""),
+ "\\caption{", paste("Important features selected by ANOVA plot with p value threshold ",
+ mSetObj$analSet$aov$raw.thresh, ". ", sep=""),"}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$anova,"}", sep=""),
+ "\\end{figure}"
+ );
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+ cat("\n\n", file=rnwFile, append=TRUE, sep="\n");
+
+ cmdhist2 <- c("<<echo=false, results=tex>>=",
+ "GetSigTable.Anova(mSet)",
+ "@");
+ cat(cmdhist2, file=rnwFile, append=TRUE, sep="\n");
+
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+}
+
+#'Create report of analyses
+#'@description Report generation using Sweave
+#'Create correlation document
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateCorrDoc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # need to check if this process is executed
+ if(is.null(mSetObj$analSet$cor.res) & is.null(mSetObj$imgSet$corr.heatmap)){
+ return();
+ }
+
+ # need to check if this process is executed
+ if(!is.null(mSetObj$imgSet$corr.heatmap)){
+ descr <- c("\\subsection{Correlation Analysis}\n",
+ "Correlation analysis can be used to visualize the overall correlations between different features",
+ "It can also be used to identify which features are correlated with a feature of interest.",
+ "Correlation analysis can also be used to identify if certain features show particular patterns",
+ "under different conditions. Users first need to define a pattern in the form of a series of hyphenated numbers.",
+ "For example, in a time-series study with four time points, a pattern of of",
+ "\\texttt{1-2-3-4} is used to search compounds with increasing the concentration as",
+ "time changes; while a pattern of \\texttt{3-2-1-3} can be used to search compounds",
+ "that decrease at first, then bounce back to the original level.",
+ "\n\n",
+ paste("Figure", fig.count<<-fig.count+1, "shows the overall correlation heatmap."),
+ "\n");
+
+ cat(descr, file=rnwFile, append=TRUE);
+
+ cmdhist<-c(
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$corr.heatmap,"}", sep=""),
+ "\\caption{Correlation Heatmaps}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$corr.heatmap,"}", sep=""),
+ "\\end{figure}"
+ );
+
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+ cat("\n\n", file=rnwFile, append=TRUE, sep="\n");
+ }
+
+ if(!is.null(mSetObj$analSet$cor.res)){
+ if(isEmptyMatrix(mSetObj$analSet$cor.res)){
+ cor.tab <- NULL;
+ }else{
+ cor.tab <- paste("Table", table.count<<-table.count+1,"shows the details of these features.");
+ }
+
+ descr <- c("\\subsection{Correlation Analysis}\n",
+ "Correlation analysis can be used to identify which features are correlated with a feature of interest.",
+ "Correlation analysis can also be used to identify if certain features show particular patterns",
+ "under different conditions. Users first need to define a pattern in the form of a series of hyphenated numbers.",
+ "For example, in a time-series study with four time points, a pattern of of",
+ "\\texttt{1-2-3-4} is used to search compounds with increasing the concentration as",
+ "time changes; while a pattern of \\texttt{3-2-1-3} can be used to search compounds",
+ "that decrease at first, then bounce back to the original level.",
+ "\n\n",
+ paste("Figure", fig.count<<-fig.count+1, "shows the important features identified by correlation analysis."),
+ cor.tab,
+ "\n");
+
+ cat(descr, file=rnwFile, append=TRUE);
+
+ cmdhist <- c(
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$corr,"}", sep=""),
+ "\\caption{Important features selected by correlation analysis with light",
+ "purple indicates positive correlation and blue indicate negative correlations.}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$corr,"}", sep=""),
+ "\\end{figure}"
+ );
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+ cat("\n\n", file=rnwFile, append=TRUE, sep="\n");
+
+ cmdhist2<-c("<<echo=false, results=tex>>=",
+ "GetSigTable.Corr(mSet)",
+ "@");
+ cat(cmdhist2, file=rnwFile, append=TRUE, sep="\n");
+ }
+
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+}
+
+#'Create report of analyses
+#'@description Report generation using Sweave
+#'Create PCA document
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreatePCAdoc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # need to check if this process is executed
+ if(is.null(mSetObj$analSet$pca)){
+ return();
+ }
+
+ descr <- c("\\subsection{Principal Component Analysis (PCA)}\n",
+ "PCA is an unsupervised method aiming to find the directions that best",
+ "explain the variance in a data set (X) without referring to class labels (Y).",
+ "The data are summarized into much fewer variables called \\textit{scores} which",
+ "are weighted average of the original variables. The weighting profiles are called",
+ "\\textit{loadings}. The PCA analysis is performed using the \\texttt{prcomp} package.",
+ "The calculation is based on singular value decomposition.",
+ "\n\n",
+ "The Rscript \\texttt{chemometrics.R} is required.",
+ paste("Figure", fig.count<<-fig.count+1,"is pairwise score plots providing an overview of the various seperation patterns among the most significant PCs;"),
+ paste("Figure", fig.count<<-fig.count+1,"is the scree plot showing the variances explained by the selected PCs;"),
+ paste("Figure", fig.count<<-fig.count+1,"shows the 2-D scores plot between selected PCs;"),
+ paste("Figure", fig.count<<-fig.count+1,"shows the 3-D scores plot between selected PCs;"),
+ paste("Figure", fig.count<<-fig.count+1,"shows the loadings plot between the selected PCs;"),
+ paste("Figure", fig.count<<-fig.count+1,"shows the biplot between the selected PCs.\n"));
+
+ cat(descr, file=rnwFile, append=TRUE);
+
+ cmdhist <- c(
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$pca.pair,"}", sep=""),
+ "\\caption{Pairwise score plots between the selected PCs. The explained variance of each PC is shown in the corresponding diagonal cell. }",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$pca.pair,"}", sep=""),
+ "\\end{figure}",
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$pca.scree,"}", sep=""),
+ "\\caption{Scree plot shows the variance explained by PCs. The green line on top shows the accumulated variance explained; the blue line underneath shows the variance explained by individual PC.}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$pca.scree,"}", sep=""),
+ "\\end{figure}",
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$pca.score2d,"}", sep=""),
+ "\\caption{Scores plot between the selected PCs. The explained variances are shown in brackets.}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$pca.score2d,"}", sep=""),
+ "\\end{figure}",
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", "scores3D.png","}", sep=""),
+ "\\caption{3D score plot between the selected PCs. The explained variances are shown in brackets.}",
+ "\\end{center}",
+ paste("\\label{","scores3D.png","}", sep=""),
+ "\\end{figure}",
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", "loadings3D.png","}", sep=""),
+ "\\caption{Loadings plot for the selected PCs. }",
+ "\\end{center}",
+ paste("\\label{","loadings3D.png","}", sep=""),
+ "\\end{figure}",
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$pca.biplot,"}", sep=""),
+ "\\caption{PCA biplot between the selected PCs. Note, you may want to test different centering and scaling
+ normalization methods for the biplot to be displayed properly.}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$pca.biplot,"}", sep=""),
+ "\\end{figure}"
+ );
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+}
+
+#'Create report of analyses
+#'@description Report generation using Sweave
+#'Create PLS document
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreatePLSdoc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # need to check if this process is executed
+ if(is.null(mSetObj$analSet$plsr) & is.null(mSetObj$analSet$plsda)){
+ return();
+ }
+
+ descr <- c("\\subsection{Partial Least Squares - Discriminant Analysis (PLS-DA)}\n",
+ "PLS is a supervised method that uses multivariate regression techniques to extract via",
+ "linear combination of original variables (X) the information that can predict the",
+ "class membership (Y). The PLS regression is performed using the \\texttt{plsr} function",
+ "provided by R \\texttt{pls} package\\footnote{Ron Wehrens and Bjorn-Helge Mevik.\\textit{pls: Partial Least",
+ "Squares Regression (PLSR) and Principal Component Regression (PCR)}, 2007,",
+ "R package version 2.1-0}. The classification and cross-validation are performed using the corresponding wrapper",
+ "function offered by the \\texttt{caret} package\\footnote{Max Kuhn. Contributions from",
+ "Jed Wing and Steve Weston and Andre Williams.\\textit{caret: Classification and Regression",
+ "Training}, 2008, R package version 3.45}.",
+ "\n\n",
+ "To assess the significance of class discrimination, a permutation test was performed. In each permutation, a PLS-DA model was",
+ "built between the data (X) and the permuted class labels (Y) using the optimal number of components determined",
+ "by cross validation for the model based on the original class assignment. MetaboAnalyst supports two types of test",
+ "statistics for measuring the class discrimination. The first one is based on prediction accuracy during training.",
+ "The second one is separation distance based on the ratio of the between group sum of the squares and the within",
+ "group sum of squares (B/W-ratio).",
+ "If the observed test statistic is part of the distribution based on the permuted class assignments,",
+ "the class discrimination cannot be considered significant from a statistical point of",
+ "view.\\footnote{Bijlsma et al.\\textit{Large-Scale Human Metabolomics Studies: A Strategy for Data",
+ "(Pre-) Processing and Validation}, Anal Chem. 2006, 78 567 - 574}.",
+ "\n\n",
+ "There are two variable importance measures in PLS-DA. The first, Variable Importance in Projection (VIP) is",
+ "a weighted sum of squares of the PLS loadings taking into account the amount of explained Y-variation",
+ "in each dimension. Please note, VIP scores are calculated for each components. When more than components are used to calculate",
+ "the feature importance, the average of the VIP scores are used. The other importance measure is based",
+ "on the weighted sum of PLS-regression. The weights are a function of the reduction of the sums of squares across the number",
+ "of PLS components. Please note, for multiple-group (more than two) analysis, the same number of predictors will be built for each",
+ "group. Therefore, the coefficient of each feature will be different depending on which group you want to predict.",
+ "The average of the feature coefficients are used to indicate the overall coefficient-based importance. ",
+ "\n\n",
+ paste("Figure", fig.count<<-fig.count+1,"shows the overview of scores plots;"),
+ paste("Figure", fig.count<<-fig.count+1,"shows the 2-D scores plot between selected components;"),
+ paste("Figure", fig.count<<-fig.count+1,"shows the 3-D scores plot between selected components;"),
+ paste("Figure", fig.count<<-fig.count+1,"shows the loading plot between the selected components;"));
+ cat(descr, file=rnwFile, append=TRUE);
+
+
+ descr <- c(paste("Figure", fig.count<<-fig.count+1,"shows the classification performance with different number of components;"),
+ paste("Figure", fig.count<<-fig.count+1,"shows the results of permutation test for model validation;"),
+ paste("Figure", fig.count<<-fig.count+1,"shows important features identified by PLS-DA.\n"));
+ cat(descr, file=rnwFile, append=TRUE);
+
+
+ plsrhist <- c(
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$pls.pair,"}", sep=""),
+ "\\caption{Pairwise scores plots between the selected components. The explained variance of each component is shown in the corresponding diagonal cell. }",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$pls.pair,"}", sep=""),
+ "\\end{figure}",
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$pls.score2d,"}", sep=""),
+ "\\caption{Scores plot between the selected PCs. The explained variances are shown in brackets. }",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$pls.score2d,"}", sep=""),
+ "\\end{figure}",
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$pls.score3d,"}", sep=""),
+ "\\caption{3D scores plot between the selected PCs. The explained variances are shown in brackets.}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$pls.score3d,"}", sep=""),
+ "\\end{figure}",
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$pls.loading,"}", sep=""),
+ "\\caption{Loadings plot between the selected PCs. }",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$pls.loading,"}", sep=""),
+ "\\end{figure}"
+ );
+ cat(plsrhist, file=rnwFile, append=TRUE, sep="\n");
+
+ plsdahist <- c(
+ # classification fig
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$pls.class,"}", sep=""),
+ "\\caption{PLS-DA classification using different number of components. The red star indicates the best classifier.}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$pls.class,"}", sep=""),
+ "\\end{figure}"
+ );
+ cat(plsdahist, file=rnwFile, append=TRUE, sep="\n");
+
+ if(!is.null(mSetObj$imgSet$pls.permut)){ # may not be performed (not by default)
+ plsdahist <- c(
+ # permutation fig
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$pls.permut,"}", sep=""),
+ paste("\\caption{PLS-DA model validation by permutation tests based on ", mSetObj$analSet$plsda$permut.type, ". ",
+ "The p value based on permutation is ", mSetObj$analSet$plsda$permut.p, ".", sep=""), "}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$pls.permut,"}", sep=""),
+ "\\end{figure}"
+ );
+ cat(plsdahist, file=rnwFile, append=TRUE, sep="\n");
+ }
+
+ plsdahist <- c(
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$pls.imp,"}", sep=""),
+ paste("\\caption{Important features identified by PLS-DA. The colored boxes on the right indicate the relative concentrations of the corresponding metabolite in each group
+ under study. }"),
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$pls.imp,"}", sep=""),
+ "\\end{figure}"
+ );
+ cat(plsdahist, file=rnwFile, append=TRUE, sep="\n");
+
+
+ cat("\\clearpage", file=rnwFile, append=TRUE);
+}
+
+#'Create report of analyses
+#'@description Report generation using Sweave
+#'Create sPLS-DA document
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateSPLSDAdoc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # need to check if this process is executed
+ if(is.null(mSetObj$analSet$splsr)){
+ return();
+ }
+
+ descr <- c("\\subsection{Sparse Partial Least Squares - Discriminant Analysis (sPLS-DA)}\n",
+ "The sparse PLS-DA (sPLS-DA) algorithm can be used to effectively reduce the number of variables (metabolites)",
+ "in high-dimensional metabolomics data to produce robust and easy-to-interpret models.",
+ "Users can control the sparseness of the model by controlling the number of components in the model and the number ",
+ "of variables in each component. For more information, please refer to Cao et al. 2011 (PMC3133555). ",
+ "\n\n",
+ paste("Figure", fig.count<<-fig.count+1,"shows the overview of scores plots;"),
+ paste("Figure", fig.count<<-fig.count+1,"shows the 2-D scores plot between selected components;"),
+ paste("Figure", fig.count<<-fig.count+1,"shows the loading plot of the top ranked features;"),
+ paste("Figure", fig.count<<-fig.count+1,"shows the 3-D scores plot between selected components;"),
+ paste("Figure", fig.count<<-fig.count+1,"shows the performance of the sPLS-DA model evaluated using cross-validations;"));
+ cat(descr, file=rnwFile, append=TRUE);
+
+
+ plsrhist <- c(
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$spls.pair,"}", sep=""),
+ "\\caption{Pairwise scores plots between the selected components. The explained variance of each component is shown in the corresponding diagonal cell. }",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$spls.pair,"}", sep=""),
+ "\\end{figure}",
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$spls.score2d,"}", sep=""),
+ "\\caption{Scores plot between the selected PCs. The explained variances are shown in brackets. }",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$spls.score2d,"}", sep=""),
+ "\\end{figure}",
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$spls.score3d,"}", sep=""),
+ "\\caption{3D scores plot between the selected PCs. The explained variances are shown in brackets.}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$pls.score3d,"}", sep=""),
+ "\\end{figure}",
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$spls.imp,"}", sep=""),
+ "\\caption{Plot showing the variables selected by the sPLS-DA model for a given component. The variables are ranked by the absolute values of their loadings.}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$spls.imp,"}", sep=""),
+ "\\end{figure}",
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$splsda.class,"}", sep=""),
+ "\\caption{Plot of the performance of the sPLS-DA model evaluated using cross validations (CV) with increasing numbers
+ of components created using the specified number of the variables. The error rate is on the y-axis and the number of components
+ is on the x-axis.}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$splsda.class,"}", sep=""),
+ "\\end{figure}"
+ );
+ cat(plsrhist, file=rnwFile, append=TRUE, sep="\n");
+
+
+ cat("\\clearpage", file=rnwFile, append=TRUE);
+}
+
+#'Create report of analyses
+#'@description Report generation using Sweave
+#'Create OPLSDA document
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+CreateOPLSDAdoc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # need to check if this process is executed
+ if(is.null(mSetObj$analSet$oplsda)){
+ return();
+ }
+
+ descr <- c("\\subsection{Orthogonal-Orthogonal Projections to Latent Structures Discriminant Analysis (OPLS-DA)}\n",
+ "OPLS-DA, like PLS-DA, is a powerful tool used for dimension reduction and identification of spectral features that ",
+ "drive group separation. It is a supervised modeling method, and may be used instead of PLS-DA due to its capablitities ",
+ "to distinguish between variations in a dataset relevant to predicting group-labels and variations irrelevant",
+ " to predicting group-labels. In this sense, OPLS-DA tends to make models that are less complex and more insightful",
+ " than PLS-DA. However, both OPLS-DA and PLS-DA are prone to create models that over-fit data, therefore requiring ",
+ "cross-validation to ensure model reliability. For further details, please refer to Worley and Powers 2013 (PMC4465187) ",
+ "and Worley and Powers 2016 (PMC4990351). The permutation testing for OPLS-DA is provided from Szymanska et al. 2012.",
+ "\n\n",
+ paste("Figure", fig.count<<-fig.count+1,"shows the score plot for all metabolite features;"),
+ paste("Figure", fig.count<<-fig.count+1,"shows the variable importance in an OPLS-DA model;"),
+ paste("Figure", fig.count<<-fig.count+1,"shows the model overview;"),
+ paste("Figure", fig.count<<-fig.count+1,"shows the results of the permutation tests for the models;"));
+ cat(descr, file=rnwFile, append=TRUE);
+
+
+ oplsrhist<-c(
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$opls.score2d,"}", sep=""),
+ "\\caption{OPLS-DA score plot of all metabolite features. }",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$opls.score2d,"}", sep=""),
+ "\\end{figure}",
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$opls.loading,"}", sep=""),
+ "\\caption{OPLS-DA loadings S-plot showing the variable importance in a model, combining the covariance and the correlation (p(corr)) loading profile. }",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$opls.loading,"}", sep=""),
+ "\\end{figure}",
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$opls.class,"}", sep=""),
+ "\\caption{Model overview of the OPLS-DA model for the provided dataset. It shows the R2X, R2Y, and Q2 coefficients for the groups.}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$opls.class,"}", sep=""),
+ "\\end{figure}",
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$opls.permut,"}", sep=""),
+ "\\caption{Permutation analysis, showing the observed and cross-validated R2Y and Q2 coefficients. }",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$opls.permut,"}", sep=""),
+ "\\end{figure}"
+ );
+ cat(oplsrhist, file=rnwFile, append=TRUE, sep="\n");
+
+ cat("\\clearpage", file=rnwFile, append=TRUE);
+}
+
+#'Create report of analyses
+#'@description Report generation using Sweave
+#'Create SAM document
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+CreateSAMdoc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # need to check if this process is executed
+ if(is.null(mSetObj$analSet$sam)){
+ return();
+ }
+
+ if(isEmptyMatrix(mSetObj$analSet$sam.cmpds)){
+ sam.tab <- NULL;
+ }else{
+ sam.tab <- paste("Table", table.count<<-table.count+1,"shows the details of these features.");
+ }
+
+ descr <- c("\\subsection{Significance Analysis of Microarray (SAM)}\n",
+ "SAM is a well-established statistical method for identification",
+ "of differentially expressed genes in microarray data analysis. It is designed",
+ "to address the false discovery rate (FDR) when running multiple tests on high-dimensional",
+ "microarray data. SAM assigns a significance score to each variable based on its change",
+ "relative to the standard deviation of repeated measurements. For a variable with scores",
+ "greater than an adjustable threshold, its relative difference is compared to the",
+ "distribution estimated by random permutations of the class labels. For each threshold,",
+ "a certain proportion of the variables in the permutation set will be found to be significant",
+ "by chance. The proportion is used to calculate the FDR. SAM is performed using the",
+ "\\texttt{siggenes} package\\footnote{Holger Schwender. \\textit{siggenes: Multiple testing using",
+ "SAM and Efron's empirical Bayes approaches},2008, R package version 1.16.0}.",
+ "Users need to specify the \\texttt{Delta} value to control FDR in order to proceed.",
+ "\n\n",
+ paste("Figure", fig.count<<-fig.count+1,"shows the significant features identified by SAM."),
+ sam.tab,
+ "\n");
+
+ cat(descr, file=rnwFile, append=TRUE);
+
+ cmdhist <- c(
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$sam.cmpd,"}", sep=""),
+ "\\caption{Significant features identified by SAM. The green circles represent features
+ that exceed the specified threshold. }",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$sam.cmpd,"}", sep=""),
+ "\\end{figure}"
+ );
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+ cat("\n\n", file=rnwFile, append=TRUE, sep="\n");
+ cmdhist2 <- c("<<echo=false, results=tex>>=",
+ "GetSigTable.SAM(mSet)",
+ "@");
+ cat(cmdhist2, file=rnwFile, append=TRUE, sep="\n");
+ cat("\\clearpage", file=rnwFile, append=TRUE);
+}
+
+#'Create report of analyses
+#'@description Report generation using Sweave
+#'Create EBAM document
+#'Note: the search for delta (SAM) and a0 (EBAM) will not be plotted
+#'it is only exploration, and may cause potential inconsistentcies.
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+CreateEBAMdoc <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ # need to check if this process is executed
+ if(is.null(mSetObj$analSet$ebam)){
+ return();
+ }
+
+ if(isEmptyMatrix(mSetObj$analSet$ebam.cmpds)){
+ ebam.tab<-NULL;
+ }else{
+ ebam.tab <- paste("Table", table.count<<-table.count+1,"shows the details of these features.");
+ }
+
+ descr <- c("\\subsection{Empirical Bayesian Analysis of Microarray (EBAM)}\n",
+ "EBAM is an empirical Bayesian method based on moderated t-statistics.",
+ "EBAM uses a two-group mixture model for null and significant features.",
+ "The prior and density parameters are estimated from the data. A feature is",
+ "considered significant if its calculated posterior is larger than or equal to",
+ "\\texttt{delta} and no other features with a more extreme test score that",
+ "is not called signicant. The default is \\texttt{delta} = 0.9.",
+ "The suggested fudge factor (\\texttt{a0}) is chosen that leads to the largest number",
+ "of significant features. EBAM is performed with \\texttt{ebam} function in",
+ "\\texttt{siggenes} package\\footnote{Holger Schwender. \\textit{siggenes: Multiple testing using",
+ "SAM and Efron's empirical Bayes approaches},2008,R package version 1.16.0}.",
+ "\n\n",
+ paste("Figure", fig.count<<-fig.count+1,"shows the important features identified by EBAM."),
+ ebam.tab,
+ "\n");
+
+ cat(descr, file=rnwFile, append=TRUE);
+
+ cmdhist <- c(
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$ebam.cmpd,"}", sep=""),
+ "\\caption{Significant features identified by EBAM. The green circles represent features
+ that exceed the specified threshold. }",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$ebam.cmpd,"}", sep=""),
+ "\\end{figure}"
+ );
+
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+ cat("\n\n", file=rnwFile, append=TRUE, sep="\n");
+ cmdhist2 <- c("<<echo=false, results=tex>>=",
+ "GetSigTable.EBAM(mSet)",
+ "@");
+ cat(cmdhist2, file=rnwFile, append=TRUE, sep="\n");
+ cat("\\clearpage", file=rnwFile, append=TRUE);
+}
+
+#'Create report of analyses
+#'@description Report generation using Sweave
+#'Create hierarchical clustering document
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+CreateHCdoc <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+
+ # need to check if this process is executed
+ if(is.null(mSetObj$analSet$tree) & is.null(mSetObj$analSet$htmap)){
+ return();
+ }
+
+ descr <- c("\\subsection{Hierarchical Clustering}\n",
+ "In (agglomerative) hierarchical cluster analysis, each sample begins",
+ " as a separate cluster and the algorithm proceeds to combine them until all",
+ "samples belong to one cluster. Two parameters need to be considered when performing",
+ "hierarchical clustering. The first one is similarity measure - Euclidean distance,",
+ "Pearson's correlation, Spearman's rank correlation. The other parameter is clustering",
+ "algorithms, including average linkage (clustering uses the centroids of the observations),",
+ "complete linkage (clustering uses the farthest pair of observations between the two groups),",
+ "single linkage (clustering uses the closest pair of observations) and Ward's linkage",
+ "(clustering to minimize the sum of squares of any two clusters). Heatmap is often presented",
+ "as a visual aid in addition to the dendrogram.",
+ "\n\n",
+ "Hierachical clustering is performed with the \\texttt{hclust} function in package \\texttt{stat}.",
+ paste("Figure", fig.count<<-fig.count+1,"shows the clustering result in the form of a dendrogram."),
+ paste("Figure", fig.count<<-fig.count+1,"shows the clustering result in the form of a heatmap.\n"));
+
+ cat(descr, file=rnwFile, append=TRUE);
+
+ if(!is.null(mSetObj$analSet$tree)){
+ cmdhist <- c(
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$tree,"}", sep=""),
+ paste("\\caption{Clustering result shown as dendrogram (",
+ "distance measure using ", "\\texttt{", mSetObj$analSet$tree$dist.par, "}, and clustering algorithm using ", "\\texttt{", mSetObj$analSet$tree$clust.par, "}).}", sep=""),
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$tree,"}", sep=""),
+ "\\end{figure}"
+ );
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+ }
+ if(!is.null(mSetObj$analSet$htmap)){
+ cmdhist <- c(
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$heatmap,"}", sep=""),
+ paste("\\caption{Clustering result shown as heatmap (",
+ "distance measure using ", "\\texttt{", mSetObj$analSet$htmap$dist.par, "}, and clustering algorithm using ", "\\texttt{", mSetObj$analSet$htmap$clust.par, "}).}", sep=""),
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$heatmap,"}", sep=""),
+ "\\end{figure}"
+ );
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+ }
+ cat("\\clearpage", file=rnwFile, append=TRUE);
+}
+
+#'Create report of analyses
+#'@description Report generation using Sweave
+#'Create SOM partitional clustering document
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateSOMdoc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+ # need to check if this process is executed
+ if(is.null(mSetObj$analSet$som)){
+ return();
+ };
+
+ descr <- c("\\subsection{Self Organizing Map (SOM)}\n",
+ "SOM is an unsupervised neural network algorithm used to automatically",
+ "identify major trends present in high-dimensional data. SOM is based",
+ "on a grid of interconnected nodes, each of which represents a model.",
+ "These models begin as random values, but during the process of iterative training",
+ "they are updated to represent different subsets of the training set.",
+ "Users need to specify the x and y dimension of the grid to perform SOM analysis.",
+ "\n\n",
+ "The SOM is performed using the R \\texttt{som} package\\footnote{Jun Yan. \\textit{som:",
+ "Self-Organizing Map}, 2004, R package version 0.3-4}.",
+ paste("Figure", fig.count<<-fig.count+1,"shows the SOM clustering results."),
+ paste("Table", table.count<<-table.count+1,"shows the members in each cluster from SOM analysis.\n"));
+
+ cat(descr, file=rnwFile, append=TRUE);
+
+ cmdhist <- c(
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$som,"}", sep=""),
+ "\\caption{SOM cluster analysis. The x-axes are features and y-axes are relative",
+ "intensities. The blue lines represent median intensities of corresponding clusters}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$som,"}", sep=""),
+ "\\end{figure}"
+ );
+
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+ cat("\n\n", file=rnwFile, append=TRUE, sep="\n");
+ cmdhist2 <- c("<<echo=false, results=tex>>=",
+ "GetAllSOMClusterMembers(mSet)",
+ "@");
+ cat(cmdhist2, file=rnwFile, append=TRUE, sep="\n");
+ cat("\\clearpage", file=rnwFile, append=TRUE);
+}
+
+#'Create report of analyses
+#'@description Report generation using Sweave
+#'Create Kmeans partitional clustering document
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+
+CreateKMdoc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # need to check if this process is executed
+ if(is.null(mSetObj$analSet$kmeans)){
+ return();
+ }
+
+ descr <- c("\\subsection{K-means Clustering}\n",
+ "K-means clustering is a nonhierarchical clustering technique.",
+ "It begins by creating k random clusters (k is supplied by user).",
+ "The program then calculates the mean of each cluster.",
+ "If an observation is closer to the centroid of another cluster",
+ "then the observation is made a member of that cluster. This process is",
+ "repeated until none of the observations are reassigned to a different cluster.",
+ "\n\n",
+ "K-means analysis is performed using the \\texttt{kmeans} function in the",
+ "package \\texttt{stat}.",
+ paste("Figure", fig.count<<-fig.count+1,"shows clustering the results."),
+ paste("Table", table.count<<-table.count+1,"shows the members in each cluster from K-means analysis.\n"));
+
+ cat(descr, file=rnwFile, append=TRUE);
+
+ cmdhist <- c(
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$kmeans,"}", sep=""),
+ "\\caption{K-means cluster analysis. The x-axes are variable indices and y-axes",
+ "are relative intensities. The blue lines represent median intensities of corresponding clusters}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$kmeans,"}", sep=""),
+ "\\end{figure}"
+ );
+
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+ cat("\n\n", file=rnwFile, append=TRUE, sep="\n");
+ cmdhist2<-c("<<echo=false, results=tex>>=",
+ "GetAllKMClusterMembers(mSet)",
+ "@");
+ cat(cmdhist2, file=rnwFile, append=TRUE, sep="\n");
+ cat("\\clearpage", file=rnwFile, append=TRUE);
+}
+
+#'Create report of analyses
+#'@description Report generation using Sweave
+#'Create Random Forest document
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+CreateRFdoc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # need to check if this process is executed
+ if(is.null(mSetObj$analSet$rf)){
+ return();
+ }
+
+ descr <- c("\\subsection{Random Forest (RF) }\n",
+ "Random Forest is a supervised learning algorithm suitable for high dimensional data analysis.",
+ "It uses an ensemble of classification trees, each of which is grown by random feature",
+ "selection from a bootstrap sample at each branch. Class prediction is based on the",
+ "majority vote of the ensemble. RF also provides other useful information such as OOB",
+ "(out-of-bag) error, variable importance measure, and outlier measures. During tree construction, about",
+ "one-third of the instances are left out of the bootstrap sample. This OOB data",
+ "is then used as test sample to obtain an unbiased estimate of the classification",
+ "error (OOB error). Variable importance is evaluated by measuring the increase of the",
+ "OOB error when it is permuted. The outlier measures are based on the proximities during tree construction.",
+ "\n\n",
+ "RF analysis is performed using the \\texttt{randomForest} package\\footnote{Andy Liaw and",
+ "Matthew Wiener. \\textit{Classification and Regression by randomForest}, 2002, R News}.",
+ paste("Table", table.count<<-table.count+1,"shows the confusion matrix of random forest."),
+ paste("Figure", fig.count<<-fig.count+1,"shows the cumulative error rates of random forest analysis for given parameters.\n"),
+ paste("Figure", fig.count<<-fig.count+1,"shows the important features ranked by random forest.\n"),
+ paste("Figure", fig.count<<-fig.count+1,"shows the outlier measures of all samples for the given parameters.\n"));
+
+ cat(descr, file=rnwFile, append=TRUE);
+
+ cmdhist <- c(
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$rf.cls,"}", sep=""),
+ "\\caption{Cumulative error rates by Random Forest classification. The overall error rate is shown
+ as the black line; the red and green lines represent the error rates for each class.}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$rf.cls,"}", sep=""),
+ "\\end{figure}"
+ );
+
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+
+ cmdhist <- c("<<echo=false, results=tex>>=",
+ "GetRFConf.Table(mSet)",
+ "@",
+ paste("The OOB error is ", GetRFOOB(mSetObj))
+ );
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+
+ cmdhist <- c( "\n\n",
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$rf.imp,"}", sep=""),
+ "\\caption{Significant features identified by Random Forest. The features are ranked by the mean
+ decrease in classification accuracy when they are permuted.}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$rf.imp,"}", sep=""),
+ "\\end{figure}"
+ );
+
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+
+ cmdhist <- c( "\n\n",
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$rf.outlier,"}", sep=""),
+ "\\caption{Potential outliers identified by Random Forest. Only the top five are labeled.}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$rf.outlier,"}", sep=""),
+ "\\end{figure}"
+ );
+
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+ cat("\\clearpage", file=rnwFile, append=TRUE);
+}
+
+#'Create report of analyses
+#'@description Report generation using Sweave
+#'Create R-SVM document
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateSVMdoc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # need to check if this process is executed
+ if(is.null(mSetObj$analSet$svm)){
+ return();
+ }
+
+ descr <- c("\\subsection{Support Vector Machine (SVM)}\n",
+ "SVM aims to find a nonlinear decision function in the input space by mapping the data into a",
+ "higher dimensional feature space and separating it there by means of a maximum margin hyperplane.",
+ "The SVM-based recursive feature selection and classification is performed using the \\texttt{R-SVM}",
+ "script\\footnote{http:\\slash\\slash www.hsph.harvard.edu\\slash bioinfocore\\slash RSVMhome\\slash R-SVM.html}.",
+ "The process is performed recursively using decreasing series of feature subsets (\\texttt{ladder})",
+ "so that different classification models can be calculated. Feature importance is evaluated based on",
+ "its frequencies being selected in the best classifier identified by recursive classification and cross-validation.",
+ "Please note, R-SVM is very computationally intensive. Only the top 50 features (ranked by their p values from t-tests)",
+ "will be evaluated.",
+ "\n\n",
+ "In total,", length(mSetObj$analSet$svm$ladder), "models (levels) were created using",paste(mSetObj$analSet$svm$ladder, collapse=', '), "selected feature subsets.",
+ paste("Figure", fig.count<<-fig.count+1, "shows the SVM classification performance using recursive feature selection."),
+ paste("Figure", fig.count<<-fig.count+1, "shows the signicant features used by the best classifiers.\n"));
+
+ cat(descr, file=rnwFile, append=TRUE);
+
+ cat("\n\n", file=rnwFile, append=TRUE);
+ cmdhist <- c(
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$svm.class,"}", sep=""),
+ "\\caption{Recursive classification with SVM. The red circle indicates the best classifier.}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$svm.class,"}", sep=""),
+ "\\end{figure}",
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$svm,"}", sep=""),
+ "\\caption{Significant features identified by R-SVM. Features are ranked by their frequencies of being selected in the classifer.}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$svm,"}", sep=""),
+ "\\end{figure}"
+ );
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+ cat("\\clearpage", file=rnwFile, append=TRUE);
+}
+
+
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_time.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_time.R
new file mode 100755
index 0000000000000000000000000000000000000000..4c49e859ec0233a70e298622dcf81128fa4a04ef
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_report_time.R
@@ -0,0 +1,497 @@
+#'Create report of analyses (Met Pathway)
+#'@description Report generation using Sweave
+#'Metabolomic pathway analysis
+#'Create timeseries .Rnw file template
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param usrName Input the name of the user
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateTimeSeriesRnwReport <- function(mSetObj, usrName){
+
+ CreateHeader(usrName);
+ CreateTimeSeriesIOdoc(mSetObj);
+ CreateNORMdoc(mSetObj);
+
+ InitTimeSeriesAnal();
+ if(exists("analSet", where=mSetObj)){
+ CreateiPCAdoc(mSetObj);
+ CreateHeatmap2doc(mSetObj);
+ CreateAOV2doc(mSetObj);
+ CreateASCAdoc(mSetObj);
+ CreateMBdoc(mSetObj);
+ }else{
+ CreateTimeSeriesAnalNullMsg();
+ }
+
+ CreateRHistAppendix();
+ CreateFooter();
+}
+
+#'Create report of analyses (Met Pathway)
+#'@description Report generation using Sweave
+#'Metabolomic pathway analysis, time-series
+#'Read and process the raw data
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateTimeSeriesIOdoc <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ descr <- c("\\section{Data Upload and Integrity Checking}\n");
+ cat(descr, file=rnwFile, append=TRUE);
+
+ descr <- c("\\subsection{Upload your data}\n",
+ "For two-factor and time-series data, MetaboAnalyst accepts data uploaded in comma separated values (.csv) format.",
+ "Samples can be in rows or columns. The two factor labels must follow immediately",
+ "after the sample names. For time-series data, the time points group must be named",
+ "as \\textbf{Time}. In addition, the samples collected from the same subject at different time points",
+ "should be consecutive and ordered by the time points. Users need to specify the data types when uploading their data",
+ "in order for MetaboAnalyst to select the correct algorithm to process them.\n",
+ paste("Table", table.count<<-table.count+1,"summarizes the result of the data checking steps.\n")
+ );
+ cat(descr, file=rnwFile, append=TRUE);
+
+ # error checking
+ if(is.null(mSetObj$dataSet$orig.var.nms) | is.null(mSetObj$dataSet$proc) | is.null(mSetObj$dataSet$facA) | is.null(mSetObj$dataSet$facB)){
+ errorMsg<- c(descr, "Error occured during reading the raw data ....",
+ "Failed to proceed. Please check if the data format you uploaded is correct.",
+ "Please visit our FAQs, Data Formats, and TroubleShooting pages for more information!\n");
+ cat(errorMsg, file=rnwFile, append=TRUE);
+ return();
+ }
+
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+ descr <- paste(mSetObj$msgSet$read.msg, collapse="\n");
+ cat(paste("\\texttt{", PrepareLatex(descr), "}"), file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+
+ cmdhist2 <- c("<<echo=false, results=tex>>=",
+ "CreateSummaryTable(mSet)",
+ "@");
+ cat(cmdhist2, file=rnwFile, append=TRUE, sep="\n");
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+
+ # the next step is sanity check
+ descr <- c("\\subsection{Data Integrity Check}\n",
+ "Before data analysis, a data integrity check is performed to make sure that all the necessary",
+ "information has been collected.",
+ "Compound concentration or peak intensity values should all be non-negative numbers.",
+ "By default, all missing values, zeros and negative values will be replaced by the half of the minimum positive value",
+ "found within the data (detection limits).\n\n");
+ cat(descr, file=rnwFile, append=TRUE);
+
+ msgLen <- length(mSetObj$msgSet$check.msg);
+ descr <- paste(mSetObj$msgSet$check.msg[1:(msgLen-2)], collapse="\n");
+ cat(paste("\\texttt{", PrepareLatex(descr), "}"), file=rnwFile, append=TRUE);
+ cat("\n\n", file=rnwFile, append=TRUE);
+}
+
+#'Create report of analyses (Met Pathway)
+#'@description Report generation using Sweave
+#'Metabolomic pathway analysis, time-series analysis
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+InitTimeSeriesAnal <- function(){
+ descr <- c("\\section{Statistical and Machine Learning Data Analysis}",
+ "For two-factor and time-series data, MetaboAnalyst offers several carefully selected methods for general two-factor and time-series",
+ "data analysis. They include:\n");
+ cat(descr, file=rnwFile, append=TRUE, sep="\n");
+
+ descr2 <- c(
+ "\\begin{itemize}",
+
+ "\\item{Data overview: }",
+ "\\begin{itemize}",
+ "\\item{Interactive Principal Component Analysis (iPCA) }",
+ "\\item{Two-way Heatmap clustering and visualization}",
+ "\\end{itemize}",
+
+ "\\item{Univariate method: }",
+ "\\begin{itemize}",
+ "\\item{Two-way between/within-subjects ANOVA}",
+ "\\end{itemize}",
+
+ "\\item{Multivariate approaches}",
+ "\\begin{itemize}",
+ "\\item{ANOVA-Simultaneous Component Analysis (ASCA)}",
+ "\\item{Multivariate Empirical Bayes Analysis (MEBA)}",
+ "\\end{itemize}",
+
+ "\\end{itemize}",
+
+ "\\texttt{Please note: MEBA is only applicable to time-series data analyais.}",
+ "\\clearpage"
+ );
+ cat(descr2, file=rnwFile, append=TRUE, sep="\n");
+}
+
+#'Create null analysis message for time-series sweave report
+#'@description Creates empty time-series analysis message
+#'@export
+CreateTimeSeriesAnalNullMsg<-function(){
+ descr <- c("No analysis was performed on your data.\n");
+ cat(descr, file=rnwFile, append=TRUE, sep="\n");
+}
+
+#'Create report of analyses
+#'@description Report generation using Sweave
+#'For Interactive PCA
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateiPCAdoc <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+
+ # need to check if this process is executed
+ if(is.null(mSetObj$analSet$ipca)){
+ return();
+ }
+
+ descr <- c("\\subsection{Interactive Principal Component Analysis (iPCA)}\n",
+ "PCA is an unsupervised method that aims to find the directions that best",
+ "explain the variance in a data set (X) without referring to class labels (Y).",
+ "The data are summarized into the top three components or PCs that explain most of the",
+ "variations in the data. The result is displayed in an interactive 3D",
+ "visualization system. The system supports pointing-and-clicking, rotating",
+ "zooming(hold down SHIFT key and drag vertically). Clicking any of the displayed",
+ "data points will show the corresponding sample summarized by the top 20 most",
+ "different variables that deviate from the data center.",
+ "\n\n");
+
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+}
+
+#'Create report of analyses
+#'@description Report generation using Sweave
+#'2-way heatmap
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateHeatmap2doc <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ # need to check if this process is executed
+ if(is.null(mSetObj$analSet$htmap2)){
+ return();
+ }
+
+ descr <- c("\\subsection{Two-way Heatmap Visualization}\n",
+ "The heatmap provides direct visualization of all data points in the form",
+ "of colors squares. The color spectrum intuitively indicates the higher or lower values.",
+ "Users can choose different clustering algorithms or distance measures to cluster the",
+ "variables. The samples are ordered by the two factors with default the first factor",
+ "used for primary ordering. Users can choose to switch the order.",
+ "\n\n",
+ paste("Figure", fig.count<<-fig.count+1,"shows the clustering result in the form of a heatmap.\n"));
+
+ cat(descr, file=rnwFile, append=TRUE);
+
+ if(!is.null(mSetObj$analSet$htmap2)){
+ cmdhist<-c(
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$htmaptwo,"}", sep=""),
+ paste("\\caption{Clustering result shown as heatmap (",
+ "distance measure using ", "\\texttt{", mSetObj$analSet$htmap2$dist.par, "}, and clustering algorithm using ", "\\texttt{", mSetObj$analSet$htmap2$clust.par, "}).}", sep=""),
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$htmaptwo,"}", sep=""),
+ "\\end{figure}"
+ );
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+ }
+ cat("\\clearpage", file=rnwFile, append=TRUE);
+}
+
+#'Create report of analyses
+#'@description Report generation using Sweave
+#'ANOVA
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateAOV2doc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # need to check if this process is executed
+ if(is.null(mSetObj$analSet$aov2)){
+ return();
+ }
+
+ if(isEmptyMatrix(mSetObj$analSet$aov2$sig.mat)){
+ aov2.tab<-NULL;
+ }else{
+ aov2.tab<-paste("Table", table.count<<-table.count+1,"shows the details of these features;");
+ }
+
+ descr <- c("\\subsection{Univariate Analysis}\n",
+ "Univariate analysis methods are the most common methods used for exploratory data analysis. ",
+ "For two-factor data, the basic approach is two-way ANOVA. ",
+ "There are two options - between-subjects ANOVA and within-subjects ANOVA. When samples are all from",
+ "independent subjects (i.e. general two-way ANOVA), the between-subjects option should be selected.",
+ "However, time series data contains samples measured from the same subjects from different time points.",
+ "Therefore within-subjects ANOVA should be used.",
+ "\n\n",
+ paste("Figure", fig.count<<-fig.count+1,"shows the important features identified by ANOVA analysis."),
+ aov2.tab,
+ "\n");
+
+ cat(descr, file=rnwFile, append=TRUE);
+
+ cmdhist<-c(
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$anova2,"}", sep=""),
+ "\\caption{Plot of important features selected by two-way ANOVA.}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$anova2,"}", sep=""),
+ "\\end{figure}"
+ );
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+ cat("\n\n", file=rnwFile, append=TRUE, sep="\n");
+
+ cmdhist2<-c("<<echo=false, results=tex>>=",
+ "GetSigTable.Aov2(mSet)",
+ "@");
+ cat(cmdhist2, file=rnwFile, append=TRUE, sep="\n");
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+}
+
+#'Create report of analyses
+#'@description Report generation using Sweave
+#'Random Forest ASCA
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateASCAdoc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # need to check if this process is executed
+ if(is.null(mSetObj$analSet$asca)){
+ return();
+ }
+
+ if(isEmptyMatrix(mSetObj$analSet$asca$sig.list[["Model.a"]])){
+ asca.tab1<-NULL;
+ }else{
+ asca.tab1<-paste("Table", table.count<<-table.count+1,paste("shows features well-modelled by ", mSetObj$dataSet$facA.lbl, ". ", sep=""));
+ }
+
+ if(isEmptyMatrix(mSetObj$analSet$asca$sig.list[["Model.b"]])){
+ asca.tab2<-NULL;
+ }else{
+ asca.tab2<-paste("Table", table.count<<-table.count+1,paste("shows features well-modelled by ", mSetObj$dataSet$facB.lbl, ". ", sep=""));
+ }
+
+ if(isEmptyMatrix(mSetObj$analSet$asca$sig.list[["Model.ab"]])){
+ asca.tab3<-NULL;
+ }else{
+ asca.tab3<-paste("Table", table.count<<-table.count+1, "shows features well-modelled by Interaction model. ");
+ }
+
+ descr <- c("\\subsection{ANOVA - Simultaneous Component Analysis (ASCA)}\n",
+ "ASCA is a multivariate extension of univariate ANOVA approach. It is",
+ "designed to identify the major patterns associated with each factor.",
+ "This implementation supports ASCA model for two factors with one interaction",
+ "effect. The algorithm first partitions the overall data variance (X) into",
+ "individual variances induced by each factor (A and B), as well as by the",
+ "interactions (AB). The formula is shown below with (E) indicates the residual",
+ "Errors: \n\n",
+ "\\textbf{X = A + B + AB + E}",
+ "\n\n",
+ "The SCA part applies PCA to A, B, AB to summarize major variations in each partition.",
+ "Users then detect the major pattern by visualizing the PCA scores plot.",
+ "MetaboAnalyst also provides model validation to test the significance of the effects associated",
+ "with main effects. It is based on the Manly's unrestricted permutation of observation",
+ "then calculate the permuted variation associated with each factor",
+ "Finally, the permuted values are compared with the original variations",
+ "The significant variables are identified based on the leverage and the",
+ "Squared Prediction Errors (SPE) associated with each variables",
+ "Variables with low SPE and higher leverage are modeled well after the major patterns.",
+ "\n\n",
+ paste("Figure", fig.count<<-fig.count+1,"shows the scree plots for each effect model.\n"),
+ paste("Figure", fig.count<<-fig.count+1,"shows the major patterns associated with factor A.\n"),
+ paste("Figure", fig.count<<-fig.count+1,"shows the major patterns associated with factor B.\n"),
+ paste("Figure", fig.count<<-fig.count+1,"shows the major patterns associated with interaction.\n"),
+ paste("Figure", fig.count<<-fig.count+1,"shows the results of model validations through permutations.\n"),
+ paste("Figure", fig.count<<-fig.count+1,"shows the important features associated with factor A.\n"),
+ paste("Figure", fig.count<<-fig.count+1,"shows the important features associated with factor B.\n"),
+ paste("Figure", fig.count<<-fig.count+1,"shows the features that are important in the interaction.\n"),
+ "\n\n",
+ asca.tab1,
+ asca.tab2,
+ asca.tab3,
+ "The other details are available as .csv documents in your downloaded zip file.");
+
+ cat(descr, file=rnwFile, append=TRUE);
+ cat("\\clearpage", file=rnwFile, append=TRUE);
+
+ cmdhist<-c(
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$asca.scree,"}", sep=""),
+ "\\caption{Scree plots for each sub model.}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$asca.scree,"}", sep=""),
+ "\\end{figure}"
+ );
+
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+
+ cmdhist <- c(
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$asca.modelA,"}", sep=""),
+ paste("\\caption{Major patterns associated with", mSetObj$dataSet$facA.lbl, "}"),
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$asca.modelA,"}", sep=""),
+ "\\end{figure}"
+ );
+
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+
+ cmdhist <- c(
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$asca.modelB,"}", sep=""),
+ paste("\\caption{Major patterns associated with", mSetObj$dataSet$facB.lbl, "}"),
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$asca.modelB,"}", sep=""),
+ "\\end{figure}"
+ );
+
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+
+ cmdhist <- c(
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$asca.modelAB,"}", sep=""),
+ "\\caption{Major patterns associated with the Interaction between the two factors.}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$asca.modelAB,"}", sep=""),
+ "\\end{figure}"
+ );
+
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+
+ cmdhist <- c(
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$asca.perm,"}", sep=""),
+ "\\caption{Model validation through permutations}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$asca.perm,"}", sep=""),
+ "\\end{figure}"
+ );
+
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+
+ cmdhist <- c(
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$asca.impA,"}", sep=""),
+ paste("\\caption{Important variables associated with", mSetObj$dataSet$facA.lbl, "}"),
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$asca.impA,"}", sep=""),
+ "\\end{figure}"
+ );
+
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+
+ cmdhist <- c(
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$asca.impB,"}", sep=""),
+ paste("\\caption{Important variables associated with", mSetObj$dataSet$facB.lbl, "}"),
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$asca.impB,"}", sep=""),
+ "\\end{figure}"
+ );
+
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+
+ cmdhist <- c(
+ "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$asca.impAB,"}", sep=""),
+ "\\caption{Variables important in interaction between the two factors}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$asca.impAB,"}", sep=""),
+ "\\end{figure}"
+ );
+
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+
+ cat("\\clearpage\n\n", file=rnwFile, append=TRUE);
+
+ if(!is.null(asca.tab1)){
+ cmdhist<-c("<<echo=false, results=tex>>=",
+ "GetSigTable.ASCA(mSet, \"Model.a\")",
+ "@");
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+ }
+
+ if(!is.null(asca.tab2)){
+ cmdhist <- c("<<echo=false, results=tex>>=",
+ "GetSigTable.ASCA(mSet, \"Model.b\")",
+ "@");
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+ }
+
+ if(!is.null(asca.tab3)){
+ cmdhist <- c("<<echo=false, results=tex>>=",
+ "GetSigTable.ASCA(mSet, \"Model.ab\")",
+ "@");
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+ }
+ cat("\\clearpage", file=rnwFile, append=TRUE);
+}
+
+#'Create report of analyses
+#'@description Report generation using Sweave
+#'Multivariate Bayes
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateMBdoc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # need to check if this process is executed
+ if(is.null(mSetObj$analSet$MB)){
+ return();
+ }
+
+ descr <- c("\\subsection{Multivariate Empirical Bayes Approach - MEBA}\n",
+ "The approach is designed to compare the time-course profiles under different conditions.",
+ "The result is a list of variables that are ranked by their difference in temporal profiles",
+ "across different biological conditions. The Hotelling-T2 is used to rank the variables with",
+ "different temporal profiles between two biological conditions under study; And the",
+ "MB-statistics is used for more than two biological conditions. Higher statistical value",
+ "indicates the time-course profiles are more different across the biological conditions under study.",
+ "\n");
+
+ cat(descr, file=rnwFile, append=TRUE);
+
+ cmdhist2 <- c("<<echo=false, results=tex>>=",
+ "GetSigTable.MB(mSet)",
+ "@");
+ cat(cmdhist2, file=rnwFile, append=TRUE, sep="\n");
+ cat("\\clearpage", file=rnwFile, append=TRUE);
+}
\ No newline at end of file
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_reporter.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_reporter.R
new file mode 100755
index 0000000000000000000000000000000000000000..ec1597edb1e237e1db4f101c90215707e67b4c10
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/sweave_reporter.R
@@ -0,0 +1,280 @@
+#'Create report of analyses
+#'@description Report generation using Sweave
+#'Note: most analyses were already performed, only need to embed
+#'the results to the right place without rerunning the whole analysis
+#'through Sweave. Only some auxilliary info (i.e. time, version etc need to
+#'run in R through Sweave
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param usrName Input the name of the user
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PreparePDFReport<-function(mSetObj=NA, usrName){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # create the Rnw file
+ file.create("Analysis_Report.Rnw");
+ # open for write
+ rnwFile <<- file("Analysis_Report.Rnw", "w")
+
+ # create a global counter to label figures
+ fig.count <<- 0;
+ table.count <<- 0;
+
+ anal.type <- mSetObj$analSet$type;
+
+ if(anal.type == "stat" ){
+ CreateStatRnwReport(mSetObj, usrName);
+ }else if(anal.type == "ts"){
+ CreateTimeSeriesRnwReport(mSetObj, usrName);
+ }else if(substr(anal.type, 0, 4) == "mset"){
+ CreateEnrichRnwReport(mSetObj, usrName);
+ }else if(anal.type == "power"){
+ CreatePowerRnwReport(mSetObj, usrName)
+ }else if(anal.type == "roc"){
+ CreateBiomarkerRnwReport(mSetObj, usrName)
+ }else if(anal.type == "pathinteg"){
+ CreateIntegPathwayAnalysisRnwReport(mSetObj, usrName);
+ }else if(substr(anal.type, 0, 4) == "path"){ # must be after pathiteg
+ CreatePathRnwReport(mSetObj, usrName);
+ }else if(anal.type == "network"){
+ CreateNetworkExplorerRnwReport(mSetObj, usrName);
+ }else if(anal.type == "mummichog"){
+ CreateMummichogRnwReport(mSetObj, usrName);
+ }else if(anal.type == "metadata"){
+ CreateMetaAnalysisRnwReport(mSetObj, usrName);
+ }else if(anal.type == "raw"){
+ CreateRawAnalysisRnwReport(mSetObj, usrName);
+ }else if(exists(meta.anal.type)){
+ CreateMummichogRnwReport(mSetObj, usrName);
+ }else{
+ AddErrMsg(paste("No template found for this module:", anal.type));
+ return(0);
+ }
+
+ # close opened files
+ close(rnwFile);
+
+ if(!.on.public.web){
+ utils::Sweave("Analysis_Report.Rnw", encoding="utf8");
+ res <- try(tools::texi2dvi("Analysis_Report.tex", pdf = TRUE, quiet=TRUE));
+ }
+ return(1);
+}
+
+# this is for PDF report generation from bash
+SaveCurrentSession <- function(){
+ file.copy("../../rscripts/_sweave.sty", ".")
+ save.image("SweaveImage.RData");
+}
+
+CreateHeader <- function(usrName){
+ header <- c("\\documentclass[a4paper]{article}",
+ "\\usepackage[margin=1.0in]{geometry}",
+ "\\usepackage{longtable}",
+ "\\usepackage{graphicx}",
+ "\\usepackage{grffile}",
+ "<<echo=false>>=",
+ "options(width=60);",
+ "@",
+ "\\SweaveOpts{eps=FALSE,pdf=TRUE}",
+ "\\title{Metabolomic Data Analysis with MetaboAnalyst 5.0}",
+ paste("\\author{ Name: ", usrName, " }", sep=""),
+ "\\begin{document}",
+ "\\parskip=.3cm",
+ "\\maketitle");
+ cat(header, file=rnwFile, sep="\n", append=TRUE);
+
+}
+
+#'Create report of analyses
+#'@description Report generation using Sweave
+#'Create a summary table for each type of uploaded data
+#'csv table has 5 col: sampleID, feature #, zero, missing #
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'@import qs
+CreateSummaryTable <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ sum.dat<-NULL;
+ plenth<-dim(mSetObj$dataSet$proc)[2];
+ if(mSetObj$dataSet$type=='conc'| mSetObj$dataSet$type=='pktable'| mSetObj$dataSet$type=='specbin'){
+ orig.data<- qs::qread("data_orig.qs");
+ for(i in 1:nrow(orig.data)){
+ srow<-orig.data[i,];
+ newrow<-c(sum(srow[!is.na(srow)]>0), (sum(is.na(srow)) + sum(srow[!is.na(srow)]<=0)), plenth);
+ sum.dat<-rbind(sum.dat, newrow);
+ }
+ colnames(sum.dat)<-c("Features (positive)","Missing/Zero","Features (processed)");
+ rownames(sum.dat)<-mSetObj$dataSet$orig.smp.nms;
+ }else if(mSetObj$dataSet$type=="nmrpeak"| mSetObj$dataSet$type=="mspeak"){ # peak list
+ pkSet<-qs::qread("peakSet.qs");
+ orig.data<- qs::qread("data_orig.qs");
+ snames<-pkSet$sampnames;
+ for(i in 1:length(snames)){
+ samp.inx<-pkSet$peaks[,"sample"]==i;
+ srow <- orig.data[i,];
+ newrow<-c(sum(samp.inx),(sum(is.na(srow)) + sum(srow[!is.na(srow)]<=0)), plenth);
+ sum.dat<-rbind(sum.dat, newrow);
+ }
+ colnames(sum.dat)<-c("Peaks (raw)","Missing/Zero", "Peaks (processed)");
+ rownames(sum.dat)<-mSetObj$dataSet$orig.smp.nms;
+ }else{ # spectra
+ rawxset<-mSetObj$dataSet$xset.orig;
+ fillxset<-mSetObj$dataSet$xset.fill;
+ snames<-row.names(rawxset@phenoData)
+
+ for(i in 1:length(snames)){
+ rawno<-sum(rawxset@peaks[,"sample"]==i);
+ fillno<-sum(fillxset@peaks[,"sample"]==i);
+ newrow<-c(rawno,fillno,plenth);
+ sum.dat<-rbind(sum.dat, newrow);
+ }
+ colnames(sum.dat)<-c("Peaks (raw)","Peaks (fill)", "Peaks(processed)");
+ rownames(sum.dat)<-mSetObj$dataSet$orig.smp.nms;
+ }
+ print(xtable::xtable(sum.dat, caption="Summary of data processing results"), caption.placement="top", size="\\scriptsize");
+}
+
+#'Create report of analyses
+#'@description Report generation using Sweave
+#'Create normalization document
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+CreateNORMdoc <- function(mSetObj=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ # need to check if this process is executed
+ if(is.null(mSetObj$dataSet$norm)){
+ errorMsg <- c("Error occured during normalization of your data ....",
+ "Fail to proceed. Please check if the data format you uploaded is correct.",
+ "Please visit our FAQs, Data Formats, and TroubleShooting pages for more information!");
+ cat(errorMsg, file=rnwFile, append=TRUE);
+ return();
+ }
+
+ descr1 <- c("\\subsection{Data Normalization}\n",
+ "The data is stored as a table with one sample per row and one variable (bin\\slash peak\\slash",
+ "metabolite) per column. The normalization procedures implemented below are grouped into four categories.",
+ "Sample specific normalization allows users to manually adjust concentrations based on biological inputs",
+ "(i.e. volume, mass); row-wise normalization allows general-purpose adjustment for differences among samples;",
+ "data transformation and scaling are two different approaches to make features more comparable.",
+ "You can use one or combine both to achieve better results.",
+ "\n\n",
+ "The normalization consists of the following options:");
+
+ cat(descr1, file=rnwFile, append=TRUE);
+
+ descr2 <- c("\\begin{enumerate}",
+ "\\item{Row-wise procedures: }",
+ "\\begin{itemize}",
+ "\\item{Sample specific normalization (i.e. normalize by dry weight, volume) }",
+ "\\item{Normalization by the sum }",
+ "\\item{Normalization by the sample median }",
+ "\\item{Normalization by a reference sample (probabilistic quotient",
+ "normalization)\\footnote{Dieterle F, Ross A, Schlotterbeck G, Senn H. \\textit{Probabilistic quotient normalization as robust",
+ "method to account for dilution of complex biological mixtures. Application in 1H NMR metabonomics}, 2006,",
+ "Anal Chem 78 (13);4281 - 4290}}",
+ "\\item{Normalization by a pooled or average sample from a particular group }",
+ "\\item{Normalization by a reference feature (i.e. creatinine, internal control) }",
+ "\\item{Quantile normalization }",
+ "\\end{itemize}",
+ "\\item{Data transformation : }",
+ "\\begin{itemize}",
+ "\\item{Generalized log transformation (glog 2) }",
+ "\\item{Cube root transformation}",
+ "\\end{itemize}",
+ "\\item{Data scaling: }",
+ "\\begin{itemize}",
+ "\\item{Mean centering (mean-centered only)}",
+ "\\item{Auto scaling (mean-centered and divided by standard deviation of each variable)}",
+ "\\item{Pareto scaling (mean-centered and divided by the square root of standard deviation of each variable)}",
+ "\\item{Range scaling (mean-centered and divided by the value range of each variable)}",
+ "\\end{itemize}",
+ "\\end{enumerate}",
+ "\n\n",
+ if(exists("norm", where=mSetObj$imgSet)){
+ paste("Figure", fig.count<<-fig.count+1,"shows the effects before and after normalization.\n");
+ })
+
+ cat(descr2, file=rnwFile, append=TRUE, sep="\n");
+
+ if(mSetObj$dataSet$combined.method){
+ norm.desc <- "Combined approach using quantile normalization within replicates after log transformation.";
+ }else{
+ if(!is.null(mSetObj$dataSet[["rownorm.method"]])){
+ norm.desc <- paste("Row-wise normalization: ", mSetObj$dataSet$rownorm.method, "; ",
+ "Data transformation: ",mSetObj$dataSet$trans.method, "; ",
+ "Data scaling: ",mSetObj$dataSet$scale.method, ".", sep="");
+ }else{
+ norm.desc <- "No normalization methods were applied."
+ }
+ }
+
+ if(exists("norm", where=mSetObj$imgSet)){
+ cmdhist <- c( "\\begin{figure}[htp]",
+ "\\begin{center}",
+ paste("\\includegraphics[width=1.0\\textwidth]{", mSetObj$imgSet$norm,"}", sep=""),
+ "\\caption{Box plots and kernel density plots before and after normalization.",
+ "The boxplots show at most 50 features due to space limit. The density plots are based on all samples.",
+ "Selected methods :", norm.desc, "}",
+ "\\end{center}",
+ paste("\\label{",mSetObj$imgSet$norm,"}", sep=""),
+ "\\end{figure}",
+ "\\clearpage"
+ );
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+ }
+ cat("\\clearpage", file=rnwFile, append=TRUE, sep="\n");
+}
+
+#'Create report of analyses
+#'@description Report generation using Sweave
+#'Create footer
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+CreateRHistAppendix <- function(){
+
+ descr <- c("\\section{Appendix: R Command History}\n");
+ cat(descr, file=rnwFile, append=TRUE);
+
+ if(!is.null("Rhistory.R")){
+
+ cmdhist<-c("<<echo=false, results=verbatim>>=",
+ "GetRCommandHistory(mSet);",
+ "@"
+ );
+ cat(cmdhist, file=rnwFile, append=TRUE, sep="\n");
+ }
+}
+
+#'Create report of analyses (Met Enrichment)
+#'@description Report generation using Sweave
+#'Metabolite enrichment analysis report footer
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+CreateFooter <- function(){
+ end <- c("\\vspace{5 mm}\n--------------------------------\n\n",
+ "The report was generated on \\Sexpr{date()} with \\Sexpr{print(version$version.string)}.\n",
+ "\\end{document}\n\n"
+ );
+ cat(end, file=rnwFile, append=TRUE);
+}
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/time_asca_heatmap2.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/time_asca_heatmap2.R
new file mode 100755
index 0000000000000000000000000000000000000000..b536144da9bc73b2da6046a6105fdd539b28060d
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/time_asca_heatmap2.R
@@ -0,0 +1,1320 @@
+#'Plot heatmap visualization for time-series data
+#'@description Plot heatmap visualization for time-series data
+#'@usage PlotHeatMap2(mSetObj=NA, imgName, format="png", dpi=72, width=NA, smplDist="pearson", clstDist="average", colors="bwm", viewOpt="overview", hiRes=FALSE, sortInx = 1, useSigFeature, drawBorder)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@param smplDist Select distance measure: euclidean, pearson, or minkowski
+#'@param clstDist Select clustering algorithm: ward, average, complete, single
+#'@param colors Select heatmap colors: bwm, gray
+#'@param viewOpt Select overview or detailed view: overview or detail
+#'@param hiRes Select high-resolution or not: logical, default set to F
+#'@param sortInx Sort by index
+#'@param useSigFeature Use significant features only: F or T (default false)
+#'@param drawBorder Show cell borders: F or T (default F)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotHeatMap2<-function(mSetObj=NA, imgName, format="png", dpi=72, width=NA, smplDist="pearson",
+ clstDist="average", colors="bwm", viewOpt="overview", hiRes=FALSE, sortInx = 1,
+ useSigFeature, drawBorder){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(mSet$dataSet$facA.type==TRUE){
+ facA <- as.factor(as.numeric(levels(mSet$dataSet$facA))[mSet$dataSet$facA]);
+ }else{
+ facA <- mSetObj$dataSet$facA;
+ }
+
+ if(mSet$dataSet$facB.type==TRUE){
+ facB <- as.factor(as.numeric(levels(mSet$dataSet$facB))[mSet$dataSet$facB]);
+ }else{
+ facB <- mSetObj$dataSet$facB;
+ }
+
+ if(sortInx == 1){
+ ordInx <- order(facA, facB);
+ }else{
+ ordInx <- order(facB, facA);
+ }
+
+ new.facA <- facA[ordInx];
+ new.facB <- facB[ordInx];
+
+ # set up data set. note, need to transpose the data for two way plotting
+ data <- mSetObj$dataSet$norm[ordInx, ];
+
+ # use features from ANOVA2
+ if(useSigFeature){
+ hits <- colnames(data) %in% rownames(mSetObj$analSet$aov2$sig.mat);
+ data <- mSetObj$dataSet$norm[ordInx, hits];
+ }
+
+ hc.dat <- as.matrix(data);
+ colnames(hc.dat) <- substr(colnames(data), 1, 18) # some names are too long
+
+ # set up parameter for heatmap
+ if(colors=="gbr"){
+ colors <- colorRampPalette(c("green", "black", "red"), space="rgb")(256);
+ }else if(colors == "heat"){
+ colors <- heat.colors(256);
+ }else if(colors == "topo"){
+ colors <- topo.colors(256);
+ }else if(colors == "gray"){
+ colors <- colorRampPalette(c("grey90", "grey10"), space="rgb")(256);
+ }else{
+ colors <- rev(colorRampPalette(RColorBrewer::brewer.pal(10, "RdBu"))(256));
+ }
+ if(drawBorder){
+ border.col<-"grey60";
+ }else{
+ border.col <- NA;
+ }
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+
+ if(viewOpt == "overview"){
+ if(is.na(width)){
+ w <- 9;
+ }else if(width == 0){
+ w <- 7.2;
+ }else{
+ w <- 7.2;
+ }
+ mSetObj$imgSet$htmaptwo <- imgName;
+ h <- w;
+ }else{
+ if(is.na(width)){
+ minW <- 650;
+ myW <- nrow(hc.dat)*11 + 150;
+ if(myW < minW){
+ myW <- minW;
+ }
+ w <- round(myW/72,2);
+ }else if(width == 0){
+ w <- 7.2;
+ }else{
+ w <- 7.2;
+ }
+ if(ncol(hc.dat) >100){
+ myH <- ncol(hc.dat)*12 + 120;
+ }else if(ncol(hc.dat) > 50){
+ myH <- ncol(hc.dat)*12 + 60;
+ }else{
+ myH <- ncol(hc.dat)*12 + 20;
+ }
+ mSetObj$imgSet$htmaptwo <- imgName;
+ h <- round(myH/72,2);
+ }
+ if(format=="pdf"){
+ pdf(file = imgName, width=w, height=h, bg="white", onefile=FALSE);
+ }else{
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ }
+
+ annotation <- data.frame(new.facB, new.facA);
+ colnames(annotation) <- c(mSetObj$dataSet$facB.lbl, mSetObj$dataSet$facA.lbl);
+ rownames(annotation) <-rownames(hc.dat);
+
+ pheatmap::pheatmap(t(hc.dat),
+ annotation=annotation,
+ fontsize=8, fontsize_row=8,
+ clustering_distance_rows = smplDist,
+ clustering_distance_cols = smplDist,
+ clustering_method = clstDist,
+ border_color = border.col,
+ cluster_rows = T,
+ cluster_cols = F,
+ scale = 'row',
+ color = colors);
+ dev.off();
+ mSetObj$analSet$htmap2 <- list(dist.par=smplDist, clust.par=clstDist);
+ return(.set.mSet(mSetObj));
+}
+
+#'Perform ASCA
+#'@description The ASCA algorithm was adapted from the ASCA-genes method
+#'(analysis of variance (ANOVA) simultaneous component analysis)
+#'by Maria Jose Nueda (mj.nueda@ua.es) and Ana Conesa (aconesa@ivia.es)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param a specify the number of components for facA
+#'@param b specify the number of components for facB
+#'@param x specify the number of components for interaction AB
+#'@param res specify the number of model residuals
+#' type is string, indicating the type of analysis
+#' "abc" separately
+#' "aab" facA joins with AB
+#' "bab" facB joins with AB
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+Perform.ASCA <- function(mSetObj=NA, a=1, b=2, x=2, res=2){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ X <- mSetObj$dataSet$norm;
+ Fac = c(a, b, x, res);
+
+ # Designa (p x I)
+ Designa <- model.matrix(~ mSetObj$dataSet$facA-1);
+
+ # Designb (p x J)
+ Designb <- model.matrix(~ mSetObj$dataSet$facB-1);
+
+ n<-ncol(X);
+ p<-nrow(X);
+ I<-ncol(Designa);
+ J<-ncol(Designb);
+
+ Faca=Fac[1]; # number components Model a
+ Facb=Fac[2]; # number components Model b
+ Facab=Fac[3]; # number components Model ab to not consider interations set to 0
+ Facres=Fac[4]; # number components Residues
+
+ # Calculate Overall Mean
+ offset<-apply(X,2,mean);
+
+ # remove the overall mean from the matrix
+ Xoff <- X-(cbind(matrix(1,nrow=p,ncol=1))%*%rbind(offset));
+
+ Model.a<-ASCAfun1(Xoff,Designa,Faca);
+ Model.b<-ASCAfun1(Xoff,Designb,Facb);
+ if (Facab != 0 ) {
+ Model.ab<-ASCAfun2(Xoff,Designa,Designb,Facab);
+ }
+
+ # Collecting models
+ models <- ls(pattern="Model");
+ output <- vector(mode="list");
+ Xres <- Xoff;
+ for (i in 1: length(models)) {
+ mymodel <- get(models[i], envir=environment());
+ output <- c(output, list(mymodel));
+ Xres <- Xres - mymodel$X;
+ rm(mymodel);
+ gc();
+ }
+ names(output) <- models
+
+ # Model.res
+ Model.res <- ASCAfun.res(Xres,Facres);
+
+ LIST<-list(Model.res);
+ names(LIST)<-c("Model.res");
+
+ mSetObj$analSet$asca <- list(
+ facNum = Fac,
+ Xoff = Xoff,
+ models = c(output,LIST)
+ );
+ return(.set.mSet(mSetObj));
+}
+
+#'Calculate the Important Variable Cutoff
+#'@description This function calculates the all important features based on
+#'a specfic cutoff.
+#'@usage CalculateImpVarCutoff(mSetObj, spe.thresh, lev.thresh)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param spe.thresh alpha threshold, less is better, default less than 5 percentile based chi-square
+#'note: spe and leverage are vectors, not a single value, but a list to store the result
+#'note: the last model is Model.res, no spe
+#'Calculate leverage cutoff based on permutation
+#'Calculate the reference distribution of leverages
+#'note: leverage.perm is a list with each member in a 3 column matrix
+#'@param lev.thresh leverage threshold, the higher better, default more than 95 percentile of permuted leverage
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+CalculateImpVarCutoff <- function(mSetObj=NA, spe.thresh = 0.05, lev.thresh = 0.95){
+
+ mSetObj <- .get.mSet(mSetObj);
+ asca.models <- mSetObj$analSet$asca$models;
+ spe.lims <- lev.lims <- numeric(3);
+
+ md.nms <- names(asca.models)[1:3]; # note, last model is Model.res, ignore
+ names(spe.lims) <- names(lev.lims) <- md.nms;
+ for (nm in md.nms) { # a, ab, b
+ model <- asca.models[[nm]];
+ # get SPE cutoff based on Chiq distribution
+ m <- mean(model$SPE);
+ v <- var(model$SPE);
+ g <- v/(2*m);
+ h <- 2*m*m/v;
+ lim <- g*qchisq(1-spe.thresh, df=h);
+ spe.lims[nm] <- lim;
+ }
+ mSetObj$analSet$asca$SPE.cutoff <- spe.lims;
+
+ if(is.null(mSetObj$analSet$asca$leverage.perm)){
+
+ mSetLev <<- mSetObj
+
+ # lev.perm is a list with each 3 col matrix (lvA, lvV, lvAB)
+ res.perm <- Perform.permutation(20, Get.asca.leverage);
+
+ # perm.num may be adjusted on public server
+ perm.num <- res.perm$perm.num;
+ lev.perm <- res.perm$perm.res;
+
+ rm(mSetLev, pos = ".GlobalEnv")
+
+ # convert to a list with 3 members each is a permutation of all variable
+ # for a single factor
+ rowNum <- length(lev.perm);
+ colNum <- ncol (mSetObj$dataSet$norm); # each col is variable
+ lvA.mat <- lvB.mat <- lvAB.mat <- matrix(0, nrow = rowNum, ncol=colNum);
+ for(m in 1:length(lev.perm)){
+ mat <- lev.perm[[m]];
+ lvA.mat[m,] <- mat[,1]; # facA
+ lvB.mat[m,] <- mat[,2]; # facB
+ lvAB.mat[m,] <- mat[,3]; # facAB
+ }
+ perm.lv <- list("Model.a"=lvA.mat,
+ "Model.b"=lvB.mat,
+ "Model.ab"=lvAB.mat);
+ mSetObj$analSet$asca$leverage.perm <- perm.lv;
+ rm(lev.perm);
+ gc();
+ }
+
+ for (nm in md.nms){
+ lv.mat <- mSetObj$analSet$asca$leverage.perm[[nm]];
+ # get the quantile for each var
+ quant1 <- apply(lv.mat, 2, quantile, probs = lev.thresh);
+ # get the quantile for each model
+ lim <- quantile(quant1, probs = lev.thresh);
+ lev.lims[nm] <- lim;
+ }
+
+ mSetObj$analSet$asca$leverage.cutoff <- lev.lims;
+
+ # now get all significant and outlier for each factor based on the threshold
+ sig.list <- out.list <- list();
+ for (nm in md.nms){
+ model <- asca.models[[nm]];
+ lv <- model$leverage;
+ spe <- model$SPE;
+
+ lv.cutoff <- mSetObj$analSet$asca$leverage.cutoff[nm];
+ spe.cutoff <- mSetObj$analSet$asca$SPE.cutoff[nm];
+
+ lvInx <- lv >= lv.cutoff;
+ speInx <- spe <= spe.cutoff;
+ sigInx <- lvInx & speInx;
+ outInx <- spe > spe.cutoff;
+
+ sig.mat <- cbind(lv[sigInx], spe[sigInx]);
+ colnames(sig.mat) <- c("Leverage", "SPE");
+ rownames(sig.mat) <- colnames(mSetObj$dataSet$norm)[sigInx];
+ # order by leverage
+ ordInx <- order(sig.mat[,1], decreasing=TRUE);
+ sig.mat <- sig.mat[ordInx,,drop=F];
+
+ out.mat <- cbind(lv[outInx], spe[outInx]);
+ colnames(out.mat) <- c("Leverage", "SPE");
+ rownames(out.mat) <- colnames(mSetObj$dataSet$norm)[outInx];
+ # order by SPE
+ ordInx <- order(out.mat[,2], decreasing=TRUE);
+ out.mat <- out.mat[ordInx,,drop=F];
+
+ # must use double [[, to use dynamical name and assign arbitury list element
+ sig.list[[nm]] <- sig.mat;
+ out.list[[nm]]<- out.mat;
+
+ nm <- gsub("\\.", "_", nm);
+ fast.write.csv(sig.mat, file=paste("Sig_features_", nm, ".csv", sep=""));
+ fast.write.csv(out.mat, file=paste("Outliers_", nm, ".csv", sep=""));
+ }
+ mSetObj$analSet$asca$sig.list <- sig.list;
+ mSetObj$analSet$asca$out.list <- out.list;
+ return(.set.mSet(mSetObj));
+}
+
+#'Function to perform ASCA
+#'@description Perform ASCA
+#'@param X Numeric, number of compounds
+#'@param Design Number of levels in the factor
+#'@param Fac Numeric, the factor
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+ASCAfun1<-function (X, Design, Fac) {
+ n <- ncol(X) # number of genes
+ I <- ncol(Design) # number of levels in the factor
+
+ NK<-NULL
+ XK<-matrix(NA,nrow=I,ncol=n)
+
+ for (i in 1:I) {
+ sub<-X[Design[,i]==1,]
+ NK[i]<-nrow(sub)
+ XK[i,]<-apply(sub,2,mean)
+ }
+ NK<-sqrt(NK)
+
+ # Weigh the data of the Submodel with the corresponding number of measurement occasions
+ XKw<- NK*XK
+
+ PCA<-PCA.GENES(XKw)
+ scw<-PCA$scores[,1:Fac]
+ ld<-PCA$loadings[,1:Fac]
+ ssq<-PCA$var.exp
+
+ if(Fac==1) {
+ scw<-as.matrix(scw)
+ ld<-as.matrix(ld)
+ }
+
+ # Re-weigth the scores
+ sc<-scw/NK
+ XKrec<-sc%*%t(ld)
+ Xa<-NULL
+ TPa<-NULL
+ for (i in 1:nrow(X)){
+ position<-which(Design[i,]==1)
+ Xa<-rbind(Xa,XK[position,])
+ TPa<-rbind(TPa,XKrec[position,])
+ }
+
+ Ea<-Xa-TPa
+
+ # leverage & SPE
+ leverage<-apply(ld^2,1,sum)
+ SPE<-apply(Ea^2,2,sum)
+
+ output<-list(XK,sc,ld,ssq,Xa,TPa,Ea,leverage,SPE, Fac)
+ names(output)<-c("data","scores","loadings","var.exp","X","TP","E","leverage","SPE", "facNum");
+ output
+}
+
+#'Function to perform ASCA
+#'@description Perform ASCA
+#'@param X Numeric, number of compounds
+#'@param Desa Number of levels in the factor TIME
+#'@param Desb Number of levels in the other factor
+#'@param Fac Numeric, the factor
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+ASCAfun2<-function (X, Desa, Desb, Fac) {
+
+ n <- ncol(X) # number of genes
+ I <- ncol(Desa) # number of levels in the factor TIME
+ J <- ncol(Desb) # number of levels in the other factor
+
+ XK1<-matrix(NA,nrow=I,ncol=n);
+ for (i in 1:I) {
+ sub<-X[Desa[,i]==1,]
+ XK1[i,]<-apply(sub,2,mean)
+ }
+
+ XK2<-matrix(NA,nrow=J,ncol=n);
+ for (j in 1:J) {
+ sub<-X[Desb[,j]==1,]
+ XK2[j,]<-apply(sub,2,mean)
+ }
+
+ NK<-matrix(NA,nrow=I,ncol=J)
+ XK<-matrix(NA,nrow=I*J,ncol=n)
+
+ nms.I <- colnames(Desa);
+ nms.J <- colnames(Desb);
+ row.nm <- vector(mode="character", length=I*J);
+
+ k=1
+ for (j in 1:J){
+ for (i in 1:I){
+ sub<-X[(Desa[,i]+Desb[,j])==2,]
+ NK[i,j]<-sqrt(nrow(sub))
+ XK[k,]<-apply(sub,2,mean)-XK1[i,]-XK2[j,];
+ row.nm[k] <- paste(nms.I[i], nms.J[j], sep=".");
+ k=k+1
+ }
+ }
+
+ XKw<-XK*(as.numeric(NK))
+ rownames(XKw) <- row.nm;
+
+ PCA<-PCA.GENES(XKw)
+ scw<-PCA$scores[,1:Fac]
+ ld<-PCA$loadings[,1:Fac]
+ ssq<-PCA$var.exp
+ if(Fac==1) {
+ scw<-as.matrix(scw)
+ ld<-as.matrix(ld)
+ }
+
+ # Re-weigth the scores
+ sc<-scw/(as.numeric(NK))
+
+ XKrec<-sc%*%t(ld)
+
+ Xab<-NULL
+ TPab<-NULL
+ for (i in 1:nrow(X)){
+ position1<-which(Desa[i,]==1)
+ position2<-which(Desb[i,]==1)
+ Xab<-rbind(Xab,XK[I*(position2-1)+position1,])
+ TPab<-rbind(TPab,XKrec[I*(position2-1)+position1,])
+ }
+ Eab<-Xab-TPab
+
+ leverage<-apply(ld^2,1,sum)
+ SPE<-apply(Eab^2,2,sum)
+
+ output<-list(XK,sc,ld,ssq,Xab,TPab,Eab,leverage,SPE, Fac)
+ names(output)<-c("data","scores","loadings","var.exp","X","TP","E","leverage","SPE", "facNum");
+ output
+}
+
+#'Function to perform ASCA
+#'@description Perform ASCA
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'@param X Input list of compounds
+#'@param Fac Numeric
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+ASCAfun.res <- function(X, Fac){
+ PCA<-PCA.GENES(X);
+ sc<-PCA$scores[,1:Fac];
+ ld<-PCA$loadings[,1:Fac];
+ ssq<-PCA$var.exp;
+
+ if(Fac==1) {
+ sc<-as.matrix(sc)
+ ld<-as.matrix(ld)
+ }
+ TPres<-sc%*%t(ld)
+
+ if(Fac==0){
+ sc=0
+ ld=0
+ TPres<-matrix(0,nrow(X),ncol(X))
+ }
+
+ Eres<-X-TPres
+ output<-list(sc,ld,ssq,X,TPres,Eres, Fac)
+ names(output)<-c("scores","loadings","var.exp","X","TP","E", "facNum");
+ output
+}
+
+#'Perform ASCA model validation by permutation
+#'@description Perform ASCA model validation by permutation
+#'we use Manly's unrestricted permutation of observations
+#'which esentially permutes the data over all cells in the
+#'designed experiment, then calculates the score for
+#'each main factor or interaction components.
+#'This will get the null distribution for all effects in one go
+#'@usage Perform.ASCA.permute(mSetObj=NA, perm.num)
+#'@param mSetObj Input name of the created mSet Object
+#'@param perm.num Select the number of permutations, default is 20
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+Perform.ASCA.permute<-function(mSetObj=NA, perm.num=20){
+
+ # since there are three factors a, b, ab, it is easier
+ # to permute the data, and let factors fixed, we can pre-calculate
+ # the needed information for each factor to save computation time
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ facA <- mSetObj$dataSet$facA;
+ facB <- mSetObj$dataSet$facB;
+ facAB <- as.factor(paste(facA, facB, sep=":"));
+
+ lvAB <- levels(facAB);
+ lvAB.mat <- do.call(rbind, strsplit(lvAB, ":", fixed=TRUE))
+ lvAB.mat <- cbind(lvAB,lvAB.mat);
+
+ # factor size is needed for each iteration
+ facA.size <- getFactorSize(facA);
+ facB.size <- getFactorSize(facB);
+ facAB.size <- getFactorSize(facAB);
+
+ # record these information
+ mSetObj$analSet$asca$perm.info <- list(
+ facA.size = facA.size,
+ facB.size = facB.size,
+ facAB = facAB,
+ facAB.size = facAB.size,
+ lvAB.mat = lvAB.mat
+ );
+
+ mSetPerm <<- mSetObj
+ perm.orig <- Get.asca.tss(dummy, perm=F);
+ res.perm <- Perform.permutation(perm.num, Get.asca.tss);
+ rm(mSetPerm, pos = ".GlobalEnv");
+ gc(); # garbage collection
+
+ # perm.num may be adjusted on public server
+ perm.num <- res.perm$perm.num;
+ perm.res <- res.perm$perm.res;
+
+ # convert to matrix
+ perm.res <- do.call(rbind, perm.res);
+ perm.res <- rbind(perm.orig, perm.res);
+ colnames(perm.res) <- c(mSetObj$dataSet$facA.lbl, mSetObj$dataSet$facB.lbl, "Interaction");
+
+ # calculate the significant p value as the proportion of sampled permutations better than or equal to original one
+ # note, the precision is determined by the permutation number i.e. for 100 time, no better than original
+ # p value is < 0.01, we can not say it is zero
+
+ better.mat <- sweep(perm.res[-1,], 2, perm.res[1,]); # subtract perm.res[1,] for each permutated rows
+ better.hits <- apply(better.mat>=0, 2, sum);
+
+ #p.vec <- better.hits/perm.num;
+ p.res <- vector(mode="character", length=3);
+ p.res[better.hits == 0] <- paste("p < ", 1/perm.num, " (1/", perm.num, ")", sep="");
+ p.res[better.hits > 0] <- paste("p = ", signif(better.hits[better.hits > 0]/perm.num, digits=5), " (", better.hits[better.hits > 0], "/", perm.num, ")", sep="");
+
+ ## added for test
+ fast.write.csv(perm.res, file="perm.res.csv");
+
+ mSetObj$analSet$asca$perm.p <- p.res;
+ mSetObj$analSet$asca$perm.mat <- perm.res;
+ return(.set.mSet(mSetObj));
+}
+
+getFactorSize <- function(fac){
+ lvs <- levels(fac);
+ size.vec <- numeric(length(lvs));
+ for(i in length(lvs)){
+ size.vec[i] <- sum(fac == lvs[i]);
+ }
+ size.vec;
+}
+
+#'Function for ASCA permutation
+#'@description Dummy is used only for the purpose to maintain lapply API
+#'this is used for permutation on ANOVA paritions,
+#'not on the SCA/PCA part, so the number of selected components is
+#'not applicable in this step
+#'@param dummy Dummy variable
+#'@param perm Logical, TRUE by default
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+Get.asca.tss <- function(dummy, perm=T){
+
+ X <- mSetPerm$analSet$asca$Xoff;
+ facA <- mSetPerm$dataSet$facA;
+ facB <- mSetPerm$dataSet$facB;
+ facAB <- mSetPerm$analSet$asca$perm.info$facAB;
+ facA.size <- mSetPerm$analSet$asca$perm.info$facA.size;
+ facB.size <- mSetPerm$analSet$asca$perm.info$facB.size;
+ facAB.size <- mSetPerm$analSet$asca$perm.info$facAB.size;
+ lvAB.mat <- mSetPerm$analSet$asca$perm.info$lvAB.mat;
+
+ if(perm){
+ # permute factor is faster than permute data matrix?
+ ordInx <- order(runif(length(mSetPerm$dataSet$facA)));
+ facA <- facA[ordInx];
+ facB <- facB[ordInx];
+ facAB <- facAB[ordInx];
+ }
+
+ # BHAN: because of the mean & sd functions have been changed in latest version(R > 3.0.2)
+ # to calculate column means; replace mean --> colMeans
+ mnA <- by(X, facA, colMeans);
+ mnB <- by(X, facB, colMeans);
+ mnAB <- by(X, facAB, colMeans);
+
+ # mnAB should subtract A and B effect
+ for(i in 1:nrow(lvAB.mat)){
+ mnAB[[lvAB.mat[i,1]]] <- mnAB[[lvAB.mat[i,1]]] - mnA[[lvAB.mat[i,2]]] - mnB[[lvAB.mat[i,3]]];
+ }
+
+ dist.a <- sum(unlist(lapply(mnA, sumSquare), use.names=F)*(facA.size));
+ dist.b <- sum(unlist(lapply(mnB, sumSquare), use.names=F)*(facB.size));
+ dist.ab <- sum(unlist(lapply(mnAB, sumSquare), use.names=F)*(facAB.size));
+
+ # return all the distance
+ c(dist.a, dist.b, dist.ab);
+}
+
+# euclidean distance to zero
+sumSquare <- function(x){
+ sum(x*x);
+}
+
+Get.asca.leverage <- function(dummy){
+
+ X <- mSetLev$analSet$asca$Xoff;
+ Fac <-mSetLev$analSet$asca$facNum;
+ Faca=Fac[1]; # number components Model a
+ Facb=Fac[2]; # number components Model b
+ Facab=Fac[3]; # number components Model ab to not consider interations set to 0
+
+ # permute facA and facB
+ ordInx <- order(runif(length(mSetLev$dataSet$facA)));
+ facA <- mSetLev$dataSet$facA[ordInx];
+ facB <- mSetLev$dataSet$facB[ordInx];
+
+ # Designa (p x I)
+ Desa <- model.matrix(~facA-1);
+
+ # Designb (p x J)
+ Desb <- model.matrix(~facB-1);
+
+ n<-ncol(X);
+ p<-nrow(X);
+
+ I <- ncol(Desa)
+ J <- ncol(Desb)
+
+ ################################
+ ######### factor A #############
+ ################################
+ NK1<-numeric(I);
+ XK1<-matrix(NA,nrow=I,ncol=n);
+
+ for (i in 1:I) {
+ sub<-X[Desa[,i]==1,]
+ NK1[i]<-nrow(sub)
+ XK1[i,]<-apply(sub,2,mean)
+ }
+
+ NK1<-sqrt(NK1);
+ XKw1<- NK1*XK1;
+ lvA <- Get.Leverage(XKw1, Faca);
+
+ # factor B
+ NK2<-numeric(J);
+ XK2<-matrix(NA,nrow=J,ncol=n);
+
+ for (i in 1:J) {
+ sub<-X[Desb[,i]==1,]
+ NK2[i]<-nrow(sub)
+ XK2[i,]<-apply(sub,2,mean)
+ }
+
+ NK2<-sqrt(NK2);
+ XKw2<- NK2*XK2;
+ lvB <- Get.Leverage(XKw2, Facb);
+
+ # interaction AB
+ if (Facab != 0 ) {
+ NK3<-matrix(NA,nrow=I,ncol=J)
+ XK3<-matrix(NA,nrow=I*J,ncol=n);
+ k=1
+ for (j in 1:J){
+ for (i in 1:I){
+ sub<-X[(Desa[,i]+Desb[,j])==2,]
+ NK3[i,j]<-sqrt(nrow(sub));
+ XK3[k,]<-apply(sub,2,mean)-XK1[i,]-XK2[j,];
+ k=k+1
+ }
+ }
+ XKw3<-XK3*(as.numeric(NK3));
+ lvAB <- Get.Leverage(XKw3, Facab);
+ }else{
+ lvAB <- 0;
+ }
+ # return all the distance, note, each is a vector
+ cbind(lvA, lvB, lvAB);
+}
+
+#'Fast leverage calculation for permutation purpose
+#'@description note, the leverage combines all components
+#'the importance feature is for the factor not per components
+#'@param XKw Features
+#'@param Fac Factor
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+Get.Leverage <- function(XKw, Fac){
+ PCA <- PCA.GENES(XKw);
+ ld <- PCA$loadings[,1:Fac];
+ if(Fac==1) {
+ ld<-as.matrix(ld);
+ }
+ # leverage
+ apply(ld^2,1,sum);
+}
+
+
+#'Obtain principal components into a matrix that has more variables than individuals
+#'@description X is a matrix that has as columns the compounds that were considered as variables in the PCA analysis.
+#'First we center the matrix by columns (Xoff) and then we obtain the eigenvalues and the
+#'eigenvectors of the matrix Xoff%*%t(Xoff) and we
+#'use the equivalences between the loadings and scores to obtain the solution
+#'@param X Input matrix that has as columns the compounds that were considered as variables in the PCA analysis
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+PCA.GENES<-function(X){
+ n<-ncol(X)
+ p<-nrow(X)
+ offset<-apply(X,2,mean)
+ Xoff<-X-(cbind(matrix(1,p,1))%*%rbind(offset));
+ Xoff <- data.matrix(Xoff);
+
+ #eigen command sorts the eigenvalues in decreasing orden.
+ eigen<-eigen(Xoff%*%t(Xoff)/(p-1))
+ var<-cbind(eigen$values/sum(eigen$values),cumsum(eigen$values/sum(eigen$values)))
+
+ loadings2<-eigen$vectors
+ scores2<-t(Xoff)%*%loadings2
+
+ normas2 <- sqrt(apply(scores2^2,2,sum))
+ scores1 <- loadings2%*%diag(normas2);
+ rownames(scores1) <- rownames(X);
+ loadings1 <- scores2%*%diag(1/normas2)
+
+ output <- list(eigen,var,scores1,loadings1)
+ names(output) <- c("eigen","var.exp","scores","loadings")
+ output
+}
+
+#'Plot scree plots for each model in ASCA
+#'@description Plot scree plots for each model in ASCA
+#'@usage PlotModelScree(mSetObj, imgName, format="png", dpi=72, width=NA)
+#'@param mSetObj Input name of the created mSet Object.
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotModelScree <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+
+ if(is.na(width)){
+ w <- 9;
+ }else if(width == 0){
+ w <- 7;
+ }else{
+ w <- width;
+ }
+ h <- w;
+
+ mSetObj$imgSet$asca.scree <- imgName;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, type=format, width=w, height=h, bg="white");
+
+ models <- mSetObj$analSet$asca$models;
+ # note four plots, model a, b, ab and res
+ par(mfrow=c(2,2),oma=c(0,0,3,0), cex=1.0)
+
+ for ( i in 1: length (models)) {
+ pc.var <- models[[i]]$var.exp[,1];
+ if(length(pc.var) > 8){
+ pc.var <- pc.var[1:8];
+ }
+ ## Correct Typo: Expalined --> ExPlained by B. Han (17 Sep 2013)
+ plot(pc.var, type="b", main=paste(names(models)[[i]]),
+ xlab="Component", ylab="Explained variability", axes=F);
+ axis(2);
+ axis(1, at=0:length(pc.var));
+ box();
+ }
+ title("Scree plots of each model", outer=TRUE)
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+#'Plot score plots of each ASCA model for component 1 against time
+#'@description Plot score plots of each ASCA model for component 1 against time
+#'@usage PlotASCAModel(mSetObj=NA, imgName, format="png", dpi=72, width=NA, type, colorBW=FALSE)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param imgName Input a name for the ASCA score plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@param type select model a or b
+#'@param colorBW Logical, use black/white coloring (T) or not (F)
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotASCAModel<-function(mSetObj=NA, imgName, format="png", dpi=72, width=NA, type, colorBW=FALSE){
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(type == "a"){
+ md <- mSetObj$analSet$asca$models$Model.a;
+ lbls <- as.character(levels(mSetObj$dataSet$facA));
+ fac.lbl <- mSetObj$dataSet$facA.lbl;
+ }else{
+ md <- mSetObj$analSet$asca$models$Model.b;
+ lbls <- as.character(levels(mSetObj$dataSet$facB));
+ fac.lbl <- mSetObj$dataSet$facB.lbl;
+ }
+ pcNum <- md$facNum;
+
+ # plot at most top 3 PCs
+ if(pcNum > 3){
+ pcNum <- 3;
+ }
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ h.adj <- ifelse(md$facNum > 1, 5/6, 1)
+ if(is.na(width)){
+ w <- ifelse(md$facNum > 1, 6, 5);
+ }else if(width == 0){
+ w <- ifelse(md$facNum > 1, 6, 5);
+ }else{
+ w <- width;
+ }
+ h <- w*h.adj;
+
+ if(type == "a"){
+ mSetObj$imgSet$asca.modelA <- imgName;
+ }else{
+ mSetObj$imgSet$asca.modelB <- imgName;
+ }
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ par(mfrow = c(1, pcNum), cex=1.0);
+ for(j in 1:pcNum){
+ ## add 'xlab=fac.lbl' & replace ylab as "Scores Component #1 (XX% of variation explained)"
+ ## by B. Han (17 Sep 2013)
+ # plot(md$scores[,j], type="b", ylab="Concentration / Intensity", col=cols[j], pch=19,
+ # main=paste(fac.lbl, ", component", j, sep=""), axes=F);
+
+ # BHan: modified for Black/White color
+ # cols[j] --> color
+ colortype <- ifelse(colorBW, "black", (j + 1));
+ plot(md$scores[,j], type="b", ylab=paste("Scores (",round(md$var.exp[j,1]*100,2),"% of variation explained)"),
+ col=colortype, pch=19,
+ main=paste(fac.lbl, ", component", j, sep=""), axes=F,
+ xlab=fac.lbl);
+
+ axis(2);
+ axis(1, label=lbls, at=1:length(lbls));
+ box();
+ }
+
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+#'Plot ASCA interaction plots
+#'@description Plot ASCA interaction plots
+#'@usage PlotInteraction(mSetObj=NA, imgName, format="png", dpi=72, colorBW=FALSE, width=NA)
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param colorBW Logical, use black and white (TRUE) or colors (FALSE)
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotInteraction <- function(mSetObj=NA, imgName, format="png", dpi=72, colorBW=FALSE, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ md <- mSetObj$analSet$asca$models$Model.ab;
+ ab.lbls <- as.character(levels(mSetObj$dataSet$facA));
+ ba.lbls <- as.character(levels(mSetObj$dataSet$facB));
+ pcNum <- md$facNum;
+ if(pcNum > 3){
+ pcNum <- 3;
+ }
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- ifelse(md$facNum > 1, 8, 5)
+ }else if(width == 0){
+ w <- ifelse(md$facNum > 1, 7, 4.6);
+ }else{
+ w <- width;
+ }
+ h <- 8;
+
+ mSetObj$imgSet$asca.modelAB <- imgName;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=9, type=format, bg="white");
+ lmat<-matrix(1:(4*pcNum), nrow=4, byrow=F);
+ lwid<-rep(4.0, pcNum);
+ lhei<-rep(c(4.0, 0.4), 2);
+ layout(lmat, widths = lwid, heights = lhei, respect = FALSE)
+
+ # BHan: modified for black/white color; change line type and symbol
+ numscores <- ifelse( (length(ba.lbls) > length(ab.lbls)), length(ba.lbls), length(ab.lbls) );
+ if( colorBW ) {
+ cols <- "black";
+ linestyle<- (1:numscores) + 1;
+ pchstyle <- (1:numscores) + 4;
+ } else {
+ cols <- (1:numscores) + 1;
+ linestyle <- 1;
+ pchstyle <- 19;
+ }
+
+ for(j in 1:pcNum){ # plot layout column wise
+ scores <- md$scores[,j];
+
+ #b y & a x
+ md.scores <- matrix(scores, nrow=length(levels(mSetObj$dataSet$facB)), byrow=T);
+
+
+ # note, matplot plot each col, need to transpose
+ par(mar = c(3,4,3,2), cex=1.0);
+
+ ## replace ylab as "Scores (XX% of variation explained)" by B. Han (17 Sep 2013)
+ # matplot(t(md.scores), type="b", pch=19, lty=1, axes=F, col = cols,
+ # ylab="Concentration / Intensity", main=paste("Interaction, component", j, sep=""));
+
+ matplot(t(md.scores), type="b", pch=pchstyle, lty=linestyle, axes=F, col = cols,
+ ylab=paste("Scores (",round(md$var.exp[j,1]*100,2),"% of variation explained)"),
+ main=paste("Interaction, component", j, sep=""));
+ axis(1, label=ab.lbls, at=1:length(ab.lbls));
+ axis(2);
+ box();
+
+
+ par(mar = c(0,0,0,0), cex=1.0);
+ plot.new();
+ # legend("center", horiz=T, legend = as.character(ba.lbls), pch=pchstyle, col=(1:length(ba.lbls))+1, lty=1, bty="n");
+ legend("center", horiz=T, legend = as.character(ba.lbls), pch=pchstyle, col=cols, lty=linestyle, bty="n");
+
+ #b x & a y
+ op <- par(mar = c(3,4,4,2), cex=1.0);
+
+ # cols <- (1:ncol(md.scores)) + 1; # duplicated
+
+ ## replace ylab as "Scores (XX% of variation explained)" by B. Han (17 Sep 2013)
+ # matplot(md.scores, type="b", pch=19, lty=1, col= cols, axes=F,
+ # ylab="Concentration / Intensity", main=paste("Interaction, component", j, sep=""));
+ matplot(md.scores, type="b", pch=pchstyle, lty=linestyle, col= cols, axes=F,
+ ylab=paste("Scores (",round(md$var.exp[j,1]*100,2),"% of variation explained)"),
+ main=paste("Interaction, component", j, sep=""));
+ axis(1, label=ba.lbls, at=1:length(ba.lbls));
+ axis(2);
+ box();
+
+ op <- par(mar = c(0,0,0,0), cex=1.0);
+ plot.new();
+ # legend("center", horiz=T, legend = as.character(ab.lbls), pch=pchstyle, col=(1:length(ab.lbls))+1, lty=1, bty="n");
+ legend("center", horiz=T, legend = as.character(ab.lbls), pch=pchstyle, col=cols, lty=linestyle, bty="n");
+ }
+ dev.off();
+
+ return(.set.mSet(mSetObj));
+}
+
+#'Plot the important variables for each factor
+#'@description Plot the important variables for each factor
+#'@usage PlotAscaImpVar(mSetObj=NA, imgName, format, dpi, width=NA, type)
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@param type select model a, b, or ab
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotAscaImpVar <- function(mSetObj=NA, imgName, format, dpi, width=NA, type){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(type == "a"){
+ lvg <- mSetObj$analSet$asca$models$Model.a$leverage;
+ spe <- mSetObj$analSet$asca$models$Model.a$SPE;
+ lv.cutoff <- mSetObj$analSet$asca$leverage.cutoff["Model.a"];
+ spe.cutoff <- mSetObj$analSet$asca$SPE.cutoff["Model.a"];
+ lbl <- mSetObj$dataSet$facA.lbl;
+ }else if(type == "b"){
+ lvg <- mSetObj$analSet$asca$models$Model.b$leverage;
+ spe <- mSetObj$analSet$asca$models$Model.b$SPE;
+ lv.cutoff <- mSetObj$analSet$asca$leverage.cutoff["Model.b"];
+ spe.cutoff <- mSetObj$analSet$asca$SPE.cutoff["Model.b"];
+ lbl <- mSetObj$dataSet$facB.lbl;
+ }else{
+ lvg <- mSetObj$analSet$asca$models$Model.ab$leverage;
+ spe <- mSetObj$analSet$asca$models$Model.ab$SPE;
+ lv.cutoff<- mSetObj$analSet$asca$leverage.cutoff["Model.ab"];
+ spe.cutoff <- mSetObj$analSet$asca$SPE.cutoff["Model.ab"];
+ lbl <- "Interaction";
+ }
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- 7;
+ }else if(width == 0){
+ w <- 7;
+ }else{
+ w <- width;
+ }
+ h <- w*6/7;
+
+ if(type == "a"){
+ mSetObj$imgSet$asca.impA<-imgName;
+ }else if(type == "b"){
+ mSetObj$imgSet$asca.impB<-imgName;
+ }else{
+ mSetObj$imgSet$asca.impAB<-imgName;
+ }
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ PlotSigVar(lvg, spe, lv.cutoff, spe.cutoff,lbl);
+ dev.off();
+ return(.set.mSet(mSetObj));
+}
+
+#'Supporting function for plotting important variables for each factor
+#'@description Supporting function for plotting important variables for each factor
+#'note, by control xpd to plot legend outside the plotting area
+#'without using layout
+#'@param x Input the X variable
+#'@param y Input the Y variable
+#'@param xline Input the xline
+#'@param yline Input the yline
+#'@param title Input the title
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+PlotSigVar <- function(x, y, xline, yline, title){
+
+ par(mar=c(5,4,3,8), xpd=F);
+
+ plot(x, y, xlab="Leverage", ylab="SPE", main=title);
+ axis.lims <- par("usr"); # x1, x2, y1 ,y2
+
+ bad.col <- rgb(0, 0, 1, 0.2);
+ polygon(c(axis.lims[1], axis.lims[1], axis.lims[2], axis.lims[2]), c(yline, axis.lims[4], axis.lims[4], yline),
+ col = bad.col, border = NA);
+
+ good.col <- rgb(1, 0, 0, 0.2);
+ polygon(c(xline, xline, axis.lims[2], axis.lims[2]), c(axis.lims[3], yline, yline, axis.lims[3]),
+ col = good.col, border = NA);
+
+ abline(v = xline, col="red");
+ abline(h = yline, col="red");
+
+ # outside x2, and middle y
+ lgd.x <- axis.lims[2];
+ lgd.y <- (axis.lims[4] - axis.lims[3])/2;
+
+ par(xpd=T);
+ legend(lgd.x, lgd.y, legend = c("Well-modelled", "Outliers"),
+ fill=c(good.col, bad.col), bty="n");
+ box();
+}
+
+#'Plot ASCA permutation
+#'@description Plot plsda classification performance using different components
+#'@usage PlotASCA.Permutation(mSetObj=NA, imgName, format="png", dpi=72, width=NA)
+#'@param mSetObj Input name of the created mSet Object
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotASCA.Permutation <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ perm.mat<-mSetObj$analSet$asca$perm.mat;
+ perm.p<-mSetObj$analSet$asca$perm.p;
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+
+ if(is.na(width)){
+ w <- 9;
+ }else if(width == 0){
+ w <- 9;
+
+ }else{
+ w <- width;
+ }
+ h <-2*w;
+
+ mSetObj$imgSet$asca.perm <- imgName;
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ par(mfrow=c(3,1), cex=1.0);
+ nms <- colnames(perm.mat);
+ for(i in 1:3){
+ limX <-range(perm.mat[,i])*c(0.9, 1.1);
+ hst <- hist(perm.mat[-1,i], breaks = "FD", freq=T, xlim = limX, axes=F, bty="l",
+ ylab="Frequency", xlab= 'Permutation test statistics', col="gray", main=nms[i]);
+
+ ticks <- heckbert(limX[1], limX[2], 8);
+ axis(1, at=ticks);
+ # add the indicator using original label
+ h <- max(hst$counts)
+ arrows(perm.mat[1,i], h/5, perm.mat[1,i], 0, col="red", lwd=2);
+ text(perm.mat[1,i], h/2, paste('Observed \n statistic \n', perm.p[i]), xpd=T);
+ }
+ dev.off();
+ return(.set.mSet(mSetObj));
+
+}
+
+##############################################
+##############################################
+########## Utilities for web-server ##########
+##############################################
+##############################################
+
+#'Table of features well modelled by ASCA
+#'@description Table of features well modelled by ASCA
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param nm Input the name of the well modelled features
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+GetSigTable.ASCA <- function(mSetObj=NA, nm){
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(nm == "Model.a"){
+ nmLbl <- paste("main effect", mSetObj$dataSet$facA.lbl);
+ }else if(nm == "Model.b"){
+ nmLbl <- paste("main effect", mSetObj$dataSet$facB.lbl);
+ }else{
+ nmLbl <- paste("interaction effect between", mSetObj$dataSet$facA.lbl, "and", mSetObj$dataSet$facB.lbl);
+ }
+ GetSigTable(mSetObj$analSet$asca$sig.list[[nm]], paste("ASCA. The table shows features that are well modelled by ", nmLbl, ".", sep=""), mSetObj$dataSet$type);
+ #return(.set.mSet(mSetObj));
+}
+
+GetAscaSigMat <- function(mSetObj=NA, type){
+ mSetObj <- .get.mSet(mSetObj);
+ if(type == "sigA"){
+ sig.mat <- CleanNumber(mSetObj$analSet$asca$sig.list[["Model.a"]])
+ }else if(type == "outA"){
+ sig.mat <- CleanNumber(mSetObj$analSet$asca$out.list[["Model.a"]])
+ }else if(type == "sigB"){
+ sig.mat <- CleanNumber(mSetObj$analSet$asca$sig.list[["Model.b"]]);
+ }else if(type == "outB"){
+ sig.mat <- CleanNumber(mSetObj$analSet$asca$out.list[["Model.b"]]);
+ }else if(type == "sigAB"){
+ sig.mat <- CleanNumber(mSetObj$analSet$asca$sig.list[["Model.ab"]]);
+ }else if(type == "outAB"){
+ sig.mat <- CleanNumber(mSetObj$analSet$asca$out.list[["Model.ab"]])
+ }else{
+ print(paste("Unknown data type: ", type));
+ return(0);
+ }
+
+ fileNm <- paste("asca_",type, ".csv", sep="");
+ fast.write.csv(signif(sig.mat,5), file=fileNm);
+ mSetObj$analSet$asca$sig.nm <- fileNm;
+
+ if(.on.public.web){
+ .set.mSet(mSetObj);
+ return(sig.mat);
+ }else{
+ return(.set.mSet(mSetObj));
+ }
+}
+
+GetAscaSigRowNames <- function(mSetObj=NA, type){
+ mSetObj <- .get.mSet(mSetObj);
+ if(type == "sigA"){
+ return(rownames(mSetObj$analSet$asca$sig.list[["Model.a"]]))
+ }
+ if(type == "outA"){
+ return(rownames(mSetObj$analSet$asca$out.list[["Model.a"]]))
+ }
+ if(type == "sigB"){
+ return(rownames(mSetObj$analSet$asca$sig.list[["Model.b"]]))
+ }
+ if(type == "outB"){
+ return(rownames(mSetObj$analSet$asca$out.list[["Model.b"]]))
+ }
+ if(type == "sigAB"){
+ return(rownames(mSetObj$analSet$asca$sig.list[["Model.ab"]]))
+ }
+ if(type == "outAB"){
+ return(rownames(mSetObj$analSet$asca$out.list[["Model.ab"]]))
+ }
+ return(0);
+}
+
+GetAscaSigColNames <- function(type){
+ return(c("Leverage", "SPE"));
+}
+
+GetAscaSigFileName <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$analSet$asca$sig.nm
+}
+
+#'Heckbert algorithm
+#'@description function to calculate tick mark based on Heckbert algorithm
+#'available in the "labeling" package implemented by Justin Talbot
+#'adapted from the imagemap package
+#'Heckbert's labeling algorithm
+#'Heckbert, P. S. (1990) Nice numbers for graph labels, Graphics Gems I, Academic Press Professional, Inc.
+#'@param dmin Heckbert
+#'@param dmax Heckbert
+#'@param m Heckbert
+#'@author Justin Talbot \email{jtalbot@@stanford.edu}
+
+heckbert <- function(dmin, dmax, m){
+ range <- .heckbert.nicenum((dmax-dmin), FALSE)
+ lstep <- .heckbert.nicenum(range/(m-1), TRUE)
+ lmin <- floor(dmin/lstep)*lstep
+ lmax <- ceiling(dmax/lstep)*lstep
+ seq(lmin, lmax, by=lstep)
+}
+
+.heckbert.nicenum <- function(x, round){
+ e <- floor(log10(x))
+ f <- x / (10^e)
+ if(round)
+ {
+ if(f < 1.5) nf <- 1
+ else if(f < 3) nf <- 2
+ else if(f < 7) nf <- 5
+ else nf <- 10
+ }
+ else
+ {
+ if(f <= 1) nf <- 1
+ else if(f <= 2) nf <- 2
+ else if(f <= 5) nf <- 5
+ else nf <- 10
+ }
+ nf * (10^e)
+}
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/time_mb.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/time_mb.R
new file mode 100755
index 0000000000000000000000000000000000000000..17846d1e5ace539d5c1737bbf98da8a3250ca05f
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/time_mb.R
@@ -0,0 +1,994 @@
+#'Timecourse analysis
+#'@description Adapted from the timecourse package by Yu Chuan Tai
+#'This method is only applicable for time-series, not for general case
+#'two/multiple factor analysis
+#'@usage performMB(mSetObj, topPerc)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param topPerc select the cut-off, default is 10
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+performMB <- function(mSetObj=NA, topPerc = 10){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ time.fac <- mSetObj$dataSet$time.fac;
+ exp.fac <- mSetObj$dataSet$exp.fac;
+ sbj <- vector(mode="character", length=nrow(mSetObj$dataSet$norm));
+
+ time.len <- length(levels(time.fac));
+ exp.len <- numeric(length(levels(exp.fac)));
+ # to record the replicates in each exp condition
+ # note, this is not sample number, but replicates/subjects
+ k = 1;
+ len = 0;
+ m = 0;
+ for(lv1 in levels(exp.fac)){
+ m = m + 1;
+ # same subjects must in the same exp. condition
+ inx1 <- exp.fac == lv1;
+
+ # same subjects must not in the same time points
+ # all subjects will appear in each time points once
+ for (lv2 in levels(time.fac)){
+ inx2 <- time.fac == lv2;
+ len <- sum(inx1 & inx2);
+ exp.len[m] <- len;
+ sbj[inx1 & inx2] <- paste("S", k:(k+len-1), sep="");
+ }
+ k = k + len;
+ }
+
+ # the size matrix specify the number of replicates in each exp. condition
+ size <- matrix(exp.len, byrow=TRUE, nrow=ncol(mSetObj$dataSet$norm), ncol=length(levels(exp.fac)));
+ exp.grp <- as.character(exp.fac);
+ rep.grp <- as.character(sbj);
+
+ if(mSetObj$dataSet$design == "time0"){ # time series only
+ time.len <- length(levels(time.fac));
+ subj.len <- rep(length(levels(exp.fac)), ncol(mSetObj$dataSet$norm));
+ rep.grp <- as.character(exp.fac);
+ time.grp <- as.numeric(time.fac);
+ MB.stats <- suppressWarnings(mb.1D(t(mSetObj$dataSet$norm), time.len, subj.len, n.grp=rep.grp, k.grp=time.grp));
+ }else if(length(levels(exp.fac)) > 2){
+ MB.stats <- suppressWarnings(mb.MANOVA(t(mSetObj$dataSet$norm), times=time.len, D=length(exp.len), size=size, rep.grp=rep.grp, condition.grp=exp.grp));
+ }else{
+ MB.stats <- suppressWarnings(mb.2D(t(mSetObj$dataSet$norm), time.len, size, exp.grp, mn.grp=rep.grp));
+ }
+ if(is.null(MB.stats)) {
+ AddErrMsg("Please make sure the data are formatted properly for time-series analysis. In particular, for each time point, all experiments must exist and cannot be missing!");
+ mSetObj$analSet$MB <- NULL;
+ return(0);
+ }
+ fast.write.csv(signif(MB.stats, 5), file="meba_sig_features.csv");
+ mSetObj$analSet$MB <-list(stats=MB.stats);
+ return(.set.mSet(mSetObj));
+}
+
+#'Plot MB Time Profile
+#'@description Plot MB Time Profile
+#'@param mSetObj Input name of the created mSet Object
+#'@param cmpdNm Input the name of the compound
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotMBTimeProfile <- function(mSetObj=NA, cmpdNm, version, format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+ imgName <- gsub("\\/", "_", cmpdNm);
+ imgName <- paste(imgName, "_", version, "_dpi", dpi, ".", format, sep="");
+
+ # adjust width based on the time points
+ time.len <- length(levels(mSetObj$dataSet$time.fac));
+ if(is.na(width)){
+ w <- 5.0 + time.len/4; # 4 time points per inch?
+ }else if(width == 0){
+ w <- 5.4;
+ }else{
+ w <- width;
+ }
+ h <- min(5.4, w);
+ mSetObj$imgSet$mb <- imgName;
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ plotProfile(mSetObj, cmpdNm);
+ dev.off();
+
+ if(.on.public.web){
+ .set.mSet(mSetObj);
+ return(imgName);
+ }
+
+ return(.set.mSet(mSetObj));
+}
+
+# Used in higher function
+mb.MANOVA <- function (object, times, D, size, nu = NULL, Lambda = NULL, beta.d = NULL,
+ beta = NULL, alpha.d = NULL, alpha = NULL, condition.grp,
+ time.grp = NULL, rep.grp = NULL, p = 0.02)
+{
+ M <- as.matrix(object)
+ tr <- function(X) {
+ sum(diag(X))
+ }
+ G <- nrow(M)
+
+ max.size <- apply(size, 2, max)
+ if (ncol(size) != D)
+ stop("The sample sizes are incorrect!")
+ for (i in 1:D) {
+ if ((max.size[i] * times) != sum(condition.grp ==
+ sort(unique(condition.grp))[i]))
+ stop("The sample sizes or the biological condition group assignments are incorrect!")
+ }
+
+
+ time.grp <- rep(1:times, ncol(M)/times);
+
+ if (length(unique(time.grp)) != times)
+ stop("The number of time points or the time group \n assignments is incorrect!")
+ if (is.null(rep.grp)) {
+ rep.grp <- rep(1:(ncol(M)/times), rep(times, ncol(M)/times))
+ cat("Replicate group assignments are set to default.",
+ "\n")
+ }
+ mydata <- M
+ indx <- order(condition.grp, rep.grp, time.grp)
+ M <- M[, indx]
+ mis <- apply(!apply(M, 1, is.na), 2, sum)
+ mis <- sum((mis/times - floor(mis/times)) != 0)
+ if (mis > 0)
+ stop(mis, " genes may have within replicate missing values.")
+ N <- apply(size, 1, sum)
+ Sp <- apply(M, 1, matrix.cov, times, trans = FALSE, c.grp = condition.grp)
+ diagSp <- apply(Sp, 2, function(x) diag(matrix(x, ncol = times)))
+ Sp.avg <- matrix(apply(Sp, 1, mean, na.rm = TRUE), ncol = times)
+ if (is.null(nu) || is.null(Lambda)) {
+ nu.lim <- times + 6
+ if (!is.null(nu)) {
+ nu0 <- nu
+ nu <- max(nu0, nu.lim)
+ if (is.infinite(nu) & is.null(Lambda)) {
+ Lambda <- Sp.avg
+ }
+ if (is.finite(nu) & is.null(Lambda)) {
+ Lambda <- (nu - times - 1) * Sp.avg/nu
+ }
+ nu <- nu0
+ }
+ if (is.null(nu)) {
+ nu0 <- mean(sapply(1:times, function(x) squeezeVar(diagSp[x,
+ ], N - D)$df.prior))
+ nu <- max(nu0, nu.lim)
+ if (is.infinite(nu) & is.null(Lambda)) {
+ Lambda <- Sp.avg
+ }
+ if (is.finite(nu) & is.null(Lambda)) {
+ Lambda <- (nu - times - 1) * Sp.avg/nu
+ }
+ nu <- nu0
+ }
+ }
+ max.size <- apply(size, 2, max)
+ xbar.d <- as.list(NULL)
+ for (i in 1:D) {
+ grp.indx <- condition.grp == sort(unique(condition.grp))[i]
+ xbar.d[[i]] <- apply(M[, grp.indx], 1, function(x) apply(matrix(x,
+ byrow = TRUE, ncol = times), 2, mean, na.rm = TRUE))
+ }
+
+ simple.stat <- NULL
+ for(i in 1:(D-1))
+ for(j in (i+1):D)
+ simple.stat <- cbind(simple.stat, apply(abs(xbar.d[[i]]-xbar.d[[j]]),2,sum,na.rm=TRUE))
+
+ simple.stat <- apply(simple.stat,1,sum,na.rm=TRUE)
+ simple.rank <- G-rank(simple.stat)+1
+ indx1 <- simple.rank<=G*p
+ xbar <- sapply(1:G, function(x) apply(matrix(M[x, ], byrow = TRUE,
+ ncol = times), 2, mean, na.rm = TRUE))
+ if (is.null(alpha.d))
+ alpha.d <- sapply(1:D, function(x) apply(xbar.d[[x]][,indx1],
+ 1, mean, na.rm = TRUE))
+ if (is.null(alpha))
+ alpha <- apply(xbar[,!indx1], 1, mean, na.rm = TRUE)
+
+
+ if (is.null(beta.d) || is.null(beta)) {
+ U.d <- lapply(1:D, function(x) apply(xbar.d[[x]][,indx1] - alpha.d[,
+ x], 2, function(y) y %*% t(y)))
+ U <- apply(xbar[,!indx1] - alpha, 2, function(y) y %*% t(y))
+ Ubar.d <- sapply(1:D, function(x) apply(U.d[[x]], 1,
+ mean, na.rm = TRUE))
+ Ubar <- apply(U, 1, mean, na.rm = TRUE)
+ if (is.null(beta.d)){
+ Sp <- apply(M[indx1,], 1, matrix.cov, times, trans = FALSE, c.grp = condition.grp)
+ Sp.avg <- matrix(apply(Sp, 1, mean, na.rm = TRUE), ncol = times)
+ beta.d <- sapply(1:D, function(x) tr(Sp.avg)/tr(matrix(Ubar.d[,
+ x], ncol = times)))
+ }
+ if (is.null(beta)){
+ Sp <- apply(M[!indx1,], 1, matrix.cov, times, trans = FALSE, c.grp = condition.grp)
+ Sp.avg <- matrix(apply(Sp, 1, mean, na.rm = TRUE), ncol = times)
+ beta <- tr(Sp.avg)/tr(matrix(Ubar, ncol = times))
+ }
+ }
+ Sp <- apply(M, 1, matrix.cov, times, trans = FALSE, c.grp = condition.grp)
+ Sp.avg <- matrix(apply(Sp, 1, mean, na.rm = TRUE), ncol = times)
+ U.d <- lapply(1:D, function(x) apply(xbar.d[[x]] - alpha.d[,
+ x], 2, function(y) y %*% t(y)))
+ U <- apply(xbar- alpha, 2, function(y) y %*% t(y))
+ total <- (N - 1) * apply(M, 1, matrix.cov, times, trans = FALSE,
+ c.grp = rep(1, ncol(M)))
+ within <- Sp * (N - D)
+ if (sum(N == max(N)) == G)
+ M <- U/(N[1]^(-1) + beta^(-1))
+ if (sum(N == max(N)) < G)
+ M <- sapply(1:G, function(x) U[, x]/(N[x]^(-1) + beta^(-1)))
+ M.d <- as.list(NULL)
+ for (i in 1:D) {
+ if (sum(size[, i] == max.size[i]) == G)
+ M.d[[i]] <- U.d[[i]]/(size[1, i]^(-1) + beta.d[i]^(-1))
+ if (sum(size[, i] == max.size[i]) < G)
+ M.d[[i]] <- sapply(1:G, function(x) U.d[[i]][, x]/(size[x,
+ i]^(-1) + beta.d[i]^(-1)))
+ }
+ M1 <- matrix(0, nrow = times^2, ncol = G)
+ for (i in 1:D) M1 <- M1 + M.d[[i]]
+ tol <- .Machine$double.eps
+
+ if (nu < 0)
+ stop("The estimation of prior degrees of freedom <0 !")
+ if (is.finite(nu) & nu > tol) {
+ MB1 <- log(p, 10) - log(1 - p, 10)
+ MB2 <- 0.5 * times * (log(N + beta, 10) - log(beta, 10))
+ MB3 <- 0.5 * times * apply((log(beta.d, 10) - log(size +
+ beta.d, 10)), 1, sum)
+ MB4 <- sapply(1:G, function(x) 0.5 * (N[x] + nu) * (log(det(matrix(total[,
+ x], ncol = times) + matrix(M[, x], ncol = times) +
+ nu * Lambda), 10) - log(det(matrix(within[, x], ncol = times) +
+ matrix(M1[, x], ncol = times) + nu * Lambda), 10)))
+ MB <- MB1 + MB2 + MB3 + MB4
+ }
+ if (is.infinite(nu)) {
+ MB1 <- log(p, 10) - log(1 - p, 10)
+ MB2 <- 0.5 * times * (log(N + beta, 10) - log(beta, 10))
+ MB3 <- 0.5 * times * apply((log(beta.d, 10) - log(size +
+ beta.d, 10)), 1, sum)
+ MB4 <- sapply(1:G, function(x) tr(matrix(total[, x],
+ ncol = times) - matrix(within[, x], ncol = times) +
+ matrix(M[, x], ncol = times) - matrix(M1[, x], ncol = times)) -
+ log(10))
+ MB <- MB1 + MB2 + MB3 + MB4
+ }
+ if (nu < tol & nu >= 0) {
+ MB1 <- log(p, 10) - log(1 - p, 10)
+ MB2 <- 0.5 * times * (log(N + beta, 10) - log(beta, 10))
+ MB3 <- 0.5 * times * apply((log(beta.d, 10) - log(size +
+ beta.d, 10)), 1, sum)
+ MB4 <- sapply(1:G, function(x) 0.5 * N[x] * (log(det(matrix(total[,
+ x], ncol = times) + matrix(M[, x], ncol = times)),
+ 10) - log(det(matrix(within[, x], ncol = times) +
+ matrix(M1[, x], ncol = times)), 10)))
+ MB <- MB1 + MB2 + MB3 + MB4
+ }
+
+ names(MB) <- rownames(object);
+ MB <- round(sort(MB, decreasing = TRUE),5);
+ MB <- as.matrix(MB, ncol=1);
+ colnames(MB) <- c("MB-statistics");
+ MB;
+}
+
+#'Plot the variable across time points (x)
+#'@description Colored by experimental conditions, used in higher function
+#'@param mSetObj Input name of the created mSet Object
+#'@param varName Input the name of the variable
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+plotProfile <-function (mSetObj=NA, varName) {
+
+ mSetObj <- .get.mSet(mSetObj);
+ varInx <- colnames(mSetObj$dataSet$norm) == varName;
+ var <- mSetObj$dataSet$norm[,varInx];
+
+ time.fac <- mSetObj$dataSet$time.fac;
+ exp.fac <- mSetObj$dataSet$exp.fac;
+
+ cols <- unique(GetColorSchema(exp.fac));
+
+ # fold the var into a matrix with
+ # each row contains values for one time poinst
+ tpNum <- length(levels(time.fac));
+ colVec <- NULL;
+ lvlVec <- NULL;
+ varMat <- NULL;
+ for(m in 1:length(levels(exp.fac))){
+ lv1 <- levels(exp.fac)[m];
+ expInx <- exp.fac == lv1;
+ expLen <- sum(expInx);
+ colNum <- expLen/tpNum;
+ subMat <- matrix(0, nrow=tpNum, ncol=colNum);
+ subCol <- rep(cols[m], colNum);
+ subLvl <- rep(lv1, colNum);
+ for(i in 1:length(levels(time.fac))){
+ lv2 <- levels(time.fac)[i];
+ timeInx <- time.fac == lv2;
+ hitInx <- expInx & timeInx;
+ subMat[i,] <- var[hitInx];
+ }
+ varMat <- cbind(varMat, subMat);
+ colVec <- c(colVec, subCol);
+ lvlVec <- c(lvlVec, subLvl);
+ }
+
+ # increase y lim for legend
+ ylim <- GetExtendRange(range(varMat));
+
+ # note, matplot plot each col, need to transpose
+ matplot(varMat, type="b", pch=19, lty=1, col=colVec,ylim=ylim,
+ xlab="Time", ylab="Abundance",
+ main=varName,axes=FALSE);
+
+ #time.lbl <- unique(as.character(time.fac));
+ time.lbl <- unique(levels(time.fac));
+
+ legend("top", legend=unique(lvlVec), horiz=TRUE, lty=1, bty="n", col=unique(colVec));
+
+ axis(1, label=time.lbl, at=1:length(time.lbl));
+ axis(2);
+ box();
+}
+
+# Used in higher function
+matrix.cov <- function(x, k, trans=TRUE, c.grp=NULL, use="complete.obs")
+{
+ # x is already sorted by c.grp, n.grp and k.grp
+ if(!is.numeric(x)) x <- as.numeric(x)
+ if(missing(k)) stop("The number of time points is missing.")
+
+ if(length(unique(c.grp))==1)
+ {
+ res <-cov(matrix(x, byrow=TRUE, ncol=k),use=use)
+
+ if(trans)
+ {
+ OT1 <- ot.helmert(k)[2:k,]
+ if(k==2) OT1 <- t(as.matrix(OT1))
+ res <- OT1%*%res%*%t(OT1)
+ }
+
+ }
+
+ if(length(unique(c.grp))>1 & !trans)
+ {
+ D <- length(unique(c.grp))
+ size <- max.size <- NULL
+ for(i in 1:D)
+ {
+ grp.indx <- c.grp==sort(unique(c.grp))[i]
+ if(k==1) size[i] <- sum(apply(t(as.matrix(!apply(matrix(x[grp.indx], byrow=TRUE,ncol=k),1, is.na))),2,sum)==k)
+ if(k>1) size[i] <- sum(apply((!apply(matrix(x[grp.indx], byrow=TRUE,ncol=k),1, is.na)),2,sum)==k)
+ max.size[i] <- sum(grp.indx)/k
+ }
+ cumsize <- cumsum(max.size)
+ cumsize1 <- cumsum(size)
+ res1 <- as.list(NULL)
+ for(i in 1:D)
+ {
+ if(size[i]==1) res1[[i]] <- matrix(0,k,k)
+ if(i==1 & size[i]>1) res1[[i]] <- cov(matrix(x[1:(k*cumsize[1])], byrow=TRUE, ncol=k),use=use)
+ if(i>1& size[i]>1) res1[[i]] <- cov(matrix(x[(k*cumsize[i-1]+1):(k*cumsize[i])], byrow=TRUE, ncol=k),use=use)
+ }
+
+ if(k>1) res <- matrix(apply(sapply(1:D, function(x) (size[x]-1)*res1[[x]]),1,sum),ncol=k)/(cumsize1[D]-D)
+ if(k==1) res <- matrix(sum(sapply(1:D, function(x) (size[x]-1)*res1[[x]])),ncol=k)/(cumsize1[D]-D)
+ }
+ res
+}
+
+# Used in higher function
+squeezeVar <- function(var, df){
+ n <- length(var)
+ if(n == 0) stop("var is empty")
+ if(n == 1) return(list(var.post=var,var.prior=var,df.prior=0))
+ if(length(df)==1) {
+ df <- rep.int(df,n)
+ } else {
+ if(length(df) != n) stop("lengths differ")
+ }
+ out <- fitFDist(var, df1=df)
+ if(is.null(out$df2) || is.na(out$df2)) stop("Could not estimate prior df")
+ out$var.prior <- out$scale
+ out$df.prior <- out$df2
+ out$df2 <- out$scale <- NULL
+ df.total <- df + out$df.prior
+ if(out$df.prior == Inf)
+ out$var.post <- rep.int(out$var.prior,n)
+ else {
+ var[df==0] <- 0 # guard against missing or infinite values
+ out$var.post <- (df*var + out$df.prior*out$var.prior) / df.total
+ }
+ out
+}
+
+# Used in higher function
+fitFDist <- function(x, df1) {
+ # Moment estimation of the parameters of a scaled F-distribution
+ # The first degrees of freedom is given
+ # Gordon Smyth
+ # 8 Sept 2002. Last revised 6 April 2006.
+
+ # Remove missing or infinite values and zero degrees of freedom
+ o <- is.finite(x) & is.finite(df1) & (x >= 0) & (df1 > 0)
+ if(any(!o)) {
+ x <- x[o]
+ df1 <- df1[o]
+ }
+ n <- length(x)
+ if(n==0) return(list(scale=NA,df2=NA))
+
+ # Avoid exactly zero values
+ m <- median(x)
+ if(m==0) {
+ warning("More than half of residual variances are exactly zero: eBayes unreliable")
+ m <- 1
+ } else {
+ if(any(x==0)) warning("Zero sample variances detected, have been offset",call.=FALSE)
+ }
+ x <- pmax(x, 1e-5 * median(x))
+
+ # Better to work on with log(F)
+ z <- log(x)
+ e <- z-digamma(df1/2)+log(df1/2)
+ emean <- mean(e)
+ evar <- mean(n/(n-1)*(e-emean)^2-trigamma(df1/2))
+ if(evar > 0) {
+ df2 <- 2*trigammaInverse(evar)
+ s20 <- exp(emean+digamma(df2/2)-log(df2/2))
+ } else {
+ df2 <- Inf
+ s20 <- exp(emean)
+ }
+ list(scale=s20,df2=df2)
+}
+
+# Used in higher function
+trigammaInverse <- function(x) {
+ # Solve trigamma(y) = x for y
+ # Gordon Smyth
+ # 8 Sept 2002. Last revised 12 March 2004.
+
+ # Non-numeric or zero length input
+ if(!is.numeric(x)) stop("Non-numeric argument to mathematical function")
+ if(length(x)==0) return(numeric(0))
+
+ # Treat out-of-range values as special cases
+ omit <- is.na(x)
+ if(any(omit)) {
+ y <- x
+ if(any(!omit)) y[!omit] <- Recall(x[!omit])
+ return(y)
+ }
+ omit <- (x < 0)
+ if(any(omit)) {
+ y <- x
+ y[omit] <- NaN
+ warning("NaNs produced")
+ if(any(!omit)) y[!omit] <- Recall(x[!omit])
+ return(y)
+ }
+ omit <- (x > 1e7)
+ if(any(omit)) {
+ y <- x
+ y[omit] <- 1/sqrt(x[omit])
+ if(any(!omit)) y[!omit] <- Recall(x[!omit])
+ return(y)
+ }
+ omit <- (x < 1e-6)
+ if(any(omit)) {
+ y <- x
+ y[omit] <- 1/x[omit]
+ if(any(!omit)) y[!omit] <- Recall(x[!omit])
+ return(y)
+ }
+
+ # Newton's method
+ # 1/trigamma(y) is convex, nearly linear and strictly > y-0.5,
+ # so iteration to solve 1/x = 1/trigamma is monotonically convergent
+ y <- 0.5+1/x
+ iter <- 0
+ repeat {
+ iter <- iter+1
+ tri <- trigamma(y)
+ dif <- tri*(1-tri/x)/psigamma(y,deriv=2)
+ y <- y+dif
+ if(max(-dif/y) < 1e-8) break
+ if(iter > 50) {
+ warning("Iteration limit exceeded")
+ break
+ }
+ }
+ y
+}
+
+# Used in higher function
+mb.2D <- function(object, k, mn, c.grp, nu=NULL, Lambda=NULL, eta=NULL, k.grp=NULL,
+ mn.grp=NULL, r=FALSE, vec=FALSE, d=NULL, prop=0.02, T2.only=TRUE)
+{
+
+ M <- as.matrix(object);
+
+ G <- nrow(M)
+
+ if(!is.null(mn))
+ {
+ max.mn1 <- max(mn[,1])
+ max.mn2 <- max(mn[,2])
+ if(ncol(mn) != length(unique(c.grp))) stop("The sample sizes are incorrect!")
+ if(((max.mn1*k) != sum(c.grp==sort(unique(c.grp))[1])) || ((max.mn2*k) != sum(c.grp==sort(unique(c.grp))[2])))
+ stop("The sample sizes or the biological condition group assignments are incorrect!")
+ }
+
+ if(is.null(k.grp))
+ {
+ k.grp <- rep(1:k, ncol(M)/k)
+ cat("Time group assignments are set to default.","\n")
+ }
+ if(length(unique(k.grp)) != k) stop("The number of time points or the time group assignments are
+ incorrect")
+ if(is.null(mn.grp))
+ {
+ mn.grp <- rep(1:(ncol(M)/k), rep(k, ncol(M)/k))
+ cat("Replicate group assignments are set to default.","\n")
+ }
+
+
+ mydata <- M
+ indx <- order(c.grp, mn.grp, k.grp)
+ M <- M[,indx]
+
+ mis <- apply(!apply(M, 1, is.na), 2, sum)
+ mis <- sum((mis/k-floor(mis/k)) !=0)
+ if(mis>0) stop(mis, " metabolites may have within replicate missing values.")
+
+
+ N <- apply(mn,1,sum)
+
+ ## sample sizes across genes are the same
+ ## only need to input the common sample size
+ Sp <- apply(M, 1, matrix.cov, k, trans=FALSE, c.grp=c.grp)
+ diagSp <- apply(Sp, 2, function(x) diag(matrix(x,ncol=k)))
+ Sp.avg <- matrix(apply(Sp, 1, mean, na.rm=TRUE),ncol=k)
+
+ if(is.null(nu)||is.null(Lambda))
+ {
+
+ nu.lim <- k+6
+
+ if(!is.null(nu))
+ {
+ nu0 <- nu
+ nu <- max(nu0, nu.lim)
+ if(is.infinite(nu)& is.null(Lambda)) {Lambda <- Sp.avg}
+ if(is.finite(nu)& is.null(Lambda)) {Lambda <- (nu-k-1)*Sp.avg/nu}
+ nu<- nu0
+ }
+
+ if(is.null(nu))
+ {
+ nu0 <- mean(sapply(1:k, function(x) squeezeVar(diagSp[x,], N-2)$df.prior))
+ nu <- max(nu0, nu.lim)
+ if(is.infinite(nu)& is.null(Lambda)) {Lambda <- Sp.avg}
+ if(is.finite(nu)& is.null(Lambda)) {Lambda <- (nu-k-1)*Sp.avg/nu}
+ nu<- nu0
+ }
+ }
+
+ max.n1 <- max(mn[,1])
+ max.n2 <- max(mn[,2])
+ xbar1 <- apply(M[, 1:(k*max.n1)], 1, function(x)
+ apply(matrix(x, byrow=FALSE, ncol=max.n1),1,mean,na.rm=TRUE))
+ xbar2 <- apply(M[, -c(1:(k*max.n1))], 1, function(x)
+ apply(matrix(x, byrow=FALSE, ncol=max.n2),1,mean,na.rm=TRUE))
+ if(r)
+ {
+ e1 <- sapply(1:G, function(x) matrix(M[x, 1:(k*max.n1)], byrow=FALSE, ncol=max.n1)-xbar1[,x])
+ tune1 <- sapply(1:G, function(x) d * median(abs(e1[, x]),na.rm = TRUE)/0.6745)
+ indx1 <- sapply(1:G, function(x) abs(e1[, x]) > tune1[x])
+ na.indx1 <- sapply(1:G, function(x) c(1:(k * max.n1))[!is.na(indx1[,x])])
+ wt1 <- matrix(rep(1, G * max.n1 * k), ncol = max.n1 * k)
+ wt1 <- t(sapply(1:G, function(x) {wt1[x,][-na.indx1[,x]] <- 0
+ wt1[x,]}))
+ wt1 <- t(sapply(1:G, function(x) {wt1[x, ][na.indx1[,x]][indx1[,x][na.indx1[,x]]] <-
+ tune1[x]/abs(e1[,x][na.indx1[,x]][indx1[,x][na.indx1[,x]]])
+ wt1[x,]}))
+ totalw1 <- sapply(1:G, function(x) apply(matrix(wt1[x,], byrow=FALSE, ncol=max.n1), 1, sum,
+ na.rm=TRUE))
+ w1 <- sapply(1:G, function(x) matrix(wt1[x,], byrow=FALSE, ncol=max.n1)/totalw1[,x])
+ xbar1 <- sapply(1:G, function(x)
+ apply(matrix(w1[, x] * M[x, 1:(k*max.n1)], byrow = FALSE, ncol = max.n1),1, sum,na.rm=TRUE))
+
+
+ e2 <- sapply(1:G, function(x) matrix(M[x, -(1:(k*max.n1))], byrow=FALSE, ncol=max.n2)-xbar2[,x])
+ tune2 <- sapply(1:G, function(x) d * median(abs(e2[, x]),na.rm = TRUE)/0.6745)
+ indx2 <- sapply(1:G, function(x) abs(e2[, x]) > tune2[x])
+ na.indx2 <- sapply(1:G, function(x) c(1:(k * max.n2))[!is.na(indx2[,x])])
+ wt2 <- matrix(rep(1, G * max.n2 * k), ncol = max.n2 * k)
+ wt2 <- t(sapply(1:G, function(x) {wt2[x,][-na.indx2[,x]] <- 0
+ wt2[x,]}))
+ wt2 <- t(sapply(1:G, function(x) {wt2[x, ][na.indx2[,x]][indx2[,x][na.indx2[,x]]] <-
+ tune2[x]/abs(e2[,x][na.indx2[,x]][indx2[,x][na.indx2[,x]]])
+ wt2[x,]}))
+ totalw2 <- sapply(1:G, function(x) apply(matrix(wt2[x,], byrow=FALSE, ncol=max.n2), 1, sum,
+ na.rm=TRUE))
+ w2 <- sapply(1:G, function(x) matrix(wt2[x,], byrow=FALSE, ncol=max.n2)/totalw2[,x])
+ xbar2 <- sapply(1:G, function(x)
+ apply(matrix(w2[, x] * M[x, -(1:(k*max.n1))], byrow = FALSE, ncol = max.n2),1, sum,na.rm=TRUE))
+ wt <- cbind(wt1, wt2)
+ }
+
+
+ X <- xbar1-xbar2
+ tol <- .Machine$double.eps
+ if(is.finite(nu) & nu > tol)
+ {
+ modSp <- sapply(1:G, function(x) ((N[x]-2)*matrix(Sp[,x],ncol=k)+nu*Lambda)/(N[x]-2+nu))
+ if(is.null(eta) & (T2.only==FALSE))
+ {
+ sqrt.modSp <- apply(modSp, 2, function(x)
+ svd(matrix(x,ncol=k))$u%*%diag(sqrt(svd(matrix(x,ncol=k))$d))%*%t(svd(matrix(x,ncol=k))$v))
+ modt <- sapply(1:G, function(x)
+ (mn[x,1]^(-1)+mn[x,2]^(-1))^(-1/2)*solve(matrix(sqrt.modSp[,x],ncol=k))%*%X[,x])
+ HotellingT2 <- apply(modt, 2, function(x) t(x)%*%x)
+ }
+ if(T2.only)
+ HotellingT2 <- sapply(1:G, function(x)
+ (mn[x,1]^(-1)+mn[x,2]^(-1))^(-1)*t(X[,x])%*%solve(matrix(modSp[,x],ncol=k))%*%X[,x])
+
+ if(!is.null(eta) & (T2.only==FALSE))
+ HotellingT2 <- sapply(1:G, function(x)
+ n[x]*t(T1%*%xbar[,x])%*%solve(matrix(modS1[,x],ncol=k-1))%*%T1%*%xbar[,x])
+ }
+
+ if(is.infinite(nu))
+ {
+ modSp <- sapply(1:G, function(x) Lambda)
+ if(is.null(eta) & (T2.only==FALSE))
+ {
+ sqrt.modSp <- apply(modSp, 2, function(x)
+ svd(matrix(x,ncol=k))$u%*%diag(sqrt(svd(matrix(x,ncol=k))$d))%*%t(svd(matrix(x,ncol=k))$v))
+ modt <- sapply(1:G, function(x)
+ (mn[x,1]^(-1)+mn[x,2]^(-1))^(-1/2)*solve(matrix(sqrt.modSp[,x],ncol=k))%*%X[,x])
+ HotellingT2 <- apply(modt, 2, function(x) t(x)%*%x)
+ }
+ if(T2.only)
+ HotellingT2 <- sapply(1:G, function(x)
+ (mn[x,1]^(-1)+mn[x,2]^(-1))^(-1)*t(X[,x])%*%solve(matrix(modSp[,x],ncol=k))%*%X[,x])
+
+ if(!is.null(eta) & (T2.only==FALSE))
+ HotellingT2 <- sapply(1:G, function(x)
+ n[x]*t(T1%*%xbar[,x])%*%solve(matrix(modS1[,x],ncol=k-1))%*%T1%*%xbar[,x])
+ }
+ if(nu < tol & nu >=0)
+ {
+ modSp <- Sp
+ if(is.null(eta) & (T2.only==FALSE))
+ {
+ sqrt.modSp <- apply(modSp, 2, function(x)
+ svd(matrix(x,ncol=k))$u%*%diag(sqrt(svd(matrix(x,ncol=k))$d))%*%t(svd(matrix(x,ncol=k))$v))
+ modt <- sapply(1:G, function(x)
+ (mn[x,1]^(-1)+mn[x,2]^(-1))^(-1/2)*ginv(matrix(sqrt.modSp[,x],ncol=k))%*%X[,x])
+ HotellingT2 <- apply(modt, 2, function(x) t(x)%*%x)
+ }
+ if(T2.only)
+ HotellingT2 <- sapply(1:G, function(x)
+ (mn[x,1]^(-1)+mn[x,2]^(-1))^(-1)*t(X[,x])%*%ginv(matrix(modSp[,x],ncol=k))%*%X[,x])
+
+ if(!is.null(eta) & (T2.only==FALSE))
+ HotellingT2 <- sapply(1:G, function(x)
+ n[x]*t(T1%*%xbar[,x])%*%solve(matrix(modS1[,x],ncol=k-1))%*%T1%*%xbar[,x])
+ }
+ if(is.null(eta)& (T2.only==FALSE)) eta <- mean(sapply(1:k, function(x) tmixture.matrix(modt[x,],
+ sqrt(mn[,1]^(-1)+mn[,2]^(-1)), N+nu-2, prop, c(0.1, 4)^2/Lambda[x,x]))^(-1))
+
+
+ if(nu < 0) stop("The estimation of prior degrees of freedom <0 !")
+
+ names(HotellingT2) <- rownames(object);
+ HotellingT2 <- round(sort(HotellingT2, decreasing = TRUE),5);
+ HotellingT2 <- as.matrix(HotellingT2, ncol=1);
+ colnames(HotellingT2) <- c("Hotelling-T2");
+ HotellingT2;
+}
+
+# Used in higher function
+mb.1D <- function(object, k, n, nu=NULL, Lambda1=NULL, eta=NULL, k.grp=NULL, n.grp=NULL, r=FALSE, vec=FALSE, d=NULL, prop=0.01, T2.only=TRUE) {
+
+ res <- as.list(NULL)
+ M <- as.matrix(object)
+
+ G <- nrow(M)
+ max.n <- max(n)
+
+ if(is.null(k.grp)){
+ k.grp <- rep(1:k, max.n)
+ cat("Time group assignments are set to default.","\n")
+ }
+
+ if(is.null(n.grp)){
+ n.grp <- rep(c(1:max.n), rep(k, max.n))
+ cat("Replicate group assignments are set to default.", "\n")
+ }
+
+ mydata <- M
+ indx <- order(n.grp, k.grp)
+ M <- M[,indx]
+
+ mis <- apply(!apply(M, 1, is.na), 2, sum)
+ mis <- sum((mis/k-floor(mis/k)) !=0)
+ if(mis>0) stop(mis, " genes may have missing values in some of the replicates.")
+
+
+ if((max.n*k) !=ncol(M)) stop("The number of time points or sample sizes are incorrect.")
+ if(length(unique(n.grp)) != max.n) stop("Sample sizes or replicate group assignments is incorrect.")
+ c.grp <- rep(1, k*max.n)
+
+ S1 <- apply(M, 1, matrix.cov, k, c.grp=c.grp)
+ if(is.null(nu)) diagS1 <- apply(S1, 2, function(x) diag(matrix(x,ncol=k-1)))
+ S1.avg <- matrix(apply(S1, 1, mean, na.rm=TRUE),ncol=k-1)
+
+
+ if(is.null(nu)||is.null(Lambda1)){
+ nu.lim <- k-1+6
+
+
+ if(!is.null(nu))
+ {
+ nu0 <- nu
+ nu <- max(nu0, nu.lim)
+ if(is.infinite(nu) & is.null(Lambda1)) {Lambda1 <- S1.avg}
+ if(is.finite(nu)& is.null(Lambda1)) {Lambda1 <- (nu-k)*S1.avg/nu }
+ nu<- nu0
+ }
+
+ if(is.null(nu))
+ {
+ nu0 <- mean(sapply(1:(k-1), function(x) squeezeVar(diagS1[x,], n-1)$df.prior))
+ nu <- max(nu0, nu.lim)
+ if(is.infinite(nu)& is.null(Lambda1)) {Lambda1 <- S1.avg}
+ if(is.finite(nu)& is.null(Lambda1)) {Lambda1 <- (nu-k)*S1.avg/nu }
+ nu<- nu0
+ }
+ }
+
+ max.n <- max(n)
+ T1 <- ot.helmert(k)[2:k,]
+ xbar <- apply(M, 1, function(x) apply(matrix(x, byrow=FALSE, ncol=max.n),1,mean,na.rm=TRUE))
+
+ if(r){
+ e <- sapply(1:G, function(x) matrix(M[x,], byrow=FALSE, ncol=max.n)-xbar[,x])
+ tune <- sapply(1:G, function(x) d * median(abs(e[, x]),na.rm = TRUE)/0.6745)
+ indx <- sapply(1:G, function(x) abs(e[, x]) > tune[x])
+ na.indx <- sapply(1:G, function(x) c(1:(k * max.n))[!is.na(indx[,x])])
+ wt <- matrix(rep(1, G * max.n * k), ncol = max.n * k)
+ wt <- t(sapply(1:G, function(x) {wt[x,][-na.indx[,x]] <- 0
+ wt[x,]}))
+ wt <- t(sapply(1:G, function(x) {wt[x, ][na.indx[,x]][indx[,x][na.indx[,x]]] <-
+ tune[x]/abs(e[,x][na.indx[,x]][indx[,x][na.indx[,x]]])
+ wt[x,]}))
+ totalw <- sapply(1:G, function(x) apply(matrix(wt[x,], byrow=FALSE, ncol=max.n), 1, sum,
+ na.rm=TRUE))
+ w <- sapply(1:G, function(x) matrix(wt[x,], byrow=FALSE, ncol=max.n)/totalw[,x])
+ xbar <- sapply(1:G, function(x)
+ apply(matrix(w[, x] * M[x, ], byrow = FALSE, ncol = max.n),1, sum,na.rm=TRUE));
+ }
+
+ tol <- .Machine$double.eps
+ if(is.finite(nu) & nu > tol)
+ {
+ modS1 <- sapply(1:G, function(x) ((n[x]-1)*matrix(S1[,x],ncol=k-1)+nu*Lambda1)/(n[x]-1+nu))
+ if(is.null(eta) & (T2.only==FALSE))
+ {
+ sqrt.modS1 <- apply(modS1, 2, function(x)
+ svd(matrix(x,ncol=k-1))$u%*%diag(sqrt(svd(matrix(x,ncol=k-1))$d))%*%t(svd(matrix(x,ncol=k-1))$v))
+ modt1 <- sapply(1:G, function(x) n[x]^(1/2)*solve(matrix(sqrt.modS1[,x],ncol=k-1))%*%T1%*%xbar[,x])
+ HotellingT2 <- apply(modt1, 2, function(x) t(x)%*%x)
+ }
+ if(T2.only)
+ HotellingT2 <- sapply(1:G, function(x)
+ n[x]*t(T1%*%xbar[,x])%*%solve(matrix(modS1[,x],ncol=k-1))%*%T1%*%xbar[,x])
+
+ if(!is.null(eta) & (T2.only==FALSE))
+ HotellingT2 <- sapply(1:G, function(x)
+ n[x]*t(T1%*%xbar[,x])%*%solve(matrix(modS1[,x],ncol=k-1))%*%T1%*%xbar[,x])
+
+ }
+
+ if(is.infinite(nu))
+ {
+ modS1 <- sapply(1:G, function(x) Lambda1)
+ if(is.null(eta) & (T2.only==FALSE))
+ {
+ sqrt.modS1 <- apply(modS1, 2, function(x)
+ svd(matrix(x,ncol=k-1))$u%*%diag(sqrt(svd(matrix(x,ncol=k-1))$d))%*%t(svd(matrix(x,ncol=k-1))$v))
+ modt1 <- sapply(1:G, function(x) n[x]^(1/2)*solve(matrix(sqrt.modS1[,x],ncol=k-1))%*%T1%*%xbar[,x])
+ HotellingT2 <- apply(modt1, 2, function(x) t(x)%*%x)
+ }
+ if(T2.only)
+ HotellingT2 <- sapply(1:G, function(x)
+ n[x]*t(T1%*%xbar[,x])%*%solve(matrix(modS1[,x],ncol=k-1))%*%T1%*%xbar[,x])
+
+ if(!is.null(eta) & (T2.only==FALSE))
+ HotellingT2 <- sapply(1:G, function(x)
+ n[x]*t(T1%*%xbar[,x])%*%solve(matrix(modS1[,x],ncol=k-1))%*%T1%*%xbar[,x])
+ }
+ if(nu < tol & nu >=0)
+ {
+ modS1 <- S1
+ if(is.null(eta) & (T2.only==FALSE))
+ {
+ sqrt.modS1 <- apply(modS1, 2, function(x)
+ svd(matrix(x,ncol=k-1))$u%*%diag(sqrt(svd(matrix(x,ncol=k-1))$d))%*%t(svd(matrix(x,ncol=k-1))$v))
+ modt1 <- sapply(1:G, function(x) n[x]^(1/2)*ginv(matrix(sqrt.modS1[,x],ncol=k-1))%*%T1%*%xbar[,x])
+ HotellingT2 <- apply(modt1, 2, function(x) t(x)%*%x)
+ }
+ if(T2.only)
+ HotellingT2 <- sapply(1:G, function(x)
+ n[x]*t(T1%*%xbar[,x])%*%ginv(matrix(modS1[,x],ncol=k-1))%*%T1%*%xbar[,x])
+
+ if(!is.null(eta) & (T2.only==FALSE))
+ HotellingT2 <- sapply(1:G, function(x)
+ n[x]*t(T1%*%xbar[,x])%*%solve(matrix(modS1[,x],ncol=k-1))%*%T1%*%xbar[,x])
+ }
+
+
+ # HotellingT2 does not require eta
+ if(is.null(eta) & (T2.only==FALSE)) eta <- mean(sapply(1:(k-1), function(x) tmixture.matrix(modt1[x,],
+ sqrt(1/n), n+nu-1, prop, c(0.1, 4)^2/Lambda1[x,x]))^(-1))
+
+ res$M <- mydata
+ res$prop <- prop
+ res$nu <- nu
+ res$Lambda1 <- Lambda1
+ res$eta <- eta
+
+
+ if(nu < 0) stop("The degrees of moderation <0 !")
+
+ tol <- .Machine$double.eps
+ if(is.finite(nu) & nu > tol)
+ {
+ MB <- NULL
+ if(T2.only==FALSE)
+ {
+ MB1 <- log(prop,10)-log(1-prop,10)
+ MB2 <- ((k-1)/2)*log((eta/(n+eta)),10)
+ MB3 <- ((n+nu)/2)*log(((n-1+nu+HotellingT2)/(n-1+nu+(eta/(n+eta))*HotellingT2)), 10)
+ MB <- MB1+MB2+MB3
+ }
+ unique.n <- unique(n)
+ res$percent <- matrix(c(unique.n, round(100*nu/(nu+unique.n-1))), ncol=2)
+ res$size <- n
+ res$con.group <- rep(1, k*max.n)
+ res$rep.group <- n.grp
+ res$time.group <- k.grp
+ if(r) res$weights <- wt
+ if(vec) res$modt1 <- modt1
+ res$HotellingT2 <- HotellingT2
+ res$MB <- MB
+ }
+
+ if(is.infinite(nu)){
+ MB <- NULL
+ if(T2.only==FALSE)
+ {
+ MB1 <- log(prop,10)-log(1-prop,10)
+ MB2 <- ((k-1)/2)*log((eta/(n+eta)),10)
+ MB3 <- 0.5*(n/(n+eta))*HotellingT2-log(10)
+ MB <- MB1+MB2+MB3
+ }
+
+ unique.n <- unique(n)
+ res$percent <- matrix(c(unique.n, 100), ncol=2)
+ res$size <- n
+ res$con.group <- rep(1, k*max.n)
+ res$rep.group <- n.grp
+ res$time.group <- k.grp
+ if(r) res$weights <- wt
+ if(vec) res$modt1 <- modt1
+ res$HotellingT2 <- HotellingT2
+ res$MB <- MB
+ }
+
+ if(nu < tol & nu >=0){
+ MB <- NULL
+ if(T2.only==FALSE)
+ {
+ MB1 <- log(prop,10)-log(1-prop,10)
+ MB2 <- ((k-1)/2)*log((eta/(n+eta)),10)
+ MB3 <- (n/2)*log(((n-1+HotellingT2)/(n-1+(eta/(n+eta))*HotellingT2)), 10)
+ MB <- MB1+MB2+MB3
+ }
+
+ unique.n <- unique(n)
+ res$percent <- matrix(c(unique.n, 0), ncol=2)
+ res$size <- n
+ res$con.group <- rep(1, k*max.n)
+ res$rep.group <- n.grp
+ res$time.group <- k.grp
+ if(r) res$weights <- wt
+ if(vec) res$modt1 <- modt1
+ res$HotellingT2 <- HotellingT2
+ res$MB <- MB
+ }
+
+ names(HotellingT2) <- rownames(object);
+ HotellingT2 <- round(sort(HotellingT2, decreasing = TRUE),5);
+ HotellingT2 <- as.matrix(HotellingT2, ncol=1);
+ colnames(HotellingT2) <- c("Hotelling-T2");
+ HotellingT2;
+}
+
+##############################################
+##############################################
+########## Utilities for web-server ##########
+##############################################
+##############################################
+
+GetMBSigMat <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(CleanNumber(mSetObj$analSet$MB$stats));
+}
+
+GetMBSigRowNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(rownames(mSetObj$analSet$MB$stats));
+}
+
+GetMBSigColNames <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(colnames(mSetObj$analSet$MB$stats));
+}
+
+#'Sig table for MB analysis
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@export
+GetSigTable.MB<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ GetSigTable(mSetObj$analSet$MB$stats, "MEBA", mSetObj$dataSet$type);
+}
+
+######### Utility Functions ###########
+ot.helmert <- function(k){
+
+ if(missing(k)) stop("The number of time points is missing.")
+
+ if (is.numeric(k) && length(k) == 1)
+ if(k > trunc(k)) stop("The number of time points is not an integer.")
+
+
+ levels <- 1:k
+
+ T0 <- matrix(rep(1/sqrt(k), k), byrow=TRUE, ncol=k)
+
+ T1 <- matrix(rep(0,(k-1)*k), ncol=k, byrow=TRUE)
+ T1 <- array(1/sqrt(diag(outer(row(T1)[,1]+1, row(T1)[,1], "*"))),c(k-1,k))
+ T1[col(T1) > row(T1)] <- 0
+ T1[col(T1) == row(T1)+1] <- -(row(T1)[,1])/sqrt(diag(outer(row(T1)[,1]+1, row(T1)[,1], "*")))
+
+ OT <- rbind(T0, T1)
+
+ OT
+}
\ No newline at end of file
diff --git a/archived/V2.1/ODA/MetaboAnalyst_3.0.3/time_pca_anova2.R b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/time_pca_anova2.R
new file mode 100755
index 0000000000000000000000000000000000000000..f6986f7ee28b80e8833d4edbbc78e0089e8704e1
--- /dev/null
+++ b/archived/V2.1/ODA/MetaboAnalyst_3.0.3/time_pca_anova2.R
@@ -0,0 +1,665 @@
+#'Perform Two-way ANOVA
+#'@description Perform Two-way ANOVA
+#'Perform within-subjects anova
+#'@param x Input the data
+#'@param time.fac Input the time factor
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+aov.within <- function(x, time.fac){
+ unlist(summary(aov(x ~ (aov.facA*aov.facB) + Error(aov.sbj/time.fac))), use.names=F)[c(7,20,21,9,23,24)];
+}
+
+aov.within.wo <- function(x, time.fac){
+ unlist(summary(aov(x ~ (aov.facA+aov.facB))), use.names=F)[c(10,11,13,14)];
+}
+
+#'Perform Two-way ANOVA
+#'@description Perform Two-way ANOVA
+#'Perform repeated measure one-way anova
+#'@param x Input the data
+#'@param time.fac Input the time factor
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'
+aov.repeated <- function(x, time.fac){
+ unlist(summary(aov(x ~ time.fac + Error(aov.sbj/time.fac))), use.names=F)[c(12,14)];
+}
+
+#'Perform Two-way ANOVA
+#'@description Perform Two-way ANOVA
+#'Perform between-subjects anova
+#'@param x Input data to perform 2-way ANOVA
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+
+aov.between <- function(x){
+ unlist(summary(aov(x ~ aov.facA*aov.facB)), use.names=F)[c(13,14,15,17,18,19)];
+}
+
+aov.between.type3 <- function(x){
+ unlist(car::Anova(lm(x ~ aov.facA*aov.facB), type="3"))[c(12,13,14,17,18,19)];
+}
+
+#'Perform Two-way ANOVA
+#'@description Perform Two-way ANOVA
+#'@usage ANOVA2.Anal(mSetObj=NA, thresh=0.05, p.cor="fdr", type="time0", aov.type=1, use.interact=1)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param thresh Input the p-value threshold
+#'@param p.cor Select method for p-value correction, bonferroni, holm or fdr
+#'@param type Select b to perform between-subjects ANOVA, and w for within-subjects ANOVA
+#'@param aov.type Specify 1 for ANOVA type 1, or 3 for ANOVA type 3
+#'@param use.interact Numeric, whether to consider interaction in two-way repeated ANOVA (1) or not (0).
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+ANOVA2.Anal <-function(mSetObj=NA, thresh=0.05, p.cor="fdr", type="time0", aov.type=1, use.interact=1){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(type == "time0"){
+ time.fac <- mSetObj$dataSet$time.fac;
+ mSetObj$dataSet$sbj <- as.factor(mSetObj$dataSet$exp.fac);
+
+ if(.on.public.web){
+ .set.mSet(mSetObj);
+ }
+
+ # first create the subjects that being measured under different time
+ # points (under same phenotype/ exp. condition). The design must be balanced
+
+ # first check if balanced
+ res <- table (time.fac, mSetObj$dataSet$sbj);
+ res.mean <- apply(res, 2, mean);
+ all.res <- res/res.mean;
+ if(sum(all.res != 1) > 0){
+ AddErrMsg("Experiment design is not balanced!");
+ return(0);
+ }
+ aov.sbj <<- mSetObj$dataSet$sbj
+ aov.mat<-t(apply(as.matrix(mSetObj$dataSet$norm), 2, aov.repeated, time.fac));
+
+ rm(aov.sbj, pos=".GlobalEnv")
+
+ fileName <- "oneway_anova_repeated.csv";
+ rownames(aov.mat)<-colnames(mSetObj$dataSet$norm);
+ aov.mat <- cbind(aov.mat, p.adjust(aov.mat[,2], p.cor));
+ colnames(aov.mat) <- c("F-value", "Raw P-val", "Adjusted P-val");
+ p.value <- aov.mat[,3];
+ inx.imp <-aov.mat[,3] <= thresh;
+ aov.mat <- aov.mat[inx.imp, ,drop=F];
+ vennC <- NULL;
+ # default sort first by main effect: treatment, then by ...
+ ord.inx <- order(aov.mat[,2], decreasing = FALSE);
+ }else{
+ if(type=="time"){
+ # first create the subjects that being measured under different time
+ # points (under same phenotype/ exp. condition). The design must be balanced
+
+ # first check if balanced
+ res <- table(mSetObj$dataSet$facA, mSetObj$dataSet$facB);
+ res.mean <- apply(res, 2, mean);
+ all.res <- res/res.mean;
+ if(sum(all.res != 1) > 0){
+ AddErrMsg("Experiment design is not balanced!");
+ return(0);
+ }
+ time.fac <- mSetObj$dataSet$time.fac;
+ exp.fac <- mSetObj$dataSet$exp.fac;
+
+ sbj <- vector(mode="character", length=nrow(mSetObj$dataSet$norm));
+ k = 1;
+ len = 0;
+ for(lv1 in levels(exp.fac)){
+ # same subjects must in the same exp. condition
+ inx1 <- exp.fac == lv1;
+ for(lv2 in levels(time.fac)){
+ inx2 <- time.fac == lv2;
+ len <- sum(inx1 & inx2);
+
+ # same subjects must not in the same time points
+ # so in a balanced design and ordered by the time points
+ # all samples in each time points will sweep all subjects (one go)
+ sbj[inx1 & inx2] <- paste("S", k:(k+len-1), sep="");
+ }
+ k = k + len;
+ }
+
+ mSetObj$dataSet$sbj <- as.factor(sbj);
+
+ if(.on.public.web){
+ .set.mSet(mSetObj);
+ }
+
+ aov.facA <<- mSetObj$dataSet$facA;
+ aov.facB <<- mSetObj$dataSet$facB;
+ aov.sbj <<- mSetObj$dataSet$sbj;
+
+ if(use.interact){
+ aov.mat<-t(apply(as.matrix(mSetObj$dataSet$norm), 2, aov.within, time.fac));
+ }else{
+ aov.mat<-t(apply(as.matrix(mSetObj$dataSet$norm), 2, aov.within.wo, time.fac));
+ }
+
+ rm(aov.facA, aov.facB, aov.sbj, pos=".GlobalEnv");
+ fileName <- "anova_within_sbj.csv";
+
+ }else{ # g2 (two-factor analysis)
+ aov.facA <<- mSetObj$dataSet$facA;
+ aov.facB <<- mSetObj$dataSet$facB;
+
+ if(aov.type == 1){
+ aov.mat<-t(apply(as.matrix(mSetObj$dataSet$norm), 2, aov.between));
+ }else{
+ aov.mat<-t(apply(as.matrix(mSetObj$dataSet$norm), 2, aov.between.type3));
+ }
+ rm(aov.facA, aov.facB, pos=".GlobalEnv");
+
+ fileName <- "anova_between_sbj.csv";
+ }
+
+ rownames(aov.mat) <- colnames(mSetObj$dataSet$norm);
+
+ if(use.interact){
+
+ aov.mat2 <- cbind (aov.mat, p.adjust(aov.mat[,4], p.cor),
+ p.adjust(aov.mat[,5], p.cor),
+ p.adjust(aov.mat[,6], p.cor));
+
+ sig.facA <-(aov.mat2[,7] <= thresh);
+ sig.facB <-(aov.mat2[,8] <= thresh);
+ sig.intr <-(aov.mat2[,9] <= thresh);
+
+ all.match <- cbind(sig.facA, sig.facB, sig.intr);
+ colnames(all.match) <- c(mSetObj$dataSet$facA.lbl, mSetObj$dataSet$facB.lbl, "Interaction");
+ colnames(aov.mat2) <- c(paste(mSetObj$dataSet$facA.lbl, "(F.val)", sep = ""),
+ paste(mSetObj$dataSet$facB.lbl, "(F.val)", sep = ""),
+ paste("Interaction", "(F.val)", sep = ""),
+ paste(mSetObj$dataSet$facA.lbl, "(raw.p)", sep = ""),
+ paste(mSetObj$dataSet$facB.lbl, "(raw.p)", sep = ""),
+ paste("Interaction", "(raw.p)", sep = ""),
+ paste(mSetObj$dataSet$facA.lbl, "(adj.p)", sep = ""),
+ paste(mSetObj$dataSet$facB.lbl, "(adj.p)", sep = ""),
+ paste("Interaction", "(adj.p)", sep = ""))
+
+ vennC <- getVennCounts(all.match);
+ p.value <- aov.mat2[,7];
+ inx.imp <- sig.facA | sig.facB | sig.intr;
+ aov.mat2 <- aov.mat2[, c(1,4,7,2,5,8,3,6,9),drop=F]
+
+ }else{
+ aov.mat2 <- cbind(aov.mat, p.adjust(aov.mat[,3], p.cor), p.adjust(aov.mat[,4], p.cor));
+
+ sig.facA <-(aov.mat2[,5] <= thresh);
+ sig.facB <-(aov.mat2[,6] <= thresh);
+
+ all.match <- cbind(sig.facA, sig.facB);
+ colnames(all.match) <- c(mSetObj$dataSet$facA.lbl, mSetObj$dataSet$facB.lbl);
+ colnames(aov.mat2) <- c(paste(mSetObj$dataSet$facA.lbl, "(F.val)", sep = ""),
+ paste(mSetObj$dataSet$facB.lbl, "(F.val)", sep = ""),
+ paste(mSetObj$dataSet$facA.lbl, "(raw.p)", sep = ""),
+ paste(mSetObj$dataSet$facB.lbl, "(raw.p)", sep = ""),
+ paste(mSetObj$dataSet$facA.lbl, "(adj.p)", sep = ""),
+ paste(mSetObj$dataSet$facB.lbl, "(adj.p)", sep = ""))
+
+ vennC <- getVennCounts(all.match);
+ p.value <- aov.mat2[,5];
+ inx.imp <- sig.facA | sig.facB;
+ aov.mat2 <- aov.mat2[, c(1,3,5,2,4,6),drop=F];
+
+ }
+ # default sort first by main effect: treatment, then by ...
+ aov.mat <- aov.mat2[inx.imp, ,drop=F];
+ ord.inx <- order(aov.mat[,2], aov.mat[,3], decreasing = FALSE);
+ }
+
+ aov.mat <- signif(aov.mat[ord.inx,,drop=F], 5);
+ fast.write.csv(aov.mat, file=fileName);
+
+ aov2<-list (
+ type = type,
+ sig.nm = fileName,
+ thresh = -log10(thresh),
+ multi.c = p.cor,
+ sig.mat = aov.mat,
+ p.log = -log10(p.value),
+ inx.imp = inx.imp,
+ vennC = vennC
+ );
+
+ mSetObj$analSet$aov2 <- aov2;
+ return(.set.mSet(mSetObj));
+}
+
+#'Plot Venn diagram of ANOVA results
+#'@description Plot Venn diagram of ANOVA results
+#'@usage PlotANOVA2(mSetObj, imgName, format="png", dpi=72, width=NA)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param imgName Input a name for the plot
+#'@param format Select the image format, "png", or "pdf".
+#'@param dpi Input the dpi. If the image format is "pdf", users need not define the dpi. For "png" images,
+#'the default dpi is 72. It is suggested that for high-resolution images, select a dpi of 300.
+#'@param width Input the width, there are 2 default widths, the first, width = NULL, is 10.5.
+#'The second default is width = 0, where the width is 7.2. Otherwise users can input their own width.
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'
+PlotANOVA2 <- function(mSetObj=NA, imgName, format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ imgName = paste(imgName, "dpi", dpi, ".", format, sep="");
+ if(is.na(width)){
+ w <- 7;
+ }else if(width == 0){
+ w <- 7;
+ }else{
+ w <- width;
+ }
+
+ mSetObj$imgSet$anova2 <- imgName;
+
+ if(mSetObj$dataSet$design.type == "time0"){
+ w <- 9;
+ h <- w*6/9;
+ lod <- mSetObj$analSet$aov2$p.log;
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ plot(lod, ylab="-log10(p)", xlab = "Index", main="One-way repeated measures ANOVA", type="n");
+ red.inx<- which(mSetObj$analSet$aov2$inx.imp);
+ blue.inx <- which(!mSetObj$analSet$aov2$inx.imp);
+ points(red.inx, lod[red.inx], bg="red", cex=1.2, pch=21);
+ points(blue.inx, lod[blue.inx], bg="green", pch=21);
+ abline (h=mSetObj$analSet$aov2$thresh, lty=3);
+ dev.off();
+ }else{
+ h <- w;
+ title <- ifelse(mSetObj$analSet$aov2$type == "g2", "Two-way ANOVA (between subjects)", "Two-way ANOVA (within subject)");
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+ plotVennDiagram(mSetObj$analSet$aov2$vennC, circle.col=c("red", "blue", "green"), mar=c(0,0,2,0));
+ mtext(title, NORTH<-3, line=0.25, cex=1.5);
+ dev.off();
+ }
+
+ return(.set.mSet(mSetObj));
+
+}
+
+#'Perform PCA analysis, prepare file for interactive liveGraphics3D
+#'@description Perform PCA analysis, prepares a JSON file for interactive liveGraphics3D, as well as interactive 3D
+#'PCA score and loading plots using the plotly R package. These plots are saved in the created mSetObj; to view these,
+#'type "mSetObj$imgSet$time$score3d" to view the interactive score plot, and "mSetObj$imgSet$time$load3d" to view
+#'the interactive loading plot.
+#'@usage iPCA.Anal(mSetObj, fileNm)
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@param fileNm select a file name
+#'@author Jeff Xia \email{jeff.xia@mcgill.ca}
+#'McGill University, Canada
+#'License: GNU GPL (>= 2)
+#'@export
+#'@importFrom plotly plot_ly add_markers layout
+#'
+iPCA.Anal<-function(mSetObj=NA, fileNm){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ pca <- prcomp(mSetObj$dataSet$norm, center=T, scale=F);
+ imp.pca <- summary(pca)$importance;
+
+ pca3d <- list();
+ pca3d$score$axis <- paste("PC", 1:3, " (", 100*round(imp.pca[2,][1:3], 3), "%)", sep="");
+ coords <- data.frame(t(signif(pca$x[,1:3], 5)));
+ colnames(coords) <- NULL;
+ pca3d$score$xyz <- coords;
+ pca3d$score$name <- rownames(mSetObj$dataSet$norm);
+ facA <- as.character(mSetObj$dataSet$facA);
+
+ if(all.numeric(facA)){
+ facA <- paste("Group", facA);
+ }
+
+ pca3d$score$facA <- facA;
+ facB <- as.character(mSetObj$dataSet$facB);
+
+ if(all.numeric(facB)){
+ facB <- paste("Group", facB);
+ }
+
+ pca3d$score$facB <- facB;
+
+ pca3d$loadings$axis <- paste("Loadings", 1:3);
+ coords <- data.frame(t(signif(pca$rotation[,1:3], 5)));
+ colnames(coords) <- NULL;
+ pca3d$loadings$xyz <- coords;
+ pca3d$loadings$name <- colnames(mSetObj$dataSet$norm);
+
+ # now set color for each group
+ cols <- unique(GetColorSchema(mSetObj$dataSet$facA)); # this does not matter
+ pca3d$score$colors <- my.col2rgb(cols);
+
+ json.obj <- RJSONIO::toJSON(pca3d, .na='null');
+ sink(fileNm);
+ cat(json.obj);
+ sink();
+
+ if(!.on.public.web){
+
+ uniq.facA <- unique(facA)
+ uniq.facB <- unique(facB)
+
+ if(length(uniq.facA) > 3){
+ col <- RColorBrewer::brewer.pal(length(uniq.pchs), "Set3")
+ }else{
+ col <- c("#1972A4", "#FF7070")
+ }
+
+ s.xlabel <- pca3d$score$axis[1]
+ s.ylabel <- pca3d$score$axis[2]
+ s.zlabel <- pca3d$score$axis[3]
+
+ all.symbols <- c("circle", "cross", "diamond", "x", "square", "circle-open",
+ "square-open", "diamond-open")
+
+ b.symbol <- all.symbols[1:length(uniq.facB)]
+
+ # first, scores plot
+ data.s <- data.frame(cbind(t(pca3d$score$xyz), as.numeric(mSetObj$dataSet$facB)))
+
+ p.s <- plotly::plot_ly(x = data.s[, 1], y = data.s[, 2], z = data.s[, 3],
+ color = mSetObj$dataSet$facA, colors = col)
+ p.s <- plotly::add_markers(p.s, sizes = 5, symbol = data.s[,4], symbols = b.symbol)
+ p.s <- plotly::layout(p.s, scene = list(xaxis = list(title = s.xlabel),
+ yaxis = list(title = s.ylabel),
+ zaxis = list(title = s.zlabel)))
+
+ # second, loadings plot
+ l.xlabel <- pca3d$loadings$axis[1]
+ l.ylabel <- pca3d$loadings$axis[2]
+ l.zlabel <- pca3d$loadings$axis[3]
+
+ data.l <- data.frame(cbind(t(pca3d$loadings$xyz)))
+
+ p.l <- plotly::plot_ly(x = data.l[, 1], y = data.l[, 2], z = data.l[, 3], colors = col[1])
+ p.l <- plotly::add_markers(p.l, sizes = 5)
+ p.l <- plotly::layout(p.l, scene = list(xaxis = list(title = l.xlabel),
+ yaxis = list(title = l.ylabel),
+ zaxis = list(title = l.zlabel)))
+
+ mSetObj$imgSet$time$score3d <- p.s
+ mSetObj$imgSet$time$load3d <- p.l
+ }
+
+ if(!.on.public.web){
+ print("Interactive scores and loading plots have been created, please find
+ them in mSet$imgSet$time$score3d and mSet$imgSet$time$load3d.")
+ return(.set.mSet(mSetObj));
+ }
+}
+
+
+#vertically stacked boxplot
+PlotVerticalCmpdSummary<-function(mSetObj=NA, cmpdNm, format="png", dpi=72, width=NA){
+
+ mSetObj <- .get.mSet(mSetObj);
+
+ if(.on.public.web){
+ load_ggplot()
+ load_grid()
+ }
+
+ imgName <- gsub("\\/", "_", cmpdNm);
+ imgName <- paste(imgName, "_summary_dpi", dpi, ".", format, sep="");
+
+ if(is.na(width)){
+ h <- 9;
+ }else{
+ h <- width;
+ }
+
+ if(substring(mSetObj$dataSet$format,4,5)!="ts"){
+
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height= w*5/9, type=format, bg="white");
+ par(mar=c(4,4,2,2), mfrow = c(1,2), oma=c(0,0,2,0));
+
+ # need to consider norm data were edited, different from proc
+ smpl.nms <- rownames(mSetObj$dataSet$norm);
+
+ mns <- by(as.numeric(mSetObj$dataSet$proc[smpl.nms, cmpdNm]), mSetObj$dataSet$cls, mean, na.rm=T);
+ sds <- by(as.numeric(mSetObj$dataSet$proc[smpl.nms, cmpdNm]), mSetObj$dataSet$cls, sd, na.rm=T);
+
+ ups <- mns + sds;
+ dns <- mns - sds;
+
+ # all concentration need start from 0
+ y <- c(0, dns, mns, ups);
+
+ rg <- range(y) + 0.05 * diff(range(y)) * c(-1, 1)
+ pt <- pretty(y)
+
+ axp=c(min(pt), max(pt[pt <= max(rg)]),length(pt[pt <= max(rg)]) - 1);
+
+ my.col <- unique(GetColorSchema(mSetObj$dataSet$cls));
+
+ x <- barplot(mns, col= my.col, las=2, yaxp=axp, ylim=range(pt));
+ arrows(x, dns, x, ups, code=3, angle=90, length=.1);
+ axis(1, at=x, col="white", col.tick="black", labels=F);
+ box();
+ mtext("Original Conc.", line=1);
+
+ boxplot(mSetObj$dataSet$norm[, cmpdNm]~mSetObj$dataSet$cls,las=2, col= my.col);
+ mtext("Normalized Conc.", line=1);
+ title(main=cmpdNm, out=T);
+ dev.off();
+
+ }else if(mSetObj$dataSet$design.type =="time0"){
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=8, height= 6, type=format, bg="white");
+ plotProfile(mSetObj, cmpdNm);
+ dev.off();
+
+ }else{
+ if(mSetObj$dataSet$design.type =="time"){ # time trend within phenotype
+ out.fac <- mSetObj$dataSet$exp.fac;
+ in.fac <- mSetObj$dataSet$time.fac;
+ xlab = "Time";
+ }else{ # factor a split within factor b
+ out.fac <- mSetObj$dataSet$facB;
+ in.fac <- mSetObj$dataSet$facA;
+ xlab = mSetObj$dataSet$facA.lbl;
+ }
+
+ # two images per row
+ img.num <- length(levels(out.fac));
+ row.num <- ceiling(img.num/2);
+
+ if(img.num > 2){
+ col.num=2
+ }else{
+ col.num=1
+ }
+
+ if(row.num == 1){
+ w <- h*5/9;
+ }else{
+ w <- h*0.5*row.num;
+ }
+ Cairo::Cairo(file = imgName, unit="in", dpi=dpi, width=w, height=h, type=format, bg="white");
+
+ groupNum <- length(levels(in.fac))
+ pal12 = c("#A6CEE3", "#1F78B4", "#B2DF8A", "#33A02C",
+ "#FB9A99", "#E31A1C", "#FDBF6F", "#FF7F00",
+ "#CAB2D6", "#6A3D9A", "#FFFF99", "#B15928");
+ col.fun <- grDevices::colorRampPalette(pal12)
+ group_colors <- col.fun(groupNum)
+
+ p_all <- list()
+
+ for(lv in levels(out.fac)){
+ inx <- out.fac == lv;
+ df.orig <- data.frame(facA = lv, value = mSetObj$dataSet$norm[inx, cmpdNm], name = in.fac[inx])
+ p_all[[lv]] <- df.orig
+ }
+
+ alldata <- do.call(rbind, p_all)
+
+ p.time <- ggplot2::ggplot(alldata, aes(x=name, y=value, fill=name)) + geom_boxplot(outlier.shape = NA) + theme_bw() + geom_jitter(size=1)
+ p.time <- p.time + facet_wrap(~facA, ncol=col.num) + theme(axis.title.x = element_blank(), legend.position = "none")
+ p.time <- p.time + scale_fill_manual(values=group_colors) + theme(axis.text.x = element_text(angle=90, hjust=1))
+ p.time <- p.time + ggtitle(cmpdNm) + theme(plot.title = element_text(size = 11, hjust=0.5, face = "bold")) + ylab("Abundance")
+ p.time <- p.time + theme(panel.grid.minor = element_blank(), panel.grid.major = element_blank()) # remove gridlines
+ p.time <- p.time + theme(plot.margin = margin(t=0.15, r=0.25, b=0.15, l=0.25, "cm"), axis.text = element_text(size=10))
+
+ print(p.time)
+ dev.off()
+ }
+ return(imgName);
+}
+
+# Plot Venn diagram
+# Capabilities for multiple counts and colors by Francois Pepin
+# Gordon Smyth, James Wettenhall
+# 4 July 2003. Last modified 12 March 2010
+
+plotVennDiagram <- function(object, include="both", names, mar=rep(0,4), cex=1.2, lwd=1, circle.col, counts.col, show.include,...){
+ if (!is(object, "VennCounts")){
+ if (length(include)>2) stop("Cannot plot Venn diagram for more than 2 sets of counts")
+ if (length(include)==2) object.2 <- getVennCounts(object, include = include[2])
+ object <- getVennCounts(object, include = include[1])
+ }
+ else if(length(include==2)) include <- include[1]
+ nsets <- ncol(object)-1
+ if(nsets > 3) stop("Can't plot Venn diagram for more than 3 sets")
+ if(missing(names)) names <- colnames(object)[1:nsets]
+ counts <- object[,"Counts"]
+ if(length(include)==2) counts.2 <- object.2[, "Counts"]
+ if(missing(circle.col)) circle.col <- par('col')
+ if(length(circle.col)<nsets) circle.col <- rep(circle.col,length.out=nsets)
+ if(missing(counts.col)) counts.col <- par('col')
+ if(length(counts.col)<length(include)) counts.col <- rep(counts.col,length.out=length(include))
+ if(missing(show.include)) show.include <- as.logical(length(include)-1)
+ theta <- 2*pi*(0:360)/360
+ xcentres <- list(0,c(-1,1),c(-1,1,0))[[nsets]]
+ ycentres <- list(0,c(0,0),c(1/sqrt(3),1/sqrt(3),-2/sqrt(3)))[[nsets]]
+ r <- c(1.5,1.5,1.5)[nsets]
+ xtext <- list(-1.2,c(-1.2,1.2),c(-1.2,1.2,0))[[nsets]]
+ ytext <- list(1.8,c(1.8,1.8),c(2.4,2.4,-3))[[nsets]]
+ old.par <- par(mar=mar)
+ on.exit(par(old.par))
+ plot(x=0,y=0,type="n",xlim=c(-4,4),ylim=c(-4,4),xlab="",ylab="",axes=FALSE,...);
+
+ circle.col <- col2rgb(circle.col) / 255
+ circle.col <- rgb(circle.col[1,], circle.col[2,], circle.col[3,], 0.3)
+ for(i in 1:nsets) {
+ lines(xcentres[i]+r*cos(theta),ycentres[i]+r*sin(theta),lwd=lwd,col=circle.col[i])
+ polygon(xcentres[i] + r*cos(theta), ycentres[i] + r*sin(theta), col = circle.col[i], border = NULL)
+ text(xtext[i],ytext[i],names[i],cex=cex)
+ }
+ switch(nsets,
+ {
+ rect(-3,-2.5,3,2.5)
+ printing <- function(counts, cex, adj,col,leg){
+ text(2.3,-2.1,counts[1],cex=cex,col=col,adj=adj)
+ text(0,0,counts[2],cex=cex,col=col,adj=adj)
+ if(show.include) text(-2.3,-2.1,leg,cex=cex,col=col,adj=adj)
+ }
+
+ }, {
+ rect(-3,-2.5,3,2.5)
+ printing <- function(counts, cex, adj,col,leg){
+ text(2.3,-2.1,counts[1],cex=cex,col=col,adj=adj)
+ text(1.5,0.1,counts[2],cex=cex,col=col,adj=adj)
+ text(-1.5,0.1,counts[3],cex=cex,col=col,adj=adj)
+ text(0,0.1,counts[4],cex=cex,col=col,adj=adj)
+ if(show.include) text(-2.3,-2.1,leg,cex=cex,col=col,adj=adj)
+ }
+ }, {
+ rect(-3,-3.5,3,3.3)
+ printing <- function(counts, cex, adj,col,leg){
+ text(2.5,-3,counts[1],cex=cex,col=col,adj=adj)
+ text(0,-1.7,counts[2],cex=cex,col=col,adj=adj)
+ text(1.5,1,counts[3],cex=cex,col=col,adj=adj)
+ text(.75,-.35,counts[4],cex=cex,col=col,adj=adj)
+ text(-1.5,1,counts[5],cex=cex,col=col,adj=adj)
+ text(-.75,-.35,counts[6],cex=cex,col=col,adj=adj)
+ text(0,.9,counts[7],cex=cex,col=col,adj=adj)
+ text(0,0,counts[8],cex=cex,col=col,adj=adj)
+ if(show.include) text(-2.5,-3,leg,cex=cex,col=col,adj=adj)
+ }
+ }
+ )
+ adj <- c(0.5,0.5)
+ if (length(include)==2)
+ adj <- c(0.5,0)
+ printing(counts,cex,adj,counts.col[1],include[1])
+ if (length(include)==2) printing(counts.2,cex,c(0.5,1),counts.col[2],include[2])
+ invisible()
+}
+
+##############################################
+##############################################
+########## Utilities for web-server ##########
+##############################################
+##############################################
+
+GetAov2SigFileName <-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ mSetObj$analSet$aov2$sig.nm;
+}
+
+GetAov2SigMat<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ return(CleanNumber(as.matrix(mSetObj$analSet$aov2$sig.mat)));
+}
+
+GetAov2SigRowNames<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ rownames(mSetObj$analSet$aov2$sig.mat);
+}
+
+GetAov2SigColNames<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ colnames(mSetObj$analSet$aov2$sig.mat);
+}
+
+#'Sig table for AOV2
+#'@param mSetObj Input the name of the created mSetObj (see InitDataObjects)
+#'@export
+GetSigTable.Aov2<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ GetSigTable(mSetObj$analSet$aov2$sig.mat, "Significant features identified by advanced ANOVA", mSetObj$dataSet$type);
+}
+
+GetAnova2UpMat<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ lod <- mSetObj$analSet$aov2$p.log;
+ red.inx<- which(mSetObj$analSet$aov2$inx.imp);
+ as.matrix(cbind(red.inx, lod[red.inx]));
+}
+
+GetAnova2DnMat<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ lod <- mSetObj$analSet$aov$p.log;
+ blue.inx <- which(!mSetObj$analSet$aov2$inx.imp);
+ as.matrix(cbind(blue.inx, lod[blue.inx]));
+}
+
+GetAnova2LnMat<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ lod <- mSetObj$analSet$aov2$p.log;
+ as.matrix(rbind(c(0, mSetObj$analSet$aov2$thresh), c(length(lod)+1,mSetObj$analSet$aov2$thresh)));
+}
+
+GetAnova2Cmpds<-function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ names(mSetObj$analSet$aov2$p.log);
+}
+
+GetMaxAnova2Inx <- function(mSetObj=NA){
+ mSetObj <- .get.mSet(mSetObj);
+ which.max(mSetObj$analSet$aov2$p.log);
+}
diff --git a/V2.1/ODA/ODA.R b/archived/V2.1/ODA/ODA.R
similarity index 100%
rename from V2.1/ODA/ODA.R
rename to archived/V2.1/ODA/ODA.R
diff --git a/V2.1/ODA/constants.R b/archived/V2.1/ODA/constants.R
similarity index 100%
rename from V2.1/ODA/constants.R
rename to archived/V2.1/ODA/constants.R
diff --git a/V2.1/ODA/getData.R b/archived/V2.1/ODA/getData.R
similarity index 100%
rename from V2.1/ODA/getData.R
rename to archived/V2.1/ODA/getData.R
diff --git a/V2.1/ODA/getSettings.R b/archived/V2.1/ODA/getSettings.R
similarity index 100%
rename from V2.1/ODA/getSettings.R
rename to archived/V2.1/ODA/getSettings.R
diff --git a/V2.1/ODA/libraries.R b/archived/V2.1/ODA/libraries.R
similarity index 100%
rename from V2.1/ODA/libraries.R
rename to archived/V2.1/ODA/libraries.R
diff --git a/V2.1/ODA/odaObject.R b/archived/V2.1/ODA/odaObject.R
similarity index 100%
rename from V2.1/ODA/odaObject.R
rename to archived/V2.1/ODA/odaObject.R
diff --git a/V2.1/ODA/statTests.R b/archived/V2.1/ODA/statTests.R
similarity index 100%
rename from V2.1/ODA/statTests.R
rename to archived/V2.1/ODA/statTests.R
diff --git a/V2.1/ODA/transformData.R b/archived/V2.1/ODA/transformData.R
similarity index 100%
rename from V2.1/ODA/transformData.R
rename to archived/V2.1/ODA/transformData.R
diff --git a/V2.1/ODA/workBook.R b/archived/V2.1/ODA/workBook.R
similarity index 100%
rename from V2.1/ODA/workBook.R
rename to archived/V2.1/ODA/workBook.R
diff --git a/V2.1/data_template_V2.1.xlsx b/archived/V2.1/data_template_V2.1.xlsx
similarity index 100%
rename from V2.1/data_template_V2.1.xlsx
rename to archived/V2.1/data_template_V2.1.xlsx
diff --git a/V2.1/oda_analysis.sh b/archived/V2.1/oda_analysis.sh
similarity index 100%
rename from V2.1/oda_analysis.sh
rename to archived/V2.1/oda_analysis.sh
diff --git a/V2.1/r_w_packages_4.3.2.sif b/archived/V2.1/r_w_packages_4.3.2.sif
similarity index 100%
rename from V2.1/r_w_packages_4.3.2.sif
rename to archived/V2.1/r_w_packages_4.3.2.sif
diff --git a/V2.1/run_analysis.sh b/archived/V2.1/run_analysis.sh
similarity index 100%
rename from V2.1/run_analysis.sh
rename to archived/V2.1/run_analysis.sh
diff --git a/test/data_template_V2.2.xlsx b/test/data_template_V2.2.xlsx
new file mode 100755
index 0000000000000000000000000000000000000000..e1ae4e2b9b000917e7db75d3d5825ee9019b501b
Binary files /dev/null and b/test/data_template_V2.2.xlsx differ
diff --git a/test/test/EnrichmentAnalysis/kegg_clusterprofiler-ora/clusterProfiler_ora.csv b/test/test/EnrichmentAnalysis/kegg_clusterprofiler-ora/clusterProfiler_ora.csv
new file mode 100644
index 0000000000000000000000000000000000000000..8a3f5368fbd6b09452cae8488f813cdd54bc4832
--- /dev/null
+++ b/test/test/EnrichmentAnalysis/kegg_clusterprofiler-ora/clusterProfiler_ora.csv
@@ -0,0 +1,160 @@
+"category","subcategory","ID","Description","GeneRatio","BgRatio","pvalue","p.adjust","qvalue","geneID","Count","richFactor"
+"Organismal Systems","Aging","hsa04213","Longevity regulating pathway - multiple species","23/23","62/8850",2.63658653690747e-52,4.19217259368288e-50,2.77535424937629e-51,"INS/INSR/IGF1/IGF1R/IRS1/IRS2/IRS4/HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3/ADCY1/ADCY2/ADCY3",23,142.741935483871
+"Organismal Systems","Aging","hsa04211","Longevity regulating pathway","23/23","90/8850",6.96173569087274e-48,5.53457987424383e-46,3.66407141624881e-47,"INS/INSR/IGF1/IGF1R/IRS1/IRS2/IRS4/HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3/ADCY1/ADCY2/ADCY3",23,98.3333333333333
+"Organismal Systems","Endocrine system","hsa04923","Regulation of lipolysis in adipocytes","18/23","59/8850",1.25178080484189e-36,6.63443826566201e-35,4.39221335032242e-36,"INS/INSR/IRS1/IRS2/IRS4/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3/ADCY1/ADCY2/ADCY3",18,117.391304347826
+"Organismal Systems","Endocrine system","hsa04935","Growth hormone synthesis, secretion and action","20/23","122/8850",2.0695858391271e-35,8.22660371053021e-34,5.44627852401867e-35,"IGF1/IRS1/IRS2/IRS4/HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3/ADCY1/ADCY2/ADCY3",20,63.0791161796151
+"Environmental Information Processing","Signal transduction","hsa04068","FoxO signaling pathway","20/23","133/8850",1.33831556389324e-34,4.2558434931805e-33,2.81750645030156e-34,"INS/INSR/IGF1/IGF1R/IRS1/IRS2/IRS4/HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",20,57.8620464203988
+"Human Diseases","Drug resistance: antineoplastic","hsa01522","Endocrine resistance","18/23","99/8850",4.75712816552715e-32,1.26063896386469e-30,8.34583888688974e-32,"IGF1/IGF1R/HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3/ADCY1/ADCY2/ADCY3",18,69.9604743083004
+"Environmental Information Processing","Signal transduction","hsa04015","Rap1 signaling pathway","20/23","212/8850",2.60852186122457e-30,5.92507108478152e-29,3.92258926499935e-30,"INS/INSR/IGF1/IGF1R/HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3/ADCY1/ADCY2/ADCY3",20,36.3002461033634
+"Organismal Systems","Endocrine system","hsa04910","Insulin signaling pathway","18/23","138/8850",2.99187423213789e-29,5.94635003637406e-28,3.93667662123407e-29,"INS/INSR/IRS1/IRS2/IRS4/HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",18,50.1890359168242
+"Environmental Information Processing","Signal transduction","hsa04072","Phospholipase D signaling pathway","18/23","149/8850",1.29303546427764e-28,2.05592638820145e-27,1.36108996239752e-28,"INS/INSR/HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3/ADCY1/ADCY2/ADCY3",18,46.4838050773271
+"Organismal Systems","Endocrine system","hsa04914","Progesterone-mediated oocyte maturation","17/23","111/8850",1.24816904306502e-28,2.05592638820145e-27,1.36108996239752e-28,"INS/IGF1/IGF1R/KRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3/ADCY1/ADCY2/ADCY3",17,58.930669800235
+"Environmental Information Processing","Signal transduction","hsa04150","mTOR signaling pathway","18/23","158/8850",3.93980328850346e-28,5.6948065715641e-27,3.77014668756312e-28,"INS/INSR/IGF1/IGF1R/IRS1/HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",18,43.8359933957072
+"Environmental Information Processing","Signal transduction","hsa04152","AMPK signaling pathway","17/23","122/8850",6.98014666539495e-28,9.24869433164831e-27,6.12293567139908e-28,"INS/INSR/IGF1/IGF1R/IRS1/IRS2/IRS4/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",17,53.6172487526728
+"Cellular Processes","Transport and catabolism","hsa04140","Autophagy - animal","18/23","169/8850",1.40768415387812e-27,1.72170600358939e-26,1.13982522581224e-27,"INS/IGF1R/IRS1/IRS2/IRS4/HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",18,40.9827630563417
+"Human Diseases","Cancer: specific types","hsa05215","Prostate cancer","16/23","98/8850",3.27268575358795e-27,3.71683596300345e-26,2.46066598014131e-27,"INS/IGF1/IGF1R/HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",16,62.8216503992901
+"Human Diseases","Cancer: specific types","hsa05218","Melanoma","15/23","73/8850",5.61271083520777e-27,5.94947348532024e-26,3.93874444575984e-27,"IGF1/IGF1R/HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",15,79.064919594997
+"Human Diseases","Cancer: specific types","hsa05214","Glioma","15/23","76/8850",1.0935354953303e-26,1.08670089848449e-25,7.19431246927829e-27,"IGF1/IGF1R/HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",15,75.9439359267735
+"Human Diseases","Drug resistance: antineoplastic","hsa01521","EGFR tyrosine kinase inhibitor resistance","15/23","80/8850",2.5458032240335e-26,2.38107478012545e-25,1.57634874553158e-26,"IGF1/IGF1R/HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",15,72.1467391304348
+"Organismal Systems","Nervous system","hsa04725","Cholinergic synapse","16/23","115/8850",5.10667467211287e-26,4.51089596036637e-25,2.98635945737595e-26,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3/ADCY1/ADCY2/ADCY3",16,53.5349716446125
+"Organismal Systems","Endocrine system","hsa04926","Relaxin signaling pathway","16/23","130/8850",4.095800438072e-25,3.42753826133394e-24,2.2691415169374e-25,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3/ADCY1/ADCY2/ADCY3",16,47.3578595317726
+"Organismal Systems","Endocrine system","hsa04917","Prolactin signaling pathway","14/23","71/8850",9.07596967881882e-25,7.21539589466096e-24,4.77682614674675e-25,"INS/HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",14,75.8726270667483
+"Organismal Systems","Endocrine system","hsa04915","Estrogen signaling pathway","16/23","139/8850",1.26669756562703e-24,9.59071013974751e-24,6.34936123121318e-25,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3/ADCY1/ADCY2/ADCY3",16,44.2915233030967
+"Organismal Systems","Excretory system","hsa04960","Aldosterone-regulated sodium reabsorption","12/23","38/8850",7.42724772572446e-24,5.36787449268268e-23,3.55370704580118e-24,"INS/INSR/IGF1/IRS1/KRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3",12,121.510297482838
+"Human Diseases","Cancer: specific types","hsa05213","Endometrial cancer","13/23","59/8850",1.35650517393636e-23,9.37757924590787e-23,6.20826166561263e-24,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",13,84.7826086956522
+"Environmental Information Processing","Signal transduction","hsa04370","VEGF signaling pathway","13/23","60/8850",1.7298806690945e-23,1.14604594327511e-22,7.58719591708116e-24,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",13,83.3695652173913
+"Organismal Systems","Endocrine system","hsa04929","GnRH secretion","13/23","65/8850",5.46885625898834e-23,3.47819258071658e-22,2.30267631957404e-23,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",13,76.9565217391304
+"Environmental Information Processing","Signal transduction","hsa04014","Ras signaling pathway","17/23","238/8850",9.95670451186378e-23,6.08890775917823e-22,4.03105445824444e-23,"INS/INSR/IGF1/IGF1R/HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",17,27.4844720496894
+"Human Diseases","Cancer: specific types","hsa05221","Acute myeloid leukemia","13/23","68/8850",1.04139326869389e-22,6.13264924897511e-22,4.06001274344595e-23,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",13,73.5613810741688
+"Organismal Systems","Immune system","hsa04664","Fc epsilon RI signaling pathway","13/23","69/8850",1.28178950857425e-22,7.27873328083235e-22,4.81875755103102e-23,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",13,72.4952741020794
+"Human Diseases","Endocrine and metabolic disease","hsa04930","Type II diabetes mellitus","12/23","47/8850",1.41858353873812e-22,7.77775112618485e-22,5.14912355258845e-23,"INS/INSR/IRS1/IRS2/IRS4/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3",12,98.2423681776133
+"Human Diseases","Cancer: specific types","hsa05211","Renal cell carcinoma","13/23","70/8850",1.57246407902712e-22,8.33405961884372e-22,5.51741782114778e-23,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",13,71.4596273291925
+"Human Diseases","Cancer: overview","hsa05230","Central carbon metabolism in cancer","13/23","71/8850",1.92287865526037e-22,9.86250665117415e-22,6.52929933874489e-23,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",13,70.4531537048377
+"Human Diseases","Cancer: specific types","hsa05223","Non-small cell lung cancer","13/23","73/8850",2.84895385268055e-22,1.41557394555065e-21,9.37155872592286e-23,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",13,68.5229303156641
+"Organismal Systems","Immune system","hsa04062","Chemokine signaling pathway","16/23","193/8850",3.00411988259759e-22,1.44743957979702e-21,9.5825195617148e-23,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3/ADCY1/ADCY2/ADCY3",16,31.8990763685515
+"Cellular Processes","Cellular community - eukaryotes","hsa04550","Signaling pathways regulating pluripotency of stem cells","15/23","144/8850",3.09849680324844e-22,1.44900291681324e-21,9.59286935990229e-23,"IGF1/IGF1R/HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",15,40.0815217391304
+"Human Diseases","Cancer: specific types","hsa05224","Breast cancer","15/23","148/8850",4.7568044009551e-22,2.16094828500532e-21,1.4306178649489e-22,"IGF1/IGF1R/HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",15,38.9982373678026
+"Environmental Information Processing","Signal transduction","hsa04066","HIF-1 signaling pathway","14/23","109/8850",5.82882217568551e-22,2.50481817819999e-21,1.65827088924197e-22,"INS/INSR/IGF1/IGF1R/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",14,49.4216194654966
+"Human Diseases","Endocrine and metabolic disease","hsa04931","Insulin resistance","14/23","109/8850",5.82882217568551e-22,2.50481817819999e-21,1.65827088924197e-22,"INS/INSR/IRS1/IRS2/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",14,49.4216194654966
+"Human Diseases","Cancer: specific types","hsa05220","Chronic myeloid leukemia","13/23","77/8850",6.04230988408129e-22,2.52822966202349e-21,1.67377005099205e-22,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",13,64.9632975719932
+"Human Diseases","Cancer: overview","hsa05207","Chemical carcinogenesis - receptor activation","16/23","215/8850",1.77690879703639e-21,7.24432048022529e-21,4.79597516069202e-22,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3/ADCY1/ADCY2/ADCY3",16,28.6349848331648
+"Environmental Information Processing","Signal transduction","hsa04151","PI3K-Akt signaling pathway","18/23","362/8850",1.89684659475501e-21,7.53996521415117e-21,4.99170156514477e-22,"INS/INSR/IGF1/IGF1R/IRS1/HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",18,19.1328368964689
+"Organismal Systems","Nervous system","hsa04722","Neurotrophin signaling pathway","14/23","120/8850",2.40806253336035e-21,9.33858397083647e-21,6.18244552852464e-22,"IRS1/HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",14,44.8913043478261
+"Environmental Information Processing","Signal transduction","hsa04012","ErbB signaling pathway","13/23","86/8850",2.83497337441457e-21,1.07323992031409e-20,7.10519642710419e-22,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",13,58.164812942366
+"Human Diseases","Infectious disease: viral","hsa05166","Human T-cell leukemia virus 1 infection","16/23","223/8850",3.23600338427891e-21,1.19656869325662e-20,7.92167291133148e-22,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3/ADCY1/ADCY2/ADCY3",16,27.6077208032755
+"Human Diseases","Cancer: specific types","hsa05210","Colorectal cancer","13/23","87/8850",3.32948119301319e-21,1.20315343111159e-20,7.96526601199328e-22,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",13,57.496251874063
+"Human Diseases","Infectious disease: viral","hsa05163","Human cytomegalovirus infection","16/23","226/8850",4.02833374810046e-21,1.4233445909955e-20,9.42300291953325e-22,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3/ADCY1/ADCY2/ADCY3",16,27.2412466333205
+"Human Diseases","Cancer: overview","hsa05235","PD-L1 expression and PD-1 checkpoint pathway in cancer","13/23","90/8850",5.33023112839433e-21,1.84240597698847e-20,1.21973252366003e-21,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",13,55.5797101449275
+"Organismal Systems","Immune system","hsa04662","B cell receptor signaling pathway","13/23","91/8850",6.21201783466991e-21,2.10151241640961e-20,1.39126939186336e-21,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",13,54.9689440993789
+"Human Diseases","Neurodegenerative disease","hsa05010","Alzheimer disease","18/23","391/8850",7.71770581448185e-21,2.55649005104711e-20,1.69247934528111e-21,"INS/INSR/IRS1/IRS2/IRS4/HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",18,17.7137773824085
+"Human Diseases","Cancer: overview","hsa05231","Choline metabolism in cancer","13/23","99/8850",1.98740186540443e-20,6.44891625712866e-20,4.26939176241553e-21,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",13,50.5270092226614
+"Human Diseases","Endocrine and metabolic disease","hsa04933","AGE-RAGE signaling pathway in diabetic complications","13/23","101/8850",2.61627857723847e-20,8.31976587561835e-20,5.50795489944942e-21,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",13,49.5264743865691
+"Organismal Systems","Immune system","hsa04625","C-type lectin receptor signaling pathway","13/23","105/8850",4.4569669300485e-20,1.38952498407394e-19,9.1991061507709e-21,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",13,47.639751552795
+"Human Diseases","Cancer: overview","hsa05205","Proteoglycans in cancer","15/23","204/8850",6.86298907510204e-20,2.09849089027159e-19,1.38926904354292e-20,"IGF1/IGF1R/HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",15,28.2928388746803
+"Human Diseases","Endocrine and metabolic disease","hsa04932","Non-alcoholic fatty liver disease","14/23","157/8850",1.21175462759112e-19,3.63526388277336e-19,2.40666261686419e-20,"INS/INSR/IRS1/IRS2/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",14,34.3118249792301
+"Environmental Information Processing","Signal transduction","hsa04071","Sphingolipid signaling pathway","13/23","122/8850",3.44344316951045e-19,9.77691899914574e-19,6.47263753667378e-20,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",13,41.0014255167498
+"Organismal Systems","Immune system","hsa04660","T cell receptor signaling pathway","13/23","122/8850",3.44344316951045e-19,9.77691899914574e-19,6.47263753667378e-20,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",13,41.0014255167498
+"Organismal Systems","Endocrine system","hsa04919","Thyroid hormone signaling pathway","13/23","122/8850",3.44344316951045e-19,9.77691899914574e-19,6.47263753667378e-20,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",13,41.0014255167498
+"Human Diseases","Cancer: specific types","hsa05225","Hepatocellular carcinoma","14/23","170/8850",3.81973483516162e-19,1.06550498033456e-18,7.05398861525692e-20,"IGF1R/HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",14,31.6879795396419
+"Organismal Systems","Immune system","hsa04611","Platelet activation","13/23","126/8850",5.33017360375589e-19,1.46120276378825e-18,9.67363630445715e-20,"PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3/ADCY1/ADCY2/ADCY3",13,39.6997929606625
+"Cellular Processes","Cell growth and death","hsa04210","Apoptosis","13/23","136/8850",1.49429083087589e-18,4.02698715439435e-18,2.66599613001943e-19,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",13,36.7806905370844
+"Human Diseases","Cancer: overview","hsa05200","Pathways in cancer","18/23","533/8850",2.09488701826969e-18,5.55145059841469e-18,3.67524038292929e-19,"IGF1/IGF1R/HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3/ADCY1/ADCY2/ADCY3",18,12.9945346276205
+"Human Diseases","Cancer: specific types","hsa05226","Gastric cancer","13/23","150/8850",5.56981688768112e-18,1.45180472973983e-17,9.61141827037294e-19,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",13,33.3478260869565
+"Cellular Processes","Cell growth and death","hsa04218","Cellular senescence","13/23","157/8850",1.02508548761055e-17,2.62884826661414e-17,1.74038283125729e-18,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",13,31.8609803378565
+"Human Diseases","Infectious disease: viral","hsa05160","Hepatitis C","13/23","159/8850",1.21385512292372e-17,3.06353911975986e-17,2.02816227723261e-18,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",13,31.4602132895816
+"Human Diseases","Cancer: specific types","hsa05212","Pancreatic cancer","11/23","77/8850",1.2810402714537e-17,3.18258442439279e-17,2.10697413068043e-18,"KRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",11,54.9689440993789
+"Human Diseases","Infectious disease: viral","hsa05161","Hepatitis B","13/23","163/8850",1.69084978006379e-17,4.13607869277142e-17,2.73821826730978e-18,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",13,30.6881835156042
+"Organismal Systems","Digestive system","hsa04973","Carbohydrate digestion and absorption","10/23","52/8850",2.11713900273848e-17,5.10038032477907e-17,3.37661722924798e-18,"PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",10,73.9966555183946
+"Cellular Processes","Cell motility","hsa04810","Regulation of actin cytoskeleton","14/23","230/8850",2.87255953664852e-17,6.81696964667335e-17,4.513055045795e-18,"INS/HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",14,23.421550094518
+"Human Diseases","Infectious disease: viral","hsa05167","Kaposi sarcoma-associated herpesvirus infection","13/23","196/8850",1.95161124279743e-16,4.56332628830577e-16,3.02107003529015e-17,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",13,25.5212954747116
+"Organismal Systems","Sensory system","hsa04750","Inflammatory mediator regulation of TRP channels","11/23","99/8850",2.35090885205762e-16,5.41731170256757e-16,3.58643608246777e-17,"IGF1/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/ADCY1/ADCY2/ADCY3",11,42.7536231884058
+"Cellular Processes","Cellular community - eukaryotes","hsa04510","Focal adhesion","13/23","203/8850",3.10082426106171e-16,7.04330082155446e-16,4.66289362565671e-17,"IGF1/IGF1R/HRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",13,24.6412508031698
+"Human Diseases","Cardiovascular disease","hsa05415","Diabetic cardiomyopathy","13/23","205/8850",3.52854497896383e-16,7.90195284021478e-16,5.23134911632888e-17,"INS/INSR/IRS1/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",13,24.4008483563096
+"Human Diseases","Infectious disease: parasitic","hsa05142","Chagas disease","11/23","103/8850",3.70127122888222e-16,8.17364063044823e-16,5.41121524690382e-17,"PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3/ADCY1",11,41.0932883073027
+"Human Diseases","Infectious disease: viral","hsa05170","Human immunodeficiency virus 1 infection","13/23","213/8850",5.84077179778685e-16,1.27216810390152e-15,8.42216553393922e-17,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",13,23.4843845682792
+"Human Diseases","Cardiovascular disease","hsa05417","Lipid and atherosclerosis","13/23","216/8850",7.01996376450265e-16,1.50834356561611e-15,9.98572370484018e-17,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",13,23.1582125603865
+"Human Diseases","Drug resistance: antineoplastic","hsa01524","Platinum drug resistance","10/23","75/8850",1.07555327740964e-15,2.28017294810844e-15,1.5095484595223e-16,"PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",10,51.304347826087
+"Environmental Information Processing","Signal transduction","hsa04024","cAMP signaling pathway","13/23","226/8850",1.27173268553272e-15,2.62604541558056e-15,1.73852725294972e-16,"PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3/ADCY1/ADCY2/ADCY3",13,22.1335128895729
+"Human Diseases","Cancer: overview","hsa05208","Chemical carcinogenesis - reactive oxygen species","13/23","226/8850",1.27173268553272e-15,2.62604541558056e-15,1.73852725294972e-16,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",13,22.1335128895729
+"Human Diseases","Cancer: specific types","hsa05222","Small cell lung cancer","10/23","93/8850",1.0232087705732e-14,2.08577172462997e-14,1.38084854328366e-15,"PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",10,41.3744740532959
+"Organismal Systems","Immune system","hsa04666","Fc gamma R-mediated phagocytosis","10/23","98/8850",1.76180641109546e-14,3.5459141691668e-14,2.34751020798862e-15,"PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",10,39.2635314995563
+"Organismal Systems","Immune system","hsa04620","Toll-like receptor signaling pathway","10/23","109/8850",5.28406254519893e-14,1.05020743085829e-13,6.95271387526175e-15,"PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",10,35.301156761069
+"Environmental Information Processing","Signal transduction","hsa04022","cGMP-PKG signaling pathway","11/23","166/8850",8.07309148807019e-14,1.58471795876933e-13,1.04913469630542e-14,"INS/INSR/IRS1/IRS2/IRS4/AKT1/AKT2/AKT3/ADCY1/ADCY2/ADCY3",11,25.4976427448926
+"Environmental Information Processing","Signal transduction","hsa04630","JAK-STAT signaling pathway","11/23","168/8850",9.2245129687143e-14,1.78865556344582e-13,1.18414800625344e-14,"HRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",11,25.194099378882
+"Environmental Information Processing","Signal transduction","hsa04668","TNF signaling pathway","10/23","119/8850",1.3009728557784e-13,2.49222510926224e-13,1.64993386909119e-14,"PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",10,32.3346729996346
+"Human Diseases","Infectious disease: viral","hsa05165","Human papillomavirus infection","13/23","333/8850",1.96009833708109e-13,3.71018613804635e-13,2.45626358030212e-14,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",13,15.0215432824128
+"Organismal Systems","Immune system","hsa04650","Natural killer cell mediated cytotoxicity","10/23","135/8850",4.71233633261595e-13,8.81484090454043e-13,5.83571062862657e-14,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3",10,28.5024154589372
+"Human Diseases","Infectious disease: bacterial","hsa05135","Yersinia infection","10/23","138/8850",5.8915165238592e-13,1.08924549685304e-12,7.21115853593537e-14,"PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",10,27.882797731569
+"Human Diseases","Infectious disease: viral","hsa05162","Measles","10/23","139/8850",6.3396348659287e-13,1.15862292377318e-12,7.67045960789922e-14,"PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",10,27.6822020644354
+"Human Diseases","Cardiovascular disease","hsa05418","Fluid shear stress and atherosclerosis","10/23","141/8850",7.32859448796589e-13,1.32414377680293e-12,8.7662613492415e-14,"PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",10,27.2895467160037
+"Organismal Systems","Development and regeneration","hsa04380","Osteoclast differentiation","10/23","142/8850",7.87312226069476e-13,1.4065465611803e-12,9.31179451294472e-14,"PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",10,27.097366809553
+"Human Diseases","Neurodegenerative disease","hsa05017","Spinocerebellar ataxia","10/23","144/8850",9.07220182140367e-13,1.60275565511465e-12,1.06107623642148e-13,"PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",10,26.7210144927536
+"Human Diseases","Cancer: overview","hsa05206","MicroRNAs in cancer","12/23","312/8850",2.85592033244158e-12,4.99001464679354e-12,3.30355157020426e-13,"IRS1/IRS2/HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3",12,14.7993311036789
+"Human Diseases","Infectious disease: viral","hsa05164","Influenza A","10/23","172/8850",5.44388019391199e-12,9.4084451177392e-12,6.22869587404118e-13,"PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",10,22.37108190091
+"Organismal Systems","Development and regeneration","hsa04360","Axon guidance","10/23","184/8850",1.07005514470087e-11,1.82944911835956e-11,1.21115466293251e-12,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3",10,20.9120982986767
+"Organismal Systems","Immune system","hsa04613","Neutrophil extracellular trap formation","10/23","192/8850",1.6371764100386e-11,2.76926648080997e-11,1.83334424416417e-12,"PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",10,20.0407608695652
+"Human Diseases","Infectious disease: viral","hsa05169","Epstein-Barr virus infection","10/23","203/8850",2.8525923283143e-11,4.77433873896814e-11,3.16076712278593e-12,"PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",10,18.9548083101306
+"Human Diseases","Cancer: overview","hsa05203","Viral carcinogenesis","10/23","205/8850",3.1448815917726e-11,5.15501209373034e-11,3.41278523252588e-12,"HRAS/KRAS/NRAS/PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3",10,18.7698833510074
+"Organismal Systems","Endocrine system","hsa04913","Ovarian steroidogenesis","7/23","51/8850",3.14479287541049e-11,5.15501209373034e-11,3.41278523252588e-12,"INS/INSR/IGF1/IGF1R/ADCY1/ADCY2/ADCY3",7,52.8132992327366
+"Environmental Information Processing","Signal transduction","hsa04371","Apelin signaling pathway","9/23","140/8850",3.24442370169755e-11,5.26391192418276e-11,3.48488045295118e-12,"HRAS/KRAS/NRAS/AKT1/AKT2/AKT3/ADCY1/ADCY2/ADCY3",9,24.7360248447205
+"Human Diseases","Infectious disease: parasitic","hsa05146","Amoebiasis","8/23","103/8850",1.08507599233043e-10,1.74269780586402e-10,1.15372247988349e-11,"PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/ADCY1",8,29.8860278598565
+"Human Diseases","Infectious disease: bacterial","hsa05131","Shigellosis","10/23","249/8850",2.15432358059436e-10,3.42537449314503e-10,2.26770903220459e-11,"PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",10,15.4531168150864
+"Human Diseases","Infectious disease: bacterial","hsa05100","Bacterial invasion of epithelial cells","7/23","78/8850",6.87440074117838e-10,1.08220764143303e-09,7.16456565000352e-11,"PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3",7,34.5317725752508
+"Environmental Information Processing","Signal transduction","hsa04010","MAPK signaling pathway","10/23","300/8850",1.3360505376718e-09,2.08266701460604e-09,1.3787931245323e-10,"INS/INSR/IGF1/IGF1R/HRAS/KRAS/NRAS/AKT1/AKT2/AKT3",10,12.8260869565217
+"Environmental Information Processing","Signal transduction","hsa04070","Phosphatidylinositol signaling system","7/23","98/8850",3.48684935207879e-09,5.38261210660707e-09,3.56346382430127e-10,"PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3",7,27.4844720496894
+"Organismal Systems","Immune system","hsa04670","Leukocyte transendothelial migration","7/23","116/8850",1.14192050964871e-08,1.74582077917446e-08,1.15578998952298e-09,"PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3",7,23.21964017991
+"Organismal Systems","Endocrine system","hsa04920","Adipocytokine signaling pathway","6/23","70/8850",1.78744408090856e-08,2.7067010368044e-08,1.79192389063515e-09,"IRS1/IRS2/IRS4/AKT1/AKT2/AKT3",6,32.9813664596273
+"Cellular Processes","Cellular community - eukaryotes","hsa04540","Gap junction","6/23","92/8850",9.37297741850864e-08,1.4059466127763e-07,9.30782265988941e-09,"HRAS/KRAS/NRAS/ADCY1/ADCY2/ADCY3",6,25.0945179584121
+"Organismal Systems","Endocrine system","hsa04912","GnRH signaling pathway","6/23","93/8850",1.00027905796307e-07,1.48639598332831e-07,9.84042359038931e-09,"HRAS/KRAS/NRAS/ADCY1/ADCY2/ADCY3",6,24.8246844319776
+"Organismal Systems","Endocrine system","hsa04916","Melanogenesis","6/23","101/8850",1.64118321257124e-07,2.41618639628543e-07,1.5995937744359e-08,"HRAS/KRAS/NRAS/ADCY1/ADCY2/ADCY3",6,22.8583727938011
+"Human Diseases","Infectious disease: viral","hsa05168","Herpes simplex virus 1 infection","10/23","522/8850",2.66431419632089e-07,3.88647667169744e-07,2.57297363237169e-08,"PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3/AKT1/AKT2/AKT3",10,7.37131434282859
+"Organismal Systems","Nervous system","hsa04730","Long-term depression","5/23","60/8850",3.7037858631179e-07,5.35365411123405e-07,3.54429269197885e-08,"IGF1/IGF1R/HRAS/KRAS/NRAS",5,32.0652173913044
+"Cellular Processes","Cell growth and death","hsa04114","Oocyte meiosis","6/23","139/8850",1.09172272287032e-06,1.56381903546289e-06,1.03529893112406e-07,"INS/IGF1/IGF1R/ADCY1/ADCY2/ADCY3",6,16.6093212386612
+"Human Diseases","Infectious disease: viral","hsa05171","Coronavirus disease - COVID-19","7/23","238/8850",1.5809086892001e-06,2.244325728418e-06,1.48581643721814e-07,"PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3",7,11.3171355498721
+"Organismal Systems","Circulatory system","hsa04261","Adrenergic signaling in cardiomyocytes","6/23","154/8850",1.99063874149208e-06,2.77641719208106e-06,1.83807824699176e-07,"AKT1/AKT2/AKT3/ADCY1/ADCY2/ADCY3",6,14.9915302089215
+"Organismal Systems","Endocrine system","hsa04921","Oxytocin signaling pathway","6/23","154/8850",1.99063874149208e-06,2.77641719208106e-06,1.83807824699176e-07,"HRAS/KRAS/NRAS/ADCY1/ADCY2/ADCY3",6,14.9915302089215
+"Human Diseases","Infectious disease: bacterial","hsa05132","Salmonella infection","7/23","251/8850",2.25683455939769e-06,3.12031908647158e-06,2.06575245711459e-07,"HRAS/PIK3CA/PIK3CD/PIK3CB/AKT1/AKT2/AKT3",7,10.7309890871297
+"Human Diseases","Neurodegenerative disease","hsa05020","Prion disease","7/23","278/8850",4.45396635447401e-06,6.10500560656352e-06,4.04171175542107e-07,"PIK3CA/PIK3CD/PIK3CB/PIK3R1/PIK3R2/PIK3R3/P3R3URF-PIK3R3",7,9.68877072255239
+"Organismal Systems","Environmental adaptation","hsa04714","Thermogenesis","6/23","235/8850",2.27221008877141e-05,3.0878752488432e-05,2.04427358413982e-06,"HRAS/KRAS/NRAS/ADCY1/ADCY2/ADCY3",6,9.82423681776133
+"Organismal Systems","Nervous system","hsa04720","Long-term potentiation","4/23","67/8850",2.38416723390662e-05,3.21256432365383e-05,2.12682179652687e-06,"HRAS/KRAS/NRAS/ADCY1",4,22.9720960415315
+"Organismal Systems","Endocrine system","hsa04911","Insulin secretion","4/23","86/8850",6.39274242507557e-05,8.54156340829425e-05,5.65479206110179e-06,"INS/ADCY1/ADCY2/ADCY3",4,17.896865520728
+"Human Diseases","Cancer: specific types","hsa05216","Thyroid cancer","3/23","37/8850",0.000112476338075894,0.000149031147950559,9.86634544525384e-06,"HRAS/KRAS/NRAS",3,31.1985898942421
+"Human Diseases","Cardiovascular disease","hsa05414","Dilated cardiomyopathy","4/23","105/8850",0.000139269239872795,0.000183006687105574,1.21156363525703e-05,"IGF1/ADCY1/ADCY2/ADCY3",4,14.6583850931677
+"Organismal Systems","Endocrine system","hsa04922","Glucagon signaling pathway","4/23","107/8850",0.000149834081452876,0.00019527556517219,1.29278758803171e-05,"AKT1/AKT2/AKT3/ADCY2",4,14.3843965867534
+"Human Diseases","Cancer: specific types","hsa05219","Bladder cancer","3/23","41/8850",0.000153268186620029,0.000198127168069793,1.31166612426212e-05,"HRAS/KRAS/NRAS",3,28.1548250265111
+"Organismal Systems","Endocrine system","hsa04927","Cortisol synthesis and secretion","3/23","65/8850",0.000602992537591365,0.000773192044169573,5.11878215272806e-05,"ADCY1/ADCY2/ADCY3",3,17.7591973244147
+"Metabolism","Carbohydrate metabolism","hsa00562","Inositol phosphate metabolism","3/23","73/8850",0.000847043723098275,0.00107743961578101,7.13299977345916e-05,"PIK3CA/PIK3CD/PIK3CB",3,15.8129839189994
+"Organismal Systems","Endocrine system","hsa04918","Thyroid hormone synthesis","3/23","75/8850",0.000916508907625847,0.00115654695486119,7.65671602026605e-05,"ADCY1/ADCY2/ADCY3",3,15.3913043478261
+"Organismal Systems","Digestive system","hsa04971","Gastric acid secretion","3/23","76/8850",0.000952558848732274,0.0011925736767593,7.89522460615229e-05,"ADCY1/ADCY2/ADCY3",3,15.1887871853547
+"Organismal Systems","Nervous system","hsa04727","GABAergic synapse","3/23","89/8850",0.00150527628615612,0.00186983538670955,0.000123789168269417,"ADCY1/ADCY2/ADCY3",3,12.9702002931119
+"Organismal Systems","Digestive system","hsa04976","Bile secretion","3/23","90/8850",0.00155454811979254,0.00191607093834894,0.000126850111774177,"ADCY1/ADCY2/ADCY3",3,12.8260869565217
+"Human Diseases","Substance dependence","hsa05032","Morphine addiction","3/23","91/8850",0.00160482471840504,0.00196282407866462,0.000129945321328343,"ADCY1/ADCY2/ADCY3",3,12.6851409460105
+"Organismal Systems","Environmental adaptation","hsa04713","Circadian entrainment","3/23","97/8850",0.0019280088430462,0.00232237428821474,0.000153748711566683,"ADCY1/ADCY2/ADCY3",3,11.9004930524429
+"Organismal Systems","Digestive system","hsa04970","Salivary secretion","3/23","97/8850",0.0019280088430462,0.00232237428821474,0.000153748711566683,"ADCY1/ADCY2/ADCY3",3,11.9004930524429
+"Organismal Systems","Endocrine system","hsa04925","Aldosterone synthesis and secretion","3/23","98/8850",0.00198552958066269,0.00237367822049149,0.000157145198311254,"ADCY1/ADCY2/ADCY3",3,11.7790594498669
+"Cellular Processes","Transport and catabolism","hsa04137","Mitophagy - animal","3/23","105/8850",0.00241836527711273,0.00286955282881287,0.000189973705979005,"HRAS/KRAS/NRAS",3,10.9937888198758
+"Organismal Systems","Digestive system","hsa04972","Pancreatic secretion","3/23","106/8850",0.00248459489933764,0.00292630065921989,0.000193730596439582,"ADCY1/ADCY2/ADCY3",3,10.890073831009
+"Human Diseases","Infectious disease: parasitic","hsa05145","Toxoplasmosis","3/23","111/8850",0.00283266255668195,0.00331171578317963,0.000219246327916559,"AKT1/AKT2/AKT3",3,10.3995299647474
+"Organismal Systems","Nervous system","hsa04726","Serotonergic synapse","3/23","115/8850",0.00313180495319708,0.00360838396781403,0.00023888672411877,"HRAS/KRAS/NRAS",3,10.0378071833648
+"Organismal Systems","Endocrine system","hsa04928","Parathyroid hormone synthesis, secretion and action","3/23","115/8850",0.00313180495319708,0.00360838396781403,0.00023888672411877,"ADCY1/ADCY2/ADCY3",3,10.0378071833648
+"Organismal Systems","Nervous system","hsa04724","Glutamatergic synapse","3/23","116/8850",0.00320951591483274,0.00367131676588782,0.000243053079502669,"ADCY1/ADCY2/ADCY3",3,9.95127436281859
+"Metabolism","Nucleotide metabolism","hsa00230","Purine metabolism","3/23","128/8850",0.00423592544303579,0.00481080103887636,0.000318490634814721,"ADCY1/ADCY2/ADCY3",3,9.01834239130435
+"Organismal Systems","Nervous system","hsa04728","Dopaminergic synapse","3/23","132/8850",0.00461758776567053,0.00520706705490507,0.000344724730546512,"AKT1/AKT2/AKT3",3,8.74505928853755
+"Organismal Systems","Circulatory system","hsa04270","Vascular smooth muscle contraction","3/23","134/8850",0.00481602075953941,0.00539258662511807,0.000357006727912484,"ADCY1/ADCY2/ADCY3",3,8.6145360155743
+"Human Diseases","Endocrine and metabolic disease","hsa04936","Alcoholic liver disease","3/23","144/8850",0.00588577067224555,0.00654431843976952,0.000433255110213143,"AKT1/AKT2/AKT3",3,8.01630434782609
+"Organismal Systems","Nervous system","hsa04723","Retrograde endocannabinoid signaling","3/23","149/8850",0.00647011443799649,0.00714408469195445,0.000472961581724889,"ADCY1/ADCY2/ADCY3",3,7.74730084622118
+"Human Diseases","Endocrine and metabolic disease","hsa04934","Cushing syndrome","3/23","155/8850",0.00721585091197249,0.0079125537586457,0.00052383672682196,"ADCY1/ADCY2/ADCY3",3,7.44740532959327
+"Human Diseases","Infectious disease: bacterial","hsa05152","Tuberculosis","3/23","180/8850",0.010863100945285,0.0118303633582213,0.000783208431527395,"AKT1/AKT2/AKT3",3,6.41304347826087
+"Human Diseases","Substance dependence","hsa05034","Alcoholism","3/23","188/8850",0.0122195978038376,0.013217115991906,0.000875015954445947,"HRAS/KRAS/NRAS",3,6.14014801110083
+"Cellular Processes","Cellular community - eukaryotes","hsa04520","Adherens junction","2/23","93/8850",0.0239497911093382,0.0257298431512485,0.00170339908316773,"INSR/IGF1R",2,8.27489481065919
+"Environmental Information Processing","Signal transduction","hsa04020","Calcium signaling pathway","3/23","254/8850",0.0270766187455889,0.0288938414801922,0.00191286603642451,"ADCY1/ADCY2/ADCY3",3,4.54467648065731
+"Human Diseases","Endocrine and metabolic disease","hsa04950","Maturity onset diabetes of the young","1/23","26/8850",0.0655100900164132,0.069440695417398,0.00459719929939742,"INS",1,14.7993311036789
+"Human Diseases","Cancer: overview","hsa05202","Transcriptional misregulation in cancer","2/23","193/8850",0.0887778886431108,0.0934813529420836,0.00618876881443784,"IGF1/IGF1R",2,3.98738454606893
+"Human Diseases","Endocrine and metabolic disease","hsa04940","Type I diabetes mellitus","1/23","43/8850",0.106101993818254,0.110988269849358,0.00734778350541926,"INS",1,8.948432760364
+"Organismal Systems","Excretory system","hsa04962","Vasopressin-regulated water reabsorption","1/23","44/8850",0.10843646118991,0.112688871432652,0.00746036884691507,"ADCY3",1,8.74505928853755
+"Human Diseases","Infectious disease: bacterial","hsa05110","Vibrio cholerae infection","1/23","51/8850",0.124615208159568,0.128661156476437,0.00851778593025069,"ADCY3",1,7.54475703324808
+"Human Diseases","Neurodegenerative disease","hsa05022","Pathways of neurodegeneration - multiple diseases","3/23","483/8850",0.127640319280541,0.13093426300391,0.00866827295623372,"HRAS/KRAS/NRAS",3,2.38995409127734
+"Cellular Processes","Transport and catabolism","hsa04144","Endocytosis","2/23","252/8850",0.138383840179529,0.141045067875289,0.00933764103775502,"IGF1R/HRAS",2,3.05383022774327
+"Cellular Processes","Cell growth and death","hsa04115","p53 signaling pathway","1/23","75/8850",0.177980052568715,0.180247314384877,0.0119329569271683,"IGF1",1,5.1304347826087
+"Human Diseases","Cardiovascular disease","hsa05410","Hypertrophic cardiomyopathy","1/23","99/8850",0.228224821566303,0.229669282462292,0.015204851536729,"IGF1",1,3.8866930171278
+"Organismal Systems","Sensory system","hsa04740","Olfactory transduction","1/23","453/8850",0.701812561873405,0.701812561873405,0.0464622682471635,"ADCY3",1,0.849409732219983
diff --git a/test/test/EnrichmentAnalysis/kegg_clusterprofiler-ora/clusterProfiler_ora.pdf b/test/test/EnrichmentAnalysis/kegg_clusterprofiler-ora/clusterProfiler_ora.pdf
new file mode 100644
index 0000000000000000000000000000000000000000..4f0afb936d8b1a0c6e82f2c07fb97e2e04275be4
Binary files /dev/null and b/test/test/EnrichmentAnalysis/kegg_clusterprofiler-ora/clusterProfiler_ora.pdf differ
diff --git a/test/test/EnrichmentAnalysis/kegg_clusterprofiler-ora/clusterProfiler_ora_gene_symbols.csv b/test/test/EnrichmentAnalysis/kegg_clusterprofiler-ora/clusterProfiler_ora_gene_symbols.csv
new file mode 100644
index 0000000000000000000000000000000000000000..03a5fc5c506c70c7fd083a7c1d4de34953bedbd3
--- /dev/null
+++ b/test/test/EnrichmentAnalysis/kegg_clusterprofiler-ora/clusterProfiler_ora_gene_symbols.csv
@@ -0,0 +1,24 @@
+"ENTREZID","SYMBOL"
+"3630","INS"
+"3643","INSR"
+"3479","IGF1"
+"3480","IGF1R"
+"3667","IRS1"
+"8660","IRS2"
+"8471","IRS4"
+"3265","HRAS"
+"3845","KRAS"
+"4893","NRAS"
+"5290","PIK3CA"
+"5293","PIK3CD"
+"5291","PIK3CB"
+"5295","PIK3R1"
+"5296","PIK3R2"
+"8503","PIK3R3"
+"110117499","P3R3URF-PIK3R3"
+"207","AKT1"
+"208","AKT2"
+"10000","AKT3"
+"107","ADCY1"
+"108","ADCY2"
+"109","ADCY3"
diff --git a/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea.csv b/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea.csv
new file mode 100644
index 0000000000000000000000000000000000000000..3bb065c59a6abf474e86a6524317567e3da01e63
--- /dev/null
+++ b/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea.csv
@@ -0,0 +1,149 @@
+"ID","Description","setSize","enrichmentScore","NES","pvalue","p.adjust","qvalue","rank","leading_edge","core_enrichment"
+"hsa01522","Endocrine resistance",18,0.6,1.64064897448305,0.0478180335565426,0.742677091842689,0.742677091842689,20,"tags=100%, list=87%, signal=60%","IGF1R/HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/ADCY3/ADCY2/AKT1/AKT3/ADCY1/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS/IGF1"
+"hsa05200","Pathways in cancer",18,0.6,1.64064897448305,0.0478180335565426,0.742677091842689,0.742677091842689,20,"tags=100%, list=87%, signal=60%","IGF1R/HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/ADCY3/ADCY2/AKT1/AKT3/ADCY1/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS/IGF1"
+"hsa04062","Chemokine signaling pathway",16,0.571428571428571,1.57175831658617,0.0513962537546513,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=57%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/ADCY3/ADCY2/AKT1/AKT3/ADCY1/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa04725","Cholinergic synapse",16,0.571428571428571,1.57175831658617,0.0513962537546513,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=57%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/ADCY3/ADCY2/AKT1/AKT3/ADCY1/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa04915","Estrogen signaling pathway",16,0.571428571428571,1.57175831658617,0.0513962537546513,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=57%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/ADCY3/ADCY2/AKT1/AKT3/ADCY1/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa04926","Relaxin signaling pathway",16,0.571428571428571,1.57175831658617,0.0513962537546513,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=57%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/ADCY3/ADCY2/AKT1/AKT3/ADCY1/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa05163","Human cytomegalovirus infection",16,0.571428571428571,1.57175831658617,0.0513962537546513,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=57%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/ADCY3/ADCY2/AKT1/AKT3/ADCY1/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa05166","Human T-cell leukemia virus 1 infection",16,0.571428571428571,1.57175831658617,0.0513962537546513,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=57%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/ADCY3/ADCY2/AKT1/AKT3/ADCY1/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa05207","Chemical carcinogenesis - receptor activation",16,0.571428571428571,1.57175831658617,0.0513962537546513,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=57%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/ADCY3/ADCY2/AKT1/AKT3/ADCY1/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa04024","cAMP signaling pathway",13,0.5,1.41786348682338,0.0767341381558954,0.742677091842689,0.742677091842689,18,"tags=100%, list=78%, signal=50%","PIK3CB/PIK3CA/PIK3R1/AKT2/PIK3R3/ADCY3/ADCY2/AKT1/AKT3/ADCY1/PIK3R2/P3R3URF-PIK3R3/PIK3CD"
+"hsa04611","Platelet activation",13,0.5,1.41786348682338,0.0767341381558954,0.742677091842689,0.742677091842689,18,"tags=100%, list=78%, signal=50%","PIK3CB/PIK3CA/PIK3R1/AKT2/PIK3R3/ADCY3/ADCY2/AKT1/AKT3/ADCY1/PIK3R2/P3R3URF-PIK3R3/PIK3CD"
+"hsa04722","Neurotrophin signaling pathway",14,0.492614367138802,1.38028756400168,0.0980114052452408,0.742677091842689,0.742677091842689,9,"tags=57%, list=39%, signal=89%","IRS1/HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3"
+"hsa05225","Hepatocellular carcinoma",14,0.48817526330717,1.36784935630242,0.103720633063128,0.742677091842689,0.742677091842689,9,"tags=57%, list=39%, signal=89%","IGF1R/HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3"
+"hsa04261","Adrenergic signaling in cardiomyocytes",6,0.529411764705882,1.20843176168402,0.242105263157895,0.742677091842689,0.742677091842689,14,"tags=100%, list=61%, signal=53%","AKT2/ADCY3/ADCY2/AKT1/AKT3/ADCY1"
+"hsa04935","Growth hormone synthesis, secretion and action",20,0.473687376130102,1.1837775902448,0.150537634408602,0.742677091842689,0.742677091842689,20,"tags=95%, list=87%, signal=95%","IRS1/HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/ADCY3/ADCY2/AKT1/AKT3/ADCY1/PIK3R2/P3R3URF-PIK3R3/IRS4/PIK3CD/NRAS/IGF1"
+"hsa04630","JAK-STAT signaling pathway",11,0.416666666666667,1.16443570768426,0.269230769230769,0.742677091842689,0.742677091842689,18,"tags=100%, list=78%, signal=42%","HRAS/PIK3CB/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD"
+"hsa05142","Chagas disease",11,0.416666666666667,1.16443570768426,0.269230769230769,0.742677091842689,0.742677091842689,18,"tags=100%, list=78%, signal=42%","PIK3CB/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/ADCY1/PIK3R2/P3R3URF-PIK3R3/PIK3CD"
+"hsa05212","Pancreatic cancer",11,0.416666666666667,1.16443570768426,0.269230769230769,0.742677091842689,0.742677091842689,18,"tags=100%, list=78%, signal=42%","PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD"
+"hsa04012","ErbB signaling pathway",13,0.4,1.13429078945871,0.283870967741935,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=40%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa04071","Sphingolipid signaling pathway",13,0.4,1.13429078945871,0.283870967741935,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=40%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa04210","Apoptosis",13,0.4,1.13429078945871,0.283870967741935,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=40%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa04218","Cellular senescence",13,0.4,1.13429078945871,0.283870967741935,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=40%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa04370","VEGF signaling pathway",13,0.4,1.13429078945871,0.283870967741935,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=40%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa04625","C-type lectin receptor signaling pathway",13,0.4,1.13429078945871,0.283870967741935,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=40%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa04660","T cell receptor signaling pathway",13,0.4,1.13429078945871,0.283870967741935,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=40%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa04662","B cell receptor signaling pathway",13,0.4,1.13429078945871,0.283870967741935,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=40%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa04664","Fc epsilon RI signaling pathway",13,0.4,1.13429078945871,0.283870967741935,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=40%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa04919","Thyroid hormone signaling pathway",13,0.4,1.13429078945871,0.283870967741935,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=40%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa04929","GnRH secretion",13,0.4,1.13429078945871,0.283870967741935,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=40%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa04933","AGE-RAGE signaling pathway in diabetic complications",13,0.4,1.13429078945871,0.283870967741935,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=40%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa05160","Hepatitis C",13,0.4,1.13429078945871,0.283870967741935,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=40%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa05161","Hepatitis B",13,0.4,1.13429078945871,0.283870967741935,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=40%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa05165","Human papillomavirus infection",13,0.4,1.13429078945871,0.283870967741935,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=40%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa05167","Kaposi sarcoma-associated herpesvirus infection",13,0.4,1.13429078945871,0.283870967741935,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=40%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa05170","Human immunodeficiency virus 1 infection",13,0.4,1.13429078945871,0.283870967741935,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=40%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa05208","Chemical carcinogenesis - reactive oxygen species",13,0.4,1.13429078945871,0.283870967741935,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=40%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa05210","Colorectal cancer",13,0.4,1.13429078945871,0.283870967741935,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=40%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa05211","Renal cell carcinoma",13,0.4,1.13429078945871,0.283870967741935,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=40%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa05213","Endometrial cancer",13,0.4,1.13429078945871,0.283870967741935,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=40%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa05220","Chronic myeloid leukemia",13,0.4,1.13429078945871,0.283870967741935,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=40%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa05221","Acute myeloid leukemia",13,0.4,1.13429078945871,0.283870967741935,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=40%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa05223","Non-small cell lung cancer",13,0.4,1.13429078945871,0.283870967741935,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=40%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa05226","Gastric cancer",13,0.4,1.13429078945871,0.283870967741935,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=40%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa05230","Central carbon metabolism in cancer",13,0.4,1.13429078945871,0.283870967741935,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=40%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa05231","Choline metabolism in cancer",13,0.4,1.13429078945871,0.283870967741935,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=40%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa05235","PD-L1 expression and PD-1 checkpoint pathway in cancer",13,0.4,1.13429078945871,0.283870967741935,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=40%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa05417","Lipid and atherosclerosis",13,0.4,1.13429078945871,0.283870967741935,0.742677091842689,0.742677091842689,19,"tags=100%, list=83%, signal=40%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS"
+"hsa04140","Autophagy - animal",18,0.411763993449043,1.12593362263536,0.265822784810127,0.742677091842689,0.742677091842689,9,"tags=50%, list=39%, signal=140%","IRS1/IGF1R/HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3"
+"hsa05132","Salmonella infection",7,0.443284669708045,1.0693058553078,0.350194552529183,0.742677091842689,0.742677091842689,8,"tags=57%, list=35%, signal=54%","HRAS/PIK3CB/PIK3CA/AKT2"
+"hsa01521","EGFR tyrosine kinase inhibitor resistance",15,0.378329424397707,1.06495564455484,0.326797385620915,0.742677091842689,0.742677091842689,9,"tags=53%, list=39%, signal=93%","IGF1R/HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3"
+"hsa04550","Signaling pathways regulating pluripotency of stem cells",15,0.378329424397707,1.06495564455484,0.326797385620915,0.742677091842689,0.742677091842689,9,"tags=53%, list=39%, signal=93%","IGF1R/HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3"
+"hsa05205","Proteoglycans in cancer",15,0.378329424397707,1.06495564455484,0.326797385620915,0.742677091842689,0.742677091842689,9,"tags=53%, list=39%, signal=93%","IGF1R/HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3"
+"hsa05214","Glioma",15,0.378329424397707,1.06495564455484,0.326797385620915,0.742677091842689,0.742677091842689,9,"tags=53%, list=39%, signal=93%","IGF1R/HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3"
+"hsa05218","Melanoma",15,0.378329424397707,1.06495564455484,0.326797385620915,0.742677091842689,0.742677091842689,9,"tags=53%, list=39%, signal=93%","IGF1R/HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3"
+"hsa05224","Breast cancer",15,0.378329424397707,1.06495564455484,0.326797385620915,0.742677091842689,0.742677091842689,9,"tags=53%, list=39%, signal=93%","IGF1R/HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3"
+"hsa04150","mTOR signaling pathway",18,0.383536575492461,1.04874814876408,0.512658227848101,0.872108249672632,0.872108249672632,9,"tags=50%, list=39%, signal=140%","IRS1/IGF1R/HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3"
+"hsa04151","PI3K-Akt signaling pathway",18,0.383536575492461,1.04874814876408,0.512658227848101,0.872108249672632,0.872108249672632,9,"tags=50%, list=39%, signal=140%","IRS1/IGF1R/HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3"
+"hsa04922","Glucagon signaling pathway",4,0.526315789473684,1.03562711673072,0.425714285714286,0.759104991394148,0.759104991394148,13,"tags=100%, list=57%, signal=53%","AKT2/ADCY2/AKT1/AKT3"
+"hsa01524","Platinum drug resistance",10,0.384615384615385,1.01860767830438,0.411483253588517,0.742677091842689,0.742677091842689,18,"tags=100%, list=78%, signal=38%","PIK3CB/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD"
+"hsa04380","Osteoclast differentiation",10,0.384615384615385,1.01860767830438,0.411483253588517,0.742677091842689,0.742677091842689,18,"tags=100%, list=78%, signal=38%","PIK3CB/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD"
+"hsa04613","Neutrophil extracellular trap formation",10,0.384615384615385,1.01860767830438,0.411483253588517,0.742677091842689,0.742677091842689,18,"tags=100%, list=78%, signal=38%","PIK3CB/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD"
+"hsa04620","Toll-like receptor signaling pathway",10,0.384615384615385,1.01860767830438,0.411483253588517,0.742677091842689,0.742677091842689,18,"tags=100%, list=78%, signal=38%","PIK3CB/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD"
+"hsa04666","Fc gamma R-mediated phagocytosis",10,0.384615384615385,1.01860767830438,0.411483253588517,0.742677091842689,0.742677091842689,18,"tags=100%, list=78%, signal=38%","PIK3CB/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD"
+"hsa04668","TNF signaling pathway",10,0.384615384615385,1.01860767830438,0.411483253588517,0.742677091842689,0.742677091842689,18,"tags=100%, list=78%, signal=38%","PIK3CB/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD"
+"hsa04973","Carbohydrate digestion and absorption",10,0.384615384615385,1.01860767830438,0.411483253588517,0.742677091842689,0.742677091842689,18,"tags=100%, list=78%, signal=38%","PIK3CB/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD"
+"hsa05017","Spinocerebellar ataxia",10,0.384615384615385,1.01860767830438,0.411483253588517,0.742677091842689,0.742677091842689,18,"tags=100%, list=78%, signal=38%","PIK3CB/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD"
+"hsa05131","Shigellosis",10,0.384615384615385,1.01860767830438,0.411483253588517,0.742677091842689,0.742677091842689,18,"tags=100%, list=78%, signal=38%","PIK3CB/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD"
+"hsa05135","Yersinia infection",10,0.384615384615385,1.01860767830438,0.411483253588517,0.742677091842689,0.742677091842689,18,"tags=100%, list=78%, signal=38%","PIK3CB/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD"
+"hsa05162","Measles",10,0.384615384615385,1.01860767830438,0.411483253588517,0.742677091842689,0.742677091842689,18,"tags=100%, list=78%, signal=38%","PIK3CB/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD"
+"hsa05164","Influenza A",10,0.384615384615385,1.01860767830438,0.411483253588517,0.742677091842689,0.742677091842689,18,"tags=100%, list=78%, signal=38%","PIK3CB/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD"
+"hsa05168","Herpes simplex virus 1 infection",10,0.384615384615385,1.01860767830438,0.411483253588517,0.742677091842689,0.742677091842689,18,"tags=100%, list=78%, signal=38%","PIK3CB/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD"
+"hsa05169","Epstein-Barr virus infection",10,0.384615384615385,1.01860767830438,0.411483253588517,0.742677091842689,0.742677091842689,18,"tags=100%, list=78%, signal=38%","PIK3CB/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD"
+"hsa05222","Small cell lung cancer",10,0.384615384615385,1.01860767830438,0.411483253588517,0.742677091842689,0.742677091842689,18,"tags=100%, list=78%, signal=38%","PIK3CB/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD"
+"hsa05418","Fluid shear stress and atherosclerosis",10,0.384615384615385,1.01860767830438,0.411483253588517,0.742677091842689,0.742677091842689,18,"tags=100%, list=78%, signal=38%","PIK3CB/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD"
+"hsa04510","Focal adhesion",13,0.352693482971079,1.00014242309051,0.445161290322581,0.784331797235023,0.784331797235023,9,"tags=54%, list=39%, signal=75%","IGF1R/HRAS/PIK3CB/PIK3CA/PIK3R1/AKT2/PIK3R3"
+"hsa04360","Axon guidance",10,0.345098586241194,0.913952181264892,0.545454545454545,0.879192236335094,0.879192236335093,7,"tags=50%, list=30%, signal=62%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1"
+"hsa04650","Natural killer cell mediated cytotoxicity",10,0.345098586241194,0.913952181264892,0.545454545454545,0.879192236335094,0.879192236335093,7,"tags=50%, list=30%, signal=62%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1"
+"hsa05203","Viral carcinogenesis",10,0.345098586241194,0.913952181264892,0.545454545454545,0.879192236335094,0.879192236335093,7,"tags=50%, list=30%, signal=62%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1"
+"hsa05206","MicroRNAs in cancer",12,0.331865083690304,0.909551744401949,0.585365853658537,0.879192236335094,0.879192236335093,7,"tags=50%, list=30%, signal=73%","IRS1/HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1"
+"hsa04914","Progesterone-mediated oocyte maturation",17,0.333333333333333,0.883251608231098,0.651006711409396,0.879192236335094,0.879192236335093,21,"tags=100%, list=91%, signal=33%","IGF1R/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/ADCY3/ADCY2/AKT1/AKT3/ADCY1/PIK3R2/P3R3URF-PIK3R3/PIK3CD/IGF1/INS"
+"hsa04728","Dopaminergic synapse",3,0.5,0.876507092206475,0.660714285714286,0.879192236335094,0.879192236335093,13,"tags=100%, list=57%, signal=50%","AKT2/AKT1/AKT3"
+"hsa04936","Alcoholic liver disease",3,0.5,0.876507092206475,0.660714285714286,0.879192236335094,0.879192236335093,13,"tags=100%, list=57%, signal=50%","AKT2/AKT1/AKT3"
+"hsa05145","Toxoplasmosis",3,0.5,0.876507092206475,0.660714285714286,0.879192236335094,0.879192236335093,13,"tags=100%, list=57%, signal=50%","AKT2/AKT1/AKT3"
+"hsa05152","Tuberculosis",3,0.5,0.876507092206475,0.660714285714286,0.879192236335094,0.879192236335093,13,"tags=100%, list=57%, signal=50%","AKT2/AKT1/AKT3"
+"hsa05146","Amoebiasis",8,0.333333333333333,0.80985940268377,0.648401826484018,0.879192236335094,0.879192236335093,18,"tags=100%, list=78%, signal=33%","PIK3CB/PIK3CA/PIK3R1/PIK3R3/ADCY1/PIK3R2/P3R3URF-PIK3R3/PIK3CD"
+"hsa05215","Prostate cancer",16,0.285714285714286,0.785879158293083,0.768707482993197,0.879192236335094,0.879192236335093,21,"tags=100%, list=91%, signal=29%","IGF1R/HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS/IGF1/INS"
+"hsa04070","Phosphatidylinositol signaling system",7,0.3125,0.753822774885877,0.793774319066148,0.879192236335094,0.879192236335093,18,"tags=100%, list=78%, signal=31%","PIK3CB/PIK3CA/PIK3R1/PIK3R3/PIK3R2/P3R3URF-PIK3R3/PIK3CD"
+"hsa04670","Leukocyte transendothelial migration",7,0.3125,0.753822774885877,0.793774319066148,0.879192236335094,0.879192236335093,18,"tags=100%, list=78%, signal=31%","PIK3CB/PIK3CA/PIK3R1/PIK3R3/PIK3R2/P3R3URF-PIK3R3/PIK3CD"
+"hsa05020","Prion disease",7,0.3125,0.753822774885877,0.793774319066148,0.879192236335094,0.879192236335093,18,"tags=100%, list=78%, signal=31%","PIK3CB/PIK3CA/PIK3R1/PIK3R3/PIK3R2/P3R3URF-PIK3R3/PIK3CD"
+"hsa05100","Bacterial invasion of epithelial cells",7,0.3125,0.753822774885877,0.793774319066148,0.879192236335094,0.879192236335093,18,"tags=100%, list=78%, signal=31%","PIK3CB/PIK3CA/PIK3R1/PIK3R3/PIK3R2/P3R3URF-PIK3R3/PIK3CD"
+"hsa05171","Coronavirus disease - COVID-19",7,0.3125,0.753822774885877,0.793774319066148,0.879192236335094,0.879192236335093,18,"tags=100%, list=78%, signal=31%","PIK3CB/PIK3CA/PIK3R1/PIK3R3/PIK3R2/P3R3URF-PIK3R3/PIK3CD"
+"hsa04371","Apelin signaling pathway",9,0.285714285714286,0.743854819502118,0.80952380952381,0.879192236335094,0.879192236335093,19,"tags=100%, list=83%, signal=29%","HRAS/KRAS/AKT2/ADCY3/ADCY2/AKT1/AKT3/ADCY1/NRAS"
+"hsa04540","Gap junction",6,0.308286457138605,0.703692610061846,0.831578947368421,0.879192236335094,0.879192236335093,5,"tags=33%, list=22%, signal=35%","HRAS/KRAS"
+"hsa04714","Thermogenesis",6,0.308286457138605,0.703692610061846,0.831578947368421,0.879192236335094,0.879192236335093,5,"tags=33%, list=22%, signal=35%","HRAS/KRAS"
+"hsa04912","GnRH signaling pathway",6,0.308286457138605,0.703692610061846,0.831578947368421,0.879192236335094,0.879192236335093,5,"tags=33%, list=22%, signal=35%","HRAS/KRAS"
+"hsa04916","Melanogenesis",6,0.308286457138605,0.703692610061846,0.831578947368421,0.879192236335094,0.879192236335093,5,"tags=33%, list=22%, signal=35%","HRAS/KRAS"
+"hsa04921","Oxytocin signaling pathway",6,0.308286457138605,0.703692610061846,0.831578947368421,0.879192236335094,0.879192236335093,5,"tags=33%, list=22%, signal=35%","HRAS/KRAS"
+"hsa00562","Inositol phosphate metabolism",3,0.401268373624661,0.703429150720346,0.793367346938776,0.879192236335094,0.879192236335093,6,"tags=67%, list=26%, signal=57%","PIK3CB/PIK3CA"
+"hsa01100","Metabolic pathways",6,0.301095610476212,0.68727883145029,0.835087719298246,0.879192236335094,0.879192236335093,6,"tags=33%, list=26%, signal=33%","PIK3CB/PIK3CA"
+"hsa04720","Long-term potentiation",4,0.340841861824327,0.67067164178229,0.822857142857143,0.879192236335094,0.879192236335093,5,"tags=50%, list=22%, signal=47%","HRAS/KRAS"
+"hsa04137","Mitophagy - animal",3,0.380023337399842,0.666186300869872,0.849489795918367,0.879192236335094,0.879192236335093,5,"tags=67%, list=22%, signal=60%","HRAS/KRAS"
+"hsa04726","Serotonergic synapse",3,0.380023337399842,0.666186300869872,0.849489795918367,0.879192236335094,0.879192236335093,5,"tags=67%, list=22%, signal=60%","HRAS/KRAS"
+"hsa05022","Pathways of neurodegeneration - multiple diseases",3,0.380023337399842,0.666186300869872,0.849489795918367,0.879192236335094,0.879192236335093,5,"tags=67%, list=22%, signal=60%","HRAS/KRAS"
+"hsa05034","Alcoholism",3,0.380023337399842,0.666186300869872,0.849489795918367,0.879192236335094,0.879192236335093,5,"tags=67%, list=22%, signal=60%","HRAS/KRAS"
+"hsa05216","Thyroid cancer",3,0.380023337399842,0.666186300869872,0.849489795918367,0.879192236335094,0.879192236335093,5,"tags=67%, list=22%, signal=60%","HRAS/KRAS"
+"hsa05219","Bladder cancer",3,0.380023337399842,0.666186300869872,0.849489795918367,0.879192236335094,0.879192236335093,5,"tags=67%, list=22%, signal=60%","HRAS/KRAS"
+"hsa04750","Inflammatory mediator regulation of TRP channels",11,0,0,1,1,1,21,"tags=45%, list=91%, signal=8%","ADCY1/PIK3R2/P3R3URF-PIK3R3/PIK3CD/IGF1"
+"hsa04810","Regulation of actin cytoskeleton",14,0,0,1,1,1,21,"tags=100%, list=91%, signal=22%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS/INS"
+"hsa04917","Prolactin signaling pathway",14,0,0,1,1,1,21,"tags=100%, list=91%, signal=22%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/AKT1/AKT3/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS/INS"
+"hsa04015","Rap1 signaling pathway",20,-0.333333333333333,-0.582833783107074,0.951100244498778,0.970778180591856,0.970778180591856,23,"tags=100%, list=100%, signal=0%","HRAS/PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/ADCY3/ADCY2/AKT1/AKT3/ADCY1/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS/IGF1/INS/INSR"
+"hsa04730","Long-term depression",5,-0.373386460258302,-0.653779349704974,0.888252148997135,0.912925819802611,0.912925819802611,6,"tags=40%, list=26%, signal=38%","NRAS/IGF1"
+"hsa00230","Purine metabolism",3,-0.45,-0.712661940327639,0.827697262479871,0.879192236335094,0.879192236335093,15,"tags=100%, list=65%, signal=40%","ADCY2/ADCY1"
+"hsa04020","Calcium signaling pathway",3,-0.45,-0.712661940327639,0.827697262479871,0.879192236335094,0.879192236335093,15,"tags=100%, list=65%, signal=40%","ADCY2/ADCY1"
+"hsa04270","Vascular smooth muscle contraction",3,-0.45,-0.712661940327639,0.827697262479871,0.879192236335094,0.879192236335093,15,"tags=100%, list=65%, signal=40%","ADCY2/ADCY1"
+"hsa04713","Circadian entrainment",3,-0.45,-0.712661940327639,0.827697262479871,0.879192236335094,0.879192236335093,15,"tags=100%, list=65%, signal=40%","ADCY2/ADCY1"
+"hsa04723","Retrograde endocannabinoid signaling",3,-0.45,-0.712661940327639,0.827697262479871,0.879192236335094,0.879192236335093,15,"tags=100%, list=65%, signal=40%","ADCY2/ADCY1"
+"hsa04724","Glutamatergic synapse",3,-0.45,-0.712661940327639,0.827697262479871,0.879192236335094,0.879192236335093,15,"tags=100%, list=65%, signal=40%","ADCY2/ADCY1"
+"hsa04727","GABAergic synapse",3,-0.45,-0.712661940327639,0.827697262479871,0.879192236335094,0.879192236335093,15,"tags=100%, list=65%, signal=40%","ADCY2/ADCY1"
+"hsa04918","Thyroid hormone synthesis",3,-0.45,-0.712661940327639,0.827697262479871,0.879192236335094,0.879192236335093,15,"tags=100%, list=65%, signal=40%","ADCY2/ADCY1"
+"hsa04925","Aldosterone synthesis and secretion",3,-0.45,-0.712661940327639,0.827697262479871,0.879192236335094,0.879192236335093,15,"tags=100%, list=65%, signal=40%","ADCY2/ADCY1"
+"hsa04927","Cortisol synthesis and secretion",3,-0.45,-0.712661940327639,0.827697262479871,0.879192236335094,0.879192236335093,15,"tags=100%, list=65%, signal=40%","ADCY2/ADCY1"
+"hsa04928","Parathyroid hormone synthesis, secretion and action",3,-0.45,-0.712661940327639,0.827697262479871,0.879192236335094,0.879192236335093,15,"tags=100%, list=65%, signal=40%","ADCY2/ADCY1"
+"hsa04934","Cushing syndrome",3,-0.45,-0.712661940327639,0.827697262479871,0.879192236335094,0.879192236335093,15,"tags=100%, list=65%, signal=40%","ADCY2/ADCY1"
+"hsa04970","Salivary secretion",3,-0.45,-0.712661940327639,0.827697262479871,0.879192236335094,0.879192236335093,15,"tags=100%, list=65%, signal=40%","ADCY2/ADCY1"
+"hsa04971","Gastric acid secretion",3,-0.45,-0.712661940327639,0.827697262479871,0.879192236335094,0.879192236335093,15,"tags=100%, list=65%, signal=40%","ADCY2/ADCY1"
+"hsa04972","Pancreatic secretion",3,-0.45,-0.712661940327639,0.827697262479871,0.879192236335094,0.879192236335093,15,"tags=100%, list=65%, signal=40%","ADCY2/ADCY1"
+"hsa04976","Bile secretion",3,-0.45,-0.712661940327639,0.827697262479871,0.879192236335094,0.879192236335093,15,"tags=100%, list=65%, signal=40%","ADCY2/ADCY1"
+"hsa05032","Morphine addiction",3,-0.45,-0.712661940327639,0.827697262479871,0.879192236335094,0.879192236335093,15,"tags=100%, list=65%, signal=40%","ADCY2/ADCY1"
+"hsa05415","Diabetic cardiomyopathy",13,-0.36851557862052,-0.751271934228598,0.775943396226415,0.879192236335094,0.879192236335093,4,"tags=38%, list=17%, signal=73%","PIK3R2/P3R3URF-PIK3R3/PIK3CD/INS/INSR"
+"hsa04072","Phospholipase D signaling pathway",18,-0.4,-0.765009972363562,0.782505910165485,0.879192236335094,0.879192236335093,22,"tags=100%, list=96%, signal=20%","PIK3CB/KRAS/PIK3CA/PIK3R1/AKT2/PIK3R3/ADCY3/ADCY2/AKT1/AKT3/ADCY1/PIK3R2/P3R3URF-PIK3R3/PIK3CD/NRAS/INS/INSR"
+"hsa04920","Adipocytokine signaling pathway",6,-0.453943615806308,-0.816466853213489,0.751724137931034,0.879192236335094,0.879192236335093,3,"tags=67%, list=13%, signal=78%","AKT1/AKT3/IRS4/IRS2"
+"hsa04014","Ras signaling pathway",17,-0.42472818755586,-0.839531652541834,0.679953106682298,0.879192236335094,0.879192236335093,7,"tags=29%, list=30%, signal=78%","PIK3CD/NRAS/IGF1/INS/INSR"
+"hsa04066","HIF-1 signaling pathway",14,-0.433013338705977,-0.8789167069069,0.668639053254438,0.879192236335094,0.879192236335093,5,"tags=29%, list=22%, signal=57%","PIK3CD/IGF1/INS/INSR"
+"hsa04960","Aldosterone-regulated sodium reabsorption",12,-0.449199412609864,-0.912022623687707,0.600238663484487,0.879192236335094,0.879192236335093,5,"tags=50%, list=22%, signal=82%","PIK3R2/P3R3URF-PIK3R3/PIK3CD/IGF1/INS/INSR"
+"hsa04910","Insulin signaling pathway",18,-0.479202084490116,-0.916485933530862,0.609929078014184,0.879192236335094,0.879192236335093,10,"tags=44%, list=43%, signal=116%","PIK3R2/P3R3URF-PIK3R3/IRS4/PIK3CD/NRAS/INS/IRS2/INSR"
+"hsa05010","Alzheimer disease",18,-0.479202084490116,-0.916485933530862,0.609929078014184,0.879192236335094,0.879192236335093,10,"tags=44%, list=43%, signal=116%","PIK3R2/P3R3URF-PIK3R3/IRS4/PIK3CD/NRAS/INS/IRS2/INSR"
+"hsa04923","Regulation of lipolysis in adipocytes",18,-0.53244709254595,-1.01831833888409,0.459810874704492,0.800611875956056,0.800611875956056,4,"tags=89%, list=17%, signal=338%","PIK3CA/PIK3R1/AKT2/PIK3R3/ADCY3/ADCY2/AKT1/AKT3/ADCY1/PIK3R2/P3R3URF-PIK3R3/IRS4/PIK3CD/INS/IRS2/INSR"
+"hsa04152","AMPK signaling pathway",17,-0.555543378160449,-1.09810524469694,0.369284876905041,0.742677091842689,0.742677091842689,5,"tags=47%, list=22%, signal=141%","PIK3R2/P3R3URF-PIK3R3/IRS4/PIK3CD/IGF1/INS/IRS2/INSR"
+"hsa04114","Oocyte meiosis",6,-0.61512474542316,-1.10636860557521,0.353103448275862,0.742677091842689,0.742677091842689,5,"tags=50%, list=22%, signal=53%","ADCY1/IGF1/INS"
+"hsa05414","Dilated cardiomyopathy",4,-0.693116594034729,-1.15034734785662,0.329803328290469,0.742677091842689,0.742677091842689,5,"tags=100%, list=22%, signal=95%","ADCY2/ADCY1/IGF1"
+"hsa04931","Insulin resistance",14,-0.577982954423147,-1.17317142346706,0.271005917159763,0.742677091842689,0.742677091842689,4,"tags=21%, list=17%, signal=45%","INS/IRS2/INSR"
+"hsa04932","Non-alcoholic fatty liver disease",14,-0.577982954423147,-1.17317142346706,0.271005917159763,0.742677091842689,0.742677091842689,4,"tags=21%, list=17%, signal=45%","INS/IRS2/INSR"
+"hsa04930","Type II diabetes mellitus",12,-0.578206978683157,-1.17395043477306,0.263723150357995,0.742677091842689,0.742677091842689,10,"tags=58%, list=43%, signal=69%","PIK3R2/P3R3URF-PIK3R3/IRS4/PIK3CD/INS/IRS2/INSR"
+"hsa04068","FoxO signaling pathway",20,-0.671582100623001,-1.1742622091193,0.334963325183374,0.742677091842689,0.742677091842689,10,"tags=45%, list=43%, signal=195%","PIK3R2/P3R3URF-PIK3R3/IRS4/PIK3CD/NRAS/IGF1/INS/IRS2/INSR"
+"hsa04010","MAPK signaling pathway",10,-0.632839746882227,-1.25079693873228,0.182619647355164,0.742677091842689,0.742677091842689,6,"tags=40%, list=26%, signal=52%","NRAS/IGF1/INS/INSR"
+"hsa04911","Insulin secretion",4,-0.762449453028476,-1.26541726704366,0.190620272314675,0.742677091842689,0.742677091842689,4,"tags=100%, list=17%, signal=100%","ADCY2/ADCY1/INS"
+"hsa04913","Ovarian steroidogenesis",7,-0.774497218717026,-1.43521140167019,0.0492676431424767,0.742677091842689,0.742677091842689,5,"tags=43%, list=22%, signal=48%","IGF1/INS/INSR"
+"hsa04022","cGMP-PKG signaling pathway",11,-0.726806094314102,-1.46230742169755,0.0608272506082725,0.742677091842689,0.742677091842689,4,"tags=27%, list=17%, signal=43%","INS/IRS2/INSR"
diff --git a/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea.pdf b/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea.pdf
new file mode 100644
index 0000000000000000000000000000000000000000..ffac10b10e697821000bed5fc3e00f4802d22d43
Binary files /dev/null and b/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea.pdf differ
diff --git a/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea_1.pdf b/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea_1.pdf
new file mode 100644
index 0000000000000000000000000000000000000000..9f1121e4bd27785e2ff8f9cbf36d7a23b0f4a0b5
Binary files /dev/null and b/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea_1.pdf differ
diff --git a/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea_10.pdf b/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea_10.pdf
new file mode 100644
index 0000000000000000000000000000000000000000..033b0aa173eee1a55279c9e9f7ee5e655eb6c113
Binary files /dev/null and b/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea_10.pdf differ
diff --git a/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea_2.pdf b/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea_2.pdf
new file mode 100644
index 0000000000000000000000000000000000000000..99999a1440506136a76dc7d0d20a5f2b9511dd04
Binary files /dev/null and b/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea_2.pdf differ
diff --git a/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea_3.pdf b/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea_3.pdf
new file mode 100644
index 0000000000000000000000000000000000000000..23af464ca86d11f950172ea9e6567f043a946dea
Binary files /dev/null and b/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea_3.pdf differ
diff --git a/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea_4.pdf b/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea_4.pdf
new file mode 100644
index 0000000000000000000000000000000000000000..049c68ac865219182153b73ef55504218187692a
Binary files /dev/null and b/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea_4.pdf differ
diff --git a/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea_5.pdf b/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea_5.pdf
new file mode 100644
index 0000000000000000000000000000000000000000..6bca03fbd67bd20fcd75669cb522476fb9c02ef0
Binary files /dev/null and b/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea_5.pdf differ
diff --git a/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea_6.pdf b/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea_6.pdf
new file mode 100644
index 0000000000000000000000000000000000000000..c0ea6e15f50b80eeb64809d13c3ce2b2c30e01ff
Binary files /dev/null and b/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea_6.pdf differ
diff --git a/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea_7.pdf b/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea_7.pdf
new file mode 100644
index 0000000000000000000000000000000000000000..96ed6e5ca674d08d00a4bce921af9869b823b54c
Binary files /dev/null and b/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea_7.pdf differ
diff --git a/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea_8.pdf b/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea_8.pdf
new file mode 100644
index 0000000000000000000000000000000000000000..cbd02ba54a8916227c63d657b90d46bc969a5e7d
Binary files /dev/null and b/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea_8.pdf differ
diff --git a/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea_9.pdf b/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea_9.pdf
new file mode 100644
index 0000000000000000000000000000000000000000..31ecdf25dd6cca9c7c06f71f1d5185690ee76651
Binary files /dev/null and b/test/test/EnrichmentAnalysis/kegg_clusterprofiler-qea/clusterprofiler_qea_9.pdf differ
diff --git a/test/test/ODA_Result.rdata b/test/test/ODA_Result.rdata
new file mode 100644
index 0000000000000000000000000000000000000000..b6f3adabb794d7a4a5a98f887d72c02ceb65ae98
Binary files /dev/null and b/test/test/ODA_Result.rdata differ
diff --git a/test/test/ODA_Result.xlsx b/test/test/ODA_Result.xlsx
new file mode 100644
index 0000000000000000000000000000000000000000..fa49443b441fe873a7f5f2f6d1d69542b4241b15
Binary files /dev/null and b/test/test/ODA_Result.xlsx differ
diff --git a/test/test/ODA_run1729826624.423751435.log b/test/test/ODA_run1729826624.423751435.log
new file mode 100644
index 0000000000000000000000000000000000000000..1adc9229d662ef8ac637ba0356861012a57687f9
--- /dev/null
+++ b/test/test/ODA_run1729826624.423751435.log
@@ -0,0 +1,328 @@
+Loading required package: limma
+Loading required package: preprocessCore
+Loading required package: globaltest
+Loading required package: survival
+Loading required package: DESeq2
+Loading required package: S4Vectors
+Loading required package: stats4
+Loading required package: BiocGenerics
+
+Attaching package: ‘BiocGenerics’
+
+The following object is masked from ‘package:globaltest’:
+
+ sort
+
+The following object is masked from ‘package:limma’:
+
+ plotMA
+
+The following objects are masked from ‘package:stats’:
+
+ IQR, mad, sd, var, xtabs
+
+The following objects are masked from ‘package:base’:
+
+ anyDuplicated, aperm, append, as.data.frame, basename, cbind,
+ colnames, dirname, do.call, duplicated, eval, evalq, Filter, Find,
+ get, grep, grepl, intersect, is.unsorted, lapply, Map, mapply,
+ match, mget, order, paste, pmax, pmax.int, pmin, pmin.int,
+ Position, rank, rbind, Reduce, rownames, sapply, setdiff, sort,
+ table, tapply, union, unique, unsplit, which.max, which.min
+
+
+Attaching package: ‘S4Vectors’
+
+The following object is masked from ‘package:utils’:
+
+ findMatches
+
+The following objects are masked from ‘package:base’:
+
+ expand.grid, I, unname
+
+Loading required package: IRanges
+Loading required package: GenomicRanges
+Loading required package: GenomeInfoDb
+Loading required package: SummarizedExperiment
+Loading required package: MatrixGenerics
+Loading required package: matrixStats
+
+Attaching package: ‘MatrixGenerics’
+
+The following objects are masked from ‘package:matrixStats’:
+
+ colAlls, colAnyNAs, colAnys, colAvgsPerRowSet, colCollapse,
+ colCounts, colCummaxs, colCummins, colCumprods, colCumsums,
+ colDiffs, colIQRDiffs, colIQRs, colLogSumExps, colMadDiffs,
+ colMads, colMaxs, colMeans2, colMedians, colMins, colOrderStats,
+ colProds, colQuantiles, colRanges, colRanks, colSdDiffs, colSds,
+ colSums2, colTabulates, colVarDiffs, colVars, colWeightedMads,
+ colWeightedMeans, colWeightedMedians, colWeightedSds,
+ colWeightedVars, rowAlls, rowAnyNAs, rowAnys, rowAvgsPerColSet,
+ rowCollapse, rowCounts, rowCummaxs, rowCummins, rowCumprods,
+ rowCumsums, rowDiffs, rowIQRDiffs, rowIQRs, rowLogSumExps,
+ rowMadDiffs, rowMads, rowMaxs, rowMeans2, rowMedians, rowMins,
+ rowOrderStats, rowProds, rowQuantiles, rowRanges, rowRanks,
+ rowSdDiffs, rowSds, rowSums2, rowTabulates, rowVarDiffs, rowVars,
+ rowWeightedMads, rowWeightedMeans, rowWeightedMedians,
+ rowWeightedSds, rowWeightedVars
+
+Loading required package: Biobase
+Welcome to Bioconductor
+
+ Vignettes contain introductory material; view with
+ 'browseVignettes()'. To cite Bioconductor, see
+ 'citation("Biobase")', and for packages 'citation("pkgname")'.
+
+
+Attaching package: ‘Biobase’
+
+The following object is masked from ‘package:MatrixGenerics’:
+
+ rowMedians
+
+The following objects are masked from ‘package:matrixStats’:
+
+ anyMissing, rowMedians
+
+Loading required package: openxlsx
+Loading required package: data.table
+
+Attaching package: ‘data.table’
+
+The following object is masked from ‘package:SummarizedExperiment’:
+
+ shift
+
+The following object is masked from ‘package:GenomicRanges’:
+
+ shift
+
+The following object is masked from ‘package:IRanges’:
+
+ shift
+
+The following objects are masked from ‘package:S4Vectors’:
+
+ first, second
+
+Loading required package: dplyr
+
+Attaching package: ‘dplyr’
+
+The following objects are masked from ‘package:data.table’:
+
+ between, first, last
+
+The following object is masked from ‘package:Biobase’:
+
+ combine
+
+The following object is masked from ‘package:matrixStats’:
+
+ count
+
+The following objects are masked from ‘package:GenomicRanges’:
+
+ intersect, setdiff, union
+
+The following object is masked from ‘package:GenomeInfoDb’:
+
+ intersect
+
+The following objects are masked from ‘package:IRanges’:
+
+ collapse, desc, intersect, setdiff, slice, union
+
+The following objects are masked from ‘package:S4Vectors’:
+
+ first, intersect, rename, setdiff, setequal, union
+
+The following objects are masked from ‘package:BiocGenerics’:
+
+ combine, intersect, setdiff, union
+
+The following object is masked from ‘package:globaltest’:
+
+ combine
+
+The following objects are masked from ‘package:stats’:
+
+ filter, lag
+
+The following objects are masked from ‘package:base’:
+
+ intersect, setdiff, setequal, union
+
+Loading required package: gtools
+Loading required package: lme4
+Loading required package: Matrix
+
+Attaching package: ‘Matrix’
+
+The following object is masked from ‘package:S4Vectors’:
+
+ expand
+
+Loading required package: cplm
+Loading required package: coda
+Loading required package: splines
+
+Attaching package: ‘cplm’
+
+The following object is masked from ‘package:lme4’:
+
+ VarCorr
+
+Loading required package: nlme
+
+Attaching package: ‘nlme’
+
+The following objects are masked from ‘package:cplm’:
+
+ fixef, ranef, VarCorr
+
+The following object is masked from ‘package:lme4’:
+
+ lmList
+
+The following object is masked from ‘package:dplyr’:
+
+ collapse
+
+The following object is masked from ‘package:IRanges’:
+
+ collapse
+
+Loading required package: lmtest
+Loading required package: zoo
+
+Attaching package: ‘zoo’
+
+The following objects are masked from ‘package:data.table’:
+
+ yearmon, yearqtr
+
+The following objects are masked from ‘package:base’:
+
+ as.Date, as.Date.numeric
+
+Loading required package: ggplot2
+Loading required package: Cairo
+Loading required package: pheatmap
+Loading required package: ggcorrplot
+Loading required package: eulerr
+Loading required package: patchwork
+Loading required package: ggforce
+Loading required package: scales
+Loading required package: qs
+qs 0.26.1
+Loading required package: Rserve
+Loading required package: pls
+
+Attaching package: ‘pls’
+
+The following object is masked from ‘package:stats’:
+
+ loadings
+
+Loading required package: clusterProfiler
+
+clusterProfiler v4.10.1 For help: https://yulab-smu.top/biomedical-knowledge-mining-book/
+
+If you use clusterProfiler in published research, please cite:
+T Wu, E Hu, S Xu, M Chen, P Guo, Z Dai, T Feng, L Zhou, W Tang, L Zhan, X Fu, S Liu, X Bo, and G Yu. clusterProfiler 4.0: A universal enrichment tool for interpreting omics data. The Innovation. 2021, 2(3):100141
+
+Attaching package: ‘clusterProfiler’
+
+The following object is masked from ‘package:IRanges’:
+
+ slice
+
+The following object is masked from ‘package:S4Vectors’:
+
+ rename
+
+The following object is masked from ‘package:stats’:
+
+ filter
+
+Loading required package: enrichplot
+Loading required package: msigdbr
+
+Attaching package: ‘RcppParallel’
+
+The following object is masked from ‘package:Rcpp’:
+
+ LdFlags
+
+######################Analysis started.######################
+Creating the ODA object ...
+Reading samples sheet ...
+Finished reading samples sheet.
+Reading features sheet ...
+Finished reading features sheet.
+Reading parameters sheet ...
+Finished reading parameters sheet.
+Reading comparisons sheet ...
+Finished reading comparisons sheet.
+Reading data ...
+28 features are present in at least one sample. If the number is low, consider decreasing the valueFilter threshold.
+22 features are present in at least one group. If the number is low, consider decreasing the groupCountFilter threshold.
+Finished reading data.
+Normalizing and transforming data ...
+converting counts to integer mode
+Finished normalizing and transforming data.
+The ODA object is created.
+Creating the workbook object ...
+Workbook object is created.
+Writing the Summary sheet.
+Finished writing the Summary sheet for Parameters.
+Writing the Summary sheet.
+Finished writing the Summary sheet for Attributes.
+Writing the Summary sheet.
+Finished writing the Summary sheet for Groups.
+Writing the Summary sheet.
+Finished writing the Summary sheet for Samples.
+Writing the Raw_Data sheet ...
+Finished writing the data sheet.
+Writing the Log2(x+1.00e+00)_deseq2-normalized_Data sheet ...
+Finished writing the data sheet.
+Writing the Sample_Counts sheet.
+Finished writing the Sample_Counts sheet for ID.
+Writing the Group_Counts sheet.
+Finished writing the Group_Counts sheet for ID.
+clusterProfiler ORA and QEA analyses cannot be done at the same time. Please run them separately.
+##########Begin clusterProfiler-ORA Analysis.##########
+
+'select()' returned 1:1 mapping between keys and columns
+##########End clusterProfiler-ORA Analysis.##########
+##########Begin clusterProfiler-QEA Analysis.##########
+preparing geneSet collections...
+GSEA analysis...
+leading edge analysis...
+done...
+##########End clusterProfiler-QEA Analysis.##########
+##########Begin Differential Tests.##########
+[0;33mWarning: SubjectID is all unique for the comparison and it will be dropped. If this is not desired, check the SubjectID column.[0m
+[0;33mWarning: Value is all unique for the comparison and it will be dropped. If this is not desired, check the Value column.[0m
+[0;33mWarning: GroupID is all unique for the comparison and it will be dropped. If this is not desired, check the GroupID column.[0m
+[0;33mWarning: SubjectID is all unique for the comparison and it will be dropped. If this is not desired, check the SubjectID column.[0m
+Testing WT vs. Preg by DESeq2 with full formula ~GroupID and reduced formula ~1 ...
+converting counts to integer mode
+gene-wise dispersion estimates
+mean-dispersion relationship
+final dispersion estimates
+Performing the nbinomWaldTest test...
+Result names:
+[1] "Intercept" "GroupID_Preg_vs_WT"
+using 'apeglm' for LFC shrinkage. If used in published research, please cite:
+ Zhu, A., Ibrahim, J.G., Love, M.I. (2018) Heavy-tailed prior distributions for
+ sequence count data: removing the noise and preserving large differences.
+ Bioinformatics. https://doi.org/10.1093/bioinformatics/bty895
+Test finished.
+Writing the Comparison1 sheet.
+Finished writing the Comparison1 sheet for WT_vs_Preg.
+##########End of Differential Tests.##########
+######################Analysis finished.######################
diff --git a/test/test_V2.2.xlsx b/test/test_V2.2.xlsx
new file mode 100755
index 0000000000000000000000000000000000000000..77286720dfdbf4202520a1b44859bf796930c522
Binary files /dev/null and b/test/test_V2.2.xlsx differ