Mercurial > repos > lecorguille > xcms_retcor

comparison lib-xcms3.x.x.r @ 10:8828cba9aedd draft

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
planemo upload for repository https://github.com/workflow4metabolomics/xcms commit 9f72e947d9c241d11221cad561f3525d27231857
author lecorguille
date Tue, 18 Sep 2018 16:12:29 -0400
parents
children
comparison
equal deleted inserted replaced
9:e4e0254a3c0a 10:8828cba9aedd
1
2
3 #@TODO: remove this function as soon as we can use xcms 3.x.x from Bioconductor 3.7
4 # https://github.com/sneumann/xcms/issues/250
5 groupnamesW4M <- function(xdata, mzdec = 0, rtdec = 0) {
6 mzfmt <- paste("%.", mzdec, "f", sep = "")
7 rtfmt <- paste("%.", rtdec, "f", sep = "")
8
9 gnames <- paste("M", sprintf(mzfmt, featureDefinitions(xdata)[,"mzmed"]), "T",
10 sprintf(rtfmt, featureDefinitions(xdata)[,"rtmed"]), sep = "")
11
12 if (any(dup <- duplicated(gnames)))
13 for (dupname in unique(gnames[dup])) {
14 dupidx <- which(gnames == dupname)
15 gnames[dupidx] <- paste(gnames[dupidx], seq(along = dupidx), sep = "_")
16 }
17
18 return (gnames)
19 }
20
21 #@TODO: remove this function as soon as we can use xcms 3.x.x from Bioconductor 3.7
22 # https://github.com/sneumann/xcms/issues/247
23 .concatenate_XCMSnExp <- function(...) {
24 x <- list(...)
25 if (length(x) == 0)
26 return(NULL)
27 if (length(x) == 1)
28 return(x[[1]])
29 ## Check that all are XCMSnExp objects.
30 if (!all(unlist(lapply(x, function(z) is(z, "XCMSnExp")))))
31 stop("All passed objects should be 'XCMSnExp' objects")
32 new_x <- as(.concatenate_OnDiskMSnExp(...), "XCMSnExp")
33 ## If any of the XCMSnExp has alignment results or detected features drop
34 ## them!
35 x <- lapply(x, function(z) {
36 if (hasAdjustedRtime(z)) {
37 z <- dropAdjustedRtime(z)
38 warning("Adjusted retention times found, had to drop them.")
39 }
40 if (hasFeatures(z)) {
41 z <- dropFeatureDefinitions(z)
42 warning("Feature definitions found, had to drop them.")
43 }
44 z
45 })
46 ## Combine peaks
47 fls <- lapply(x, fileNames)
48 startidx <- cumsum(lengths(fls))
49 pks <- lapply(x, chromPeaks)
50 procH <- lapply(x, processHistory)
51 for (i in 2:length(fls)) {
52 pks[[i]][, "sample"] <- pks[[i]][, "sample"] + startidx[i - 1]
53 procH[[i]] <- lapply(procH[[i]], function(z) {
54 z@fileIndex <- as.integer(z@fileIndex + startidx[i - 1])
55 z
56 })
57 }
58 pks <- do.call(rbind, pks)
59 new_x@.processHistory <- unlist(procH)
60 chromPeaks(new_x) <- pks
61 if (validObject(new_x))
62 new_x
63 }
64
65 #@TODO: remove this function as soon as we can use xcms 3.x.x from Bioconductor 3.7
66 # https://github.com/sneumann/xcms/issues/247
67 .concatenate_OnDiskMSnExp <- function(...) {
68 x <- list(...)
69 if (length(x) == 0)
70 return(NULL)
71 if (length(x) == 1)
72 return(x[[1]])
73 ## Check that all are XCMSnExp objects.
74 if (!all(unlist(lapply(x, function(z) is(z, "OnDiskMSnExp")))))
75 stop("All passed objects should be 'OnDiskMSnExp' objects")
76 ## Check processingQueue
77 procQ <- lapply(x, function(z) z@spectraProcessingQueue)
78 new_procQ <- procQ[[1]]
79 is_ok <- unlist(lapply(procQ, function(z)
80 !is.character(all.equal(new_procQ, z))
81 ))
82 if (any(!is_ok)) {
83 warning("Processing queues from the submitted objects differ! ",
84 "Dropping the processing queue.")
85 new_procQ <- list()
86 }
87 ## processingData
88 fls <- lapply(x, function(z) z@processingData@files)
89 startidx <- cumsum(lengths(fls))
90 ## featureData
91 featd <- lapply(x, fData)
92 ## Have to update the file index and the spectrum names.
93 for (i in 2:length(featd)) {
94 featd[[i]]$fileIdx <- featd[[i]]$fileIdx + startidx[i - 1]
95 rownames(featd[[i]]) <- MSnbase:::formatFileSpectrumNames(
96 fileIds = featd[[i]]$fileIdx,
97 spectrumIds = featd[[i]]$spIdx,
98 nSpectra = nrow(featd[[i]]),
99 nFiles = length(unlist(fls))
100 )
101 }
102 featd <- do.call(rbind, featd)
103 featd$spectrum <- 1:nrow(featd)
104 ## experimentData
105 expdata <- lapply(x, function(z) {
106 ed <- z@experimentData
107 data.frame(instrumentManufacturer = ed@instrumentManufacturer,
108 instrumentModel = ed@instrumentModel,
109 ionSource = ed@ionSource,
110 analyser = ed@analyser,
111 detectorType = ed@detectorType,
112 stringsAsFactors = FALSE)
113 })
114 expdata <- do.call(rbind, expdata)
115 expdata <- new("MIAPE",
116 instrumentManufacturer = expdata$instrumentManufacturer,
117 instrumentModel = expdata$instrumentModel,
118 ionSource = expdata$ionSource,
119 analyser = expdata$analyser,
120 detectorType = expdata$detectorType)
121
122 ## protocolData
123 protodata <- lapply(x, function(z) z@protocolData)
124 if (any(unlist(lapply(protodata, nrow)) > 0))
125 warning("Found non-empty protocol data, but merging protocol data is",
126 " currently not supported. Skipped.")
127 ## phenoData
128 pdata <- do.call(rbind, lapply(x, pData))
129 res <- new(
130 "OnDiskMSnExp",
131 phenoData = new("NAnnotatedDataFrame", data = pdata),
132 featureData = new("AnnotatedDataFrame", featd),
133 processingData = new("MSnProcess",
134 processing = paste0("Concatenated [", date(), "]"),
135 files = unlist(fls), smoothed = NA),
136 experimentData = expdata,
137 spectraProcessingQueue = new_procQ)
138 if (validObject(res))
139 res
140 }
141
142 #@TODO: remove this function as soon as we can use xcms 3.x.x from Bioconductor 3.7
143 # https://github.com/sneumann/xcms/issues/247
144 c.XCMSnExp <- function(...) {
145 .concatenate_XCMSnExp(...)
146 }
147
148 #@TODO: remove this function as soon as we can use xcms 3.x.x from Bioconductor 3.7
149 # https://github.com/sneumann/xcms/issues/247
150 c.MSnbase <- function(...) {
151 .concatenate_OnDiskMSnExp(...)
152 }