Mercurial > repos > marie-tremblay-metatoul > nmr_preprocessing
comparison ReadFids_script.R @ 7:122df1bf0a8c draft default tip
planemo upload for repository https://github.com/workflow4metabolomics/nmr_preprocessing commit 3d328007dd7716848ec2eeb6c2a472f27eeb2995
author | workflow4metabolomics |
---|---|
date | Fri, 11 Jul 2025 08:33:38 +0000 |
parents | 5e64657b4fe5 |
children |
comparison
equal
deleted
inserted
replaced
6:6e837e9352a2 | 7:122df1bf0a8c |
---|---|
1 ################################################################################################ | 1 ################################################################################################ |
2 # | 2 # |
3 # Read FIDs in Bruker format | 3 # Read FIDs in Bruker format |
4 # | 4 # |
5 # | |
6 ################################################################################################ | 5 ################################################################################################ |
7 | 6 # Function to convert a vector to a matrix |
8 | |
9 # vec2mat ============================================================================== | |
10 vec2mat <- function(vec) { | 7 vec2mat <- function(vec) { |
11 return(matrix(vec, nrow = 1, dimnames = list(c(1), names(vec)))) | 8 return(matrix(vec, nrow = 1, dimnames = list(c(1), names(vec)))) |
12 } | 9 } |
13 | 10 |
14 | 11 # Function to read FID files |
15 # ReadFid ============================================================================== | 12 # Format of files depends on version of software used for spectra aquisition (< or > 4.x.x) |
13 # Read 1D FID using Bruker XWinNMR and TopSpin format. It is inspired of the | |
14 # matNMR matlab library which deals with 2D FID and also other formats | |
15 # Based on aquisition parameters stored in the acqus file | |
16 ReadFid <- function(path) { | 16 ReadFid <- function(path) { |
17 | 17 paramFile <- file.path(path, "acqus") |
18 # Read 1D FID using Bruker XWinNMR and TopSpin format. It is inspired of the | 18 params <- readParams(paramFile, c("TD", "BYTORDA", "DIGMOD", "DECIM", "DSPFVS", "SW_h", "SW", "O1")) |
19 # matNMR matlab library which deals with 2D FID and also other formats | 19 |
20 # Read also the parameters in the acqus file | 20 # Version of the TopSpin software |
21 | 21 line <- readLines(paramFile)[1] |
22 paramFile <- file.path(path, "acqus") | 22 version <- as.numeric(substr(strsplit(line, " ")[[1]][5], 1, 1)) |
23 # BYTEORDA: 0 -> Little Endian 1 -> Big Endian | 23 neo <- (version > 3) |
24 params <- readParams(paramFile, c("TD", "BYTORDA", "DIGMOD", "DECIM", "DSPFVS", | 24 |
25 "SW_h", "SW", "O1")) | |
26 | |
27 if (params[["DSPFVS"]] >= 20) { | |
28 # The group delay first order phase correction is given directly from version 20 | 25 # The group delay first order phase correction is given directly from version 20 |
29 grpdly <- readParams(paramFile, c("GRPDLY")) | 26 if (params[["DSPFVS"]] >= 20) { |
30 params[["GRPDLY"]] <- grpdly[["GRPDLY"]] | 27 grpdly <- readParams(paramFile, c("GRPDLY")) |
31 } | 28 params[["GRPDLY"]] <- grpdly[["GRPDLY"]] |
32 TD <- params[["TD"]] | 29 } |
33 endianness <- if (params$BYTORDA) | 30 TD <- params[["TD"]] |
34 "big" else "little" | 31 |
35 if (TD%%2 != 0) { | 32 endianness <- if (params$BYTORDA) { |
36 stop(paste("Only even numbers are allowed for size in TD because it is complex | 33 "big" |
37 data with the real and imaginary part for each element.", | 34 } else { |
38 "The TD value is in the", paramFile, "file")) | 35 "little" |
39 } | 36 } |
40 | 37 if (TD %% 2 != 0) { |
41 # Interpret params Dwell Time, time between 2 data points in the FID | 38 stop(paste("Only even numbers are allowed for size in TD because it is complex data with the real and imaginary part for each element.", "The TD value is in the", paramFile, "file")) |
42 params[["DT"]] <- 1/(2 * params[["SW_h"]]) | 39 } |
43 | 40 |
44 # Read fid | 41 # Interpret params Dwell Time, time between 2 data points in the FID |
45 fidFile <- file.path(path, "fid") | 42 params[["DT"]] <- 1 / (2 * params[["SW_h"]]) |
46 fidOnDisk <- readBin(fidFile, what = "int", n = TD, size = 4L, endian = endianness) | 43 |
47 | 44 # Read fid depend on version of aquisition software |
48 # Real size that is on disk (it should be equal to TD2, except for TopSpin/Bruker | 45 fidFile <- file.path(path, "fid") |
49 # (which is our case) according to matNMR as just discussed | 46 if (neo) { |
50 TDOnDisk <- length(fidOnDisk) | 47 fidOnDisk <- readBin(fidFile, what = "double", n = TD, size = NA_integer_, signed = TRUE, endian = .Platform$endian) |
51 if (TDOnDisk < TD) { | 48 } else { |
52 warning("Size is smaller than expected, the rest is filled with zero so the size is the same for every fid") | 49 fidOnDisk <- readBin(fidFile, what = "int", n = TD, size = 4L, endian = endianness) |
53 fidGoodSize <- sapply(vector("list", length = TD), function(x) 0) | 50 } |
54 fidGoodSize[1:TDOnDisk] <- fidOnDisk | 51 |
55 | 52 # Real size that is on disk (it should be equal to TD2, except for TopSpin/Bruker |
56 } else if (TDOnDisk > TD) { | 53 # (which is our case) according to matNMR as just discussed |
57 warning("Size is bigger than expected, the rest ignored so the size is the same for every fid") | 54 TDOnDisk <- length(fidOnDisk) |
58 fidGoodSize <- fidOnDisk(1:TD) | 55 if (TDOnDisk < TD) { |
59 | 56 warning("Size is smaller than expected, the rest is filled with zero so the size is the same for every fid") |
60 } else { | 57 fidGoodSize <- sapply(vector("list", length = TD), function(x) 0) |
61 fidGoodSize <- fidOnDisk | 58 fidGoodSize[1:TDOnDisk] <- fidOnDisk |
62 } | 59 } else if (TDOnDisk > TD) { |
63 | 60 warning("Size is bigger than expected, the rest ignored so the size is the same for every fid") |
64 fidRePart <- fidGoodSize[seq(from = 1, to = TD, by = 2)] | 61 fidGoodSize <- fidOnDisk(1:TD) |
65 fidImPart <- fidGoodSize[seq(from = 2, to = TD, by = 2)] | 62 } else { |
66 fid <- complex(real = fidRePart, imaginary = fidImPart) | 63 fidGoodSize <- fidOnDisk |
67 | 64 } |
68 return(list(fid = fid, params = params)) | 65 |
69 } | 66 fidRePart <- fidGoodSize[seq(from = 1, to = TD, by = 2)] |
70 | 67 fidImPart <- fidGoodSize[seq(from = 2, to = TD, by = 2)] |
71 | 68 fid <- complex(real = fidRePart, imaginary = fidImPart) |
72 | 69 |
73 | 70 return(list(fid = fid, params = params)) |
74 # getDirsContainingFid ============================================================================== | 71 } |
72 | |
73 # Function to obtain path to files | |
75 getDirsContainingFid <- function(path) { | 74 getDirsContainingFid <- function(path) { |
76 subdirs <- dir(path, full.names = TRUE) | 75 subdirs <- dir(path, full.names = TRUE) |
77 if (length(subdirs) > 0) { | 76 if (length(subdirs) > 0) { |
78 cond <- sapply(subdirs, function(x) { | 77 cond <- sapply(subdirs, function(x) { |
79 content <- dir(x) | 78 content <- dir(x) |
80 # subdirs must contain fid, acqu and acqus files | 79 # subdirs must contain fid, acqu and acqus files |
81 return("fid" %in% content && "acqu" %in% content && "acqus" %in% content) | 80 return("fid" %in% content && "acqu" %in% content && "acqus" %in% content) |
82 }) | 81 }) |
83 subdirs <- subdirs[cond] | 82 subdirs <- subdirs[cond] |
84 } | 83 } |
85 return(subdirs) | 84 return(subdirs) |
86 } | 85 } |
87 | 86 |
88 | 87 # Function to xxx |
89 | 88 beginTreatment <- function(name, Signal_data = NULL, Signal_info = NULL, force.real = FALSE) { |
90 | 89 cat("Begin", name, "\n") |
91 | 90 |
92 | 91 # Formatting the Signal_data and Signal_info |
93 # beginTreatment ============================================================================== | 92 vec <- is.vector(Signal_data) |
94 | 93 if (vec) { |
95 beginTreatment <- function(name, Signal_data = NULL, Signal_info = NULL, | 94 Signal_data <- vec2mat(Signal_data) |
96 force.real = FALSE) { | 95 } |
97 | 96 if (is.vector(Signal_info)) { |
98 cat("Begin", name, "\n") | 97 Signal_info <- vec2mat(Signal_info) |
99 | 98 } |
100 | 99 if (!is.null(Signal_data)) { |
101 # Formatting the Signal_data and Signal_info ----------------------- | 100 if (!is.matrix(Signal_data)) { |
102 | 101 stop("Signal_data is not a matrix.") |
103 vec <- is.vector(Signal_data) | 102 } |
104 if (vec) { | 103 if (is.vector(Signal_info)) { |
105 Signal_data <- vec2mat(Signal_data) | 104 Signal_info <- vec2mat(Signal_info) |
106 } | 105 } |
107 if (is.vector(Signal_info)) { | 106 } |
108 Signal_info <- vec2mat(Signal_info) | 107 if (!is.null(Signal_info) && !is.matrix(Signal_info)) { |
109 } | 108 stop("Signal_info is not a matrix.") |
110 if (!is.null(Signal_data)) { | 109 } |
111 if (!is.matrix(Signal_data)) { | 110 |
112 stop("Signal_data is not a matrix.") | 111 Original_data <- Signal_data |
113 } | 112 |
114 if (!is.complex(Signal_data) && !is.numeric(Signal_data)) { | 113 # Extract the real part of the spectrum |
115 stop("Signal_data contains non-numerical values.") | 114 if (force.real) { |
116 } | 115 if (is.complex(Signal_data)) { |
117 } | 116 Signal_data <- Re(Signal_data) |
118 if (!is.null(Signal_info) && !is.matrix(Signal_info)) { | 117 } else { |
119 stop("Signal_info is not a matrix.") | 118 # The signal is numeric Im(Signal_data) is zero anyway so let's avoid |
120 } | 119 # using complex(real=...,imaginary=0) which would give a complex signal |
121 | 120 # in endTreatment() |
122 | 121 force.real <- FALSE |
123 Original_data <- Signal_data | 122 } |
124 | 123 } |
125 # Extract the real part of the spectrum --------------------------- | 124 |
126 | 125 # Return the formatted data and metadata entries |
127 if (force.real) { | 126 return(list(start = proc.time(), vec = vec, force.real = force.real, Original_data = Original_data, Signal_data = Signal_data, Signal_info = Signal_info)) |
128 if (is.complex(Signal_data)) { | 127 } |
129 Signal_data <- Re(Signal_data) | 128 |
130 } else { | 129 # Function to get information on reading end |
131 # The signal is numeric Im(Signal_data) is zero anyway so let's avoid | |
132 # using complex(real=...,imaginary=0) which would give a complex signal | |
133 # in endTreatment() | |
134 force.real <- FALSE | |
135 } | |
136 } | |
137 | |
138 | |
139 # Return the formatted data and metadata entries -------------------- | |
140 | |
141 return(list(start = proc.time(), vec = vec, force.real = force.real, | |
142 Original_data = Original_data, Signal_data = Signal_data, Signal_info = Signal_info)) | |
143 } | |
144 | |
145 | |
146 # endTreatment ============================================================================== | |
147 | |
148 endTreatment <- function(name, begin_info, Signal_data) { | 130 endTreatment <- function(name, begin_info, Signal_data) { |
149 end_time = proc.time() # record it as soon as possible | 131 end_time <- proc.time() # record it as soon as possible |
150 start_time = begin_info[["start"]] | 132 start_time <- begin_info[["start"]] |
151 delta_time = end_time - start_time | 133 delta_time <- end_time - start_time |
152 delta = delta_time[] | 134 delta <- delta_time[] |
153 cat("End", name, "\n") | 135 cat("End", name, "\n") |
154 cat("It lasted", | 136 cat("It lasted", round(delta["user.self"], 3), "s user time,", round(delta["sys.self"], 3), "s system time and", round(delta["elapsed"], 3), "s elapsed time.\n") |
155 round(delta["user.self"], 3), "s user time,", | 137 if (begin_info[["force.real"]]) { |
156 round(delta["sys.self"] , 3), "s system time and", | 138 # The imaginary part is left untouched |
157 round(delta["elapsed"] , 3), "s elapsed time.\n") | 139 i <- complex(real = 0, imaginary = 1) |
158 if (begin_info[["force.real"]]) { | 140 Signal_data <- Signal_data + i * Im(begin_info[["Original_data"]]) |
159 # The imaginary part is left untouched | 141 } |
160 i <- complex(real=0, imaginary=1) | 142 if (begin_info[["vec"]]) { |
161 Signal_data = Signal_data + i * Im(begin_info[["Original_data"]]) | 143 Signal_data <- Signal_data[1, ] |
162 } | 144 } |
163 if (begin_info[["vec"]]) { | 145 return(Signal_data) |
164 Signal_data = Signal_data[1,] | 146 } |
165 } | 147 |
166 return(Signal_data) | 148 # Function to check arguments |
167 } | 149 checkArg <- function(arg, checks, can.be.null = FALSE) { |
168 | 150 check.list <- list(bool = c(is.logical, "a boolean"), int = c(function(x) { |
169 | 151 x %% 1 == 0 |
170 # checkArg ============================================================================== | 152 }, "an integer"), num = c(is.numeric, "a numeric"), str = c(is.character, "a string"), pos = c(function(x) { |
171 | 153 x > 0 |
172 checkArg <- function(arg, checks, can.be.null=FALSE) { | 154 }, "positive"), pos0 = c(function(x) { |
173 check.list <- list(bool=c(is.logical, "a boolean"), | 155 x >= 0 |
174 int =c(function(x){x%%1==0}, "an integer"), | 156 }, "positive or zero"), l1 = c(function(x) { |
175 num =c(is.numeric, "a numeric"), | 157 length(x) == 1 |
176 str =c(is.character, "a string"), | 158 }, "of length 1")) |
177 pos =c(function(x){x>0}, "positive"), | 159 if (is.null(arg)) { |
178 pos0=c(function(x){x>=0}, "positive or zero"), | 160 if (!can.be.null) { |
179 l1 =c(function(x){length(x)==1}, "of length 1") | 161 stop(deparse(substitute(arg)), " is null.") |
180 ) | 162 } |
181 if (is.null(arg)) { | 163 } |
182 if (!can.be.null) { | 164 } |
183 stop(deparse(substitute(arg)), " is null.") | 165 |
184 } | 166 |
185 } else { | 167 # Function to get arguments |
186 if (is.matrix(arg)) { | 168 getArg <- function(arg, info, argname, can.be.absent = FALSE) { |
187 stop(deparse(substitute(arg)), " is not scalar.") | 169 if (is.null(arg)) { |
188 } | 170 start <- paste("impossible to get argument", argname, "it was not given directly and") |
189 for (c in checks) { | 171 if (!is.matrix(info)) { |
190 if (!check.list[[c]][[1]](arg)) { | 172 stop(paste(start, "the info matrix was not given")) |
191 stop(deparse(substitute(arg)), " is not ", check.list[[c]][[2]], ".") | 173 } |
192 } | 174 if (!(argname %in% colnames(info))) { |
193 } | 175 if (can.be.absent) { |
194 } | 176 return(NULL) |
195 } | 177 } else { |
196 | 178 stop(paste(start, "is not in the info matrix")) |
197 | 179 } |
198 # getArg ============================================================================== | 180 } |
199 | 181 if (nrow(info) < 1) { |
200 getArg <- function(arg, info, argname, can.be.absent=FALSE) { | 182 stop(paste(start, "the info matrix has no row")) |
201 if (is.null(arg)) { | 183 } |
202 start <- paste("impossible to get argument", argname, "it was not given directly and"); | 184 arg <- info[1, argname] |
203 if (!is.matrix(info)) { | 185 if (is.na(arg)) { |
204 stop(paste(start, "the info matrix was not given")) | 186 stop(paste(start, "it is NA in the info matrix")) |
205 } | 187 } |
206 if (!(argname %in% colnames(info))) { | 188 } |
207 if (can.be.absent) { | 189 return(arg) |
208 return(NULL) | 190 } |
209 } else { | 191 |
210 stop(paste(start, "is not in the info matrix")) | 192 # Function to get title and name samples |
211 } | 193 # Get the name of the signal from the title file or from the name of the subdirectory |
212 } | |
213 if (nrow(info) < 1) { | |
214 stop(paste(start, "the info matrix has no row")) | |
215 } | |
216 arg <- info[1,argname] | |
217 if (is.na(arg)) { | |
218 stop(paste(start, "it is NA in the info matrix")) | |
219 } | |
220 } | |
221 return(arg) | |
222 } | |
223 | |
224 | |
225 | |
226 # getTitle ============================================================================== | |
227 | |
228 # Get the name of the signal from the title file or fromt the name of the subdirectory | |
229 # Get the name of the signal from the title file or fromt the name of the subdirectory | |
230 | |
231 getTitle <- function(path, l, subdirs) { | 194 getTitle <- function(path, l, subdirs) { |
232 title <- NULL | 195 title <- NULL |
233 title_file <- file.path(file.path(file.path(path, "pdata"), "1"), "title") | 196 title_file <- file.path(file.path(file.path(path, "pdata"), "1"), "title") |
234 if (file.exists(title_file)) { | 197 if (file.exists(title_file)) { |
235 lines <- readLines(title_file, warn = FALSE) | 198 lines <- readLines(title_file, warn = FALSE) |
236 if (length(lines) >= 1) { | 199 if (length(lines) >= 1) { |
237 first_line <- gsub("^\\s+|\\s+$", "", lines[l]) | 200 first_line <- gsub("^\\s+|\\s+$", "", lines[l]) |
238 if (nchar(first_line) >= 1) { | 201 if (nchar(first_line) >= 1) { |
239 title <- first_line | 202 title <- first_line |
240 } else { | 203 } else { |
241 warning(paste("The", l ,"line of the title file is blank for directory ", | 204 warning(paste("The", l, "line of the title file is blank for directory ", path, "and the (sub)dirs names are used instead")) |
242 path, "and the (sub)dirs names are used instead")) | 205 } |
243 } | 206 } else { |
244 } else { | 207 warning(paste("Title file doesn't exists for directory ", path, "\n the (sub)dirs names are used instead")) |
245 warning(paste("The title file is empty for directory ", path, "and the (sub)dirs names are used instead")) | 208 } |
246 } | 209 } else { |
247 } else { | 210 warning(paste("Title file doesn't exists for directory ", path, "\n the (sub)dirs names are used instead")) |
248 warning(paste("Title file doesn't exists for directory ", path, "\n the (sub)dirs names are used instead")) | 211 } |
249 } | 212 if (is.null(title)) { |
250 if (is.null(title)) { | 213 if (subdirs) { |
251 if(subdirs) { | 214 separator <- .Platform$file.sep |
252 separator <- .Platform$file.sep | 215 path_elem <- strsplit(path, separator)[[1]] |
253 path_elem <- strsplit(path,separator)[[1]] | 216 title <- paste(path_elem[length(path_elem) - 1], path_elem[length(path_elem)], sep = "_") |
254 title <- paste(path_elem[length(path_elem)-1], path_elem[length(path_elem)], sep = "_") | 217 } else { |
255 } else{title <- basename(path)} | 218 title <- basename(path) |
256 } | 219 } |
257 return(title) | 220 } |
258 } | 221 return(title) |
259 | 222 } |
260 | 223 |
261 | 224 # Function to read parameter values for Fid_info in the ReadFids function |
262 | |
263 # readParams ============================================================================== | |
264 # Read parameter values for Fid_info in the ReadFids function | |
265 | |
266 readParams <- function(file, paramsName) { | 225 readParams <- function(file, paramsName) { |
267 | 226 isDigit <- function(c) { |
268 isDigit <- function(c) { | 227 return(suppressWarnings(!is.na(as.numeric(c)))) |
269 return(suppressWarnings(!is.na(as.numeric(c)))) | 228 } |
270 } | 229 lines <- readLines(file) |
271 lines <- readLines(file) | 230 params <- sapply(paramsName, function(x) NULL) |
272 params <- sapply(paramsName, function(x) NULL) | 231 |
273 | 232 for (paramName in paramsName) { |
274 for (paramName in paramsName) { | 233 # Find the line with the parameter I add a '$' '=' in the pattern so that for |
275 # Find the line with the parameter I add a '$' '=' in the pattern so that for | 234 # example 'TD0' is not found where I look for 'TD' and LOCSW and WBSW when I look |
276 # example 'TD0' is not found where I look for 'TD' and LOCSW and WBSW when I look | 235 # for 'SW' |
277 # for 'SW' | 236 pattern <- paste("\\$", paramName, "=", sep = "") |
278 pattern <- paste("\\$", paramName, "=", sep = "") | 237 occurences <- grep(pattern, lines) |
279 occurences <- grep(pattern, lines) | 238 if (length(occurences) == 0L) { |
280 if (length(occurences) == 0L) { | 239 stop(paste(file, "has no field", pattern)) |
281 stop(paste(file, "has no field", pattern)) | 240 } |
282 } | 241 lines <- readLines(file) |
283 if (length(occurences) > 1L) { | 242 params <- sapply(paramsName, function(x) NULL) |
284 warning(paste(file, "has more that one field", pattern, " I take the first one")) | 243 |
285 } | 244 for (paramName in paramsName) { |
286 line <- lines[occurences[1]] | 245 # Find the line with the parameter I add a '$' '=' in the pattern so that for |
287 | 246 # example 'TD0' is not found where I look for 'TD' and LOCSW and WBSW when I look |
288 # Cut beginning and end of the line '##$TD= 65536' -> '65536' | 247 # for 'SW' |
289 igual = as.numeric(regexpr("=", line)) | 248 pattern <- paste("\\$", paramName, "=", sep = "") |
290 | 249 occurences <- grep(pattern, lines) |
291 first <- igual | 250 if (length(occurences) == 0L) { |
292 while (first <= nchar(line) & !isDigit(substr(line, first, first))) { | 251 stop(paste(file, "has no field", pattern)) |
293 first <- first + 1 | 252 } |
294 } | 253 if (length(occurences) > 1L) { |
295 last <- nchar(line) | 254 warning(paste(file, "has more that one field", pattern, " I take the first one")) |
296 while (last > 0 & !isDigit(substr(line, last, last))) { | 255 } |
297 last <- last - 1 | 256 line <- lines[occurences[1]] |
298 } | 257 |
299 params[paramName] <- as.numeric(substr(line, first, last)) | 258 # Cut beginning and end of the line '##$TD= 65536' -> '65536' |
300 } | 259 igual <- as.numeric(regexpr("=", line)) |
301 return(params) | 260 |
302 } | 261 first <- igual |
303 | 262 while (first <= nchar(line) & !isDigit(substr(line, first, first))) { |
304 | 263 first <- first + 1 |
305 | 264 } |
306 # ReadFids ============================================================================== | 265 last <- nchar(line) |
307 | 266 while (last > 0 & !isDigit(substr(line, last, last))) { |
267 last <- last - 1 | |
268 } | |
269 params[paramName] <- as.numeric(substr(line, first, last)) | |
270 } | |
271 line <- lines[occurences[1]] | |
272 | |
273 # Cut beginning and end of the line '##$TD= 65536' -> '65536' | |
274 igual <- as.numeric(regexpr("=", line)) | |
275 | |
276 first <- igual | |
277 while (first <= nchar(line) & !isDigit(substr(line, first, first))) { | |
278 first <- first + 1 | |
279 } | |
280 last <- nchar(line) | |
281 while (last > 0 & !isDigit(substr(line, last, last))) { | |
282 last <- last - 1 | |
283 } | |
284 params[paramName] <- as.numeric(substr(line, first, last)) | |
285 } | |
286 return(params) | |
287 } | |
288 | |
289 # Function to read all fid's in the directory | |
308 ReadFids <- function(path, l = 1, subdirs = FALSE, dirs.names = FALSE) { | 290 ReadFids <- function(path, l = 1, subdirs = FALSE, dirs.names = FALSE) { |
309 | 291 # Data initialisation and checks |
310 # Data initialisation and checks ---------------------------------------------- | 292 begin_info <- beginTreatment("ReadFids") |
311 begin_info <- beginTreatment("ReadFids") | 293 checkArg(path, c("str")) |
312 checkArg(path, c("str")) | 294 checkArg(l, c("pos")) |
313 checkArg(l, c("pos")) | 295 if (file.exists(path) == FALSE) { |
314 if (file.exists(path) == FALSE) { | 296 stop(paste("Invalid path:", path)) |
315 stop(paste("Invalid path:", path)) | 297 } |
316 } | 298 |
317 | 299 # Extract the FIDs and their info |
318 | 300 if (subdirs == FALSE) { |
319 # Extract the FIDs and their info ---------------------------------------------- | 301 fidDirs <- getDirsContainingFid(path) |
320 | 302 n <- length(fidDirs) |
321 if (subdirs == FALSE) { | 303 if (n == 0L) { |
322 fidDirs <- getDirsContainingFid(path) | 304 stop(paste("No valid fid in", path)) |
323 n <- length(fidDirs) | 305 } |
324 if (n == 0L) { | 306 if (dirs.names) { |
325 stop(paste("No valid fid in", path)) | 307 separator <- .Platform$file.sep |
326 } | 308 path_elem <- strsplit(fidDirs, separator) |
327 if (dirs.names) { | 309 fidNames <- sapply(path_elem, function(x) x[[length(path_elem[[1]])]]) |
328 separator <- .Platform$file.sep | 310 } else { |
329 path_elem <- strsplit(fidDirs,separator) | 311 fidNames <- sapply(X = fidDirs, FUN = getTitle, l = l, subdirs = subdirs, USE.NAMES = F) |
330 fidNames <- sapply(path_elem, function(x) x[[length(path_elem[[1]])]]) | 312 } |
331 }else {fidNames <- sapply(X = fidDirs, FUN = getTitle, l = l, subdirs = subdirs, USE.NAMES = F)} | 313 |
332 | 314 for (i in 1:n) { |
333 for (i in 1:n) { | 315 fidList <- ReadFid(fidDirs[i]) |
334 fidList <- ReadFid(fidDirs[i]) | 316 fid <- fidList[["fid"]] |
335 fid <- fidList[["fid"]] | 317 info <- fidList[["params"]] |
336 info <- fidList[["params"]] | 318 m <- length(fid) |
337 m <- length(fid) | 319 if (i == 1) { |
338 if (i == 1) { | 320 Fid_data <- matrix(nrow = n, ncol = m, dimnames = list(fidNames, info[["DT"]] * (0:(m - 1)))) |
339 Fid_data <- matrix(nrow = n, ncol = m, dimnames = list(fidNames, | 321 Fid_info <- matrix(nrow = n, ncol = length(info), dimnames = list(fidNames, names(info))) |
340 info[["DT"]] * (0:(m - 1)))) | 322 } |
341 Fid_info <- matrix(nrow = n, ncol = length(info), dimnames = list(fidNames, | 323 Fid_data[i, ] <- fid |
342 names(info))) | 324 Fid_info[i, ] <- unlist(info) |
343 } | 325 } |
344 Fid_data[i, ] <- fid | 326 } else { |
345 Fid_info[i, ] <- unlist(info) | 327 maindirs <- dir(path, full.names = TRUE) # subdirectories |
346 } | 328 Fid_data <- numeric() |
347 | 329 Fid_info <- numeric() |
348 } else { | 330 |
349 maindirs <- dir(path, full.names = TRUE) # subdirectories | 331 fidDirs <- c() |
350 Fid_data <- numeric() | 332 for (j in maindirs) { |
351 Fid_info <- numeric() | 333 fd <- getDirsContainingFid(j) # recoved FIDs from subdirectories |
352 | 334 n <- length(fd) |
353 fidDirs <- c() | 335 if (n > 0L) { |
354 for (j in maindirs) { | 336 fidDirs <- c(fidDirs, fd) |
355 fd <- getDirsContainingFid(j) # recoved FIDs from subdirectories | 337 } else { |
356 n <- length(fd) | 338 warning(paste("No valid fid in", j)) |
357 if (n > 0L) { | 339 } |
358 fidDirs <- c(fidDirs, fd) | 340 } |
359 } else {warning(paste("No valid fid in",j ))} | 341 |
360 } | 342 if (dirs.names == TRUE) { |
361 | 343 if (length(fidDirs) != length(dir(path))) { # at least one subdir contains more than 1 FID |
362 if (dirs.names==TRUE) { | 344 separator <- .Platform$file.sep |
363 if (length(fidDirs)!= length(dir(path))) { # at least one subdir contains more than 1 FID | 345 path_elem <- strsplit(fidDirs, separator) |
364 separator <- .Platform$file.sep | 346 fidNames <- sapply(path_elem, function(x) paste(x[[length(path_elem[[1]]) - 1]], x[[length(path_elem[[1]])]], sep = "_")) |
365 path_elem <- strsplit(fidDirs,separator) | 347 } else { |
366 fidNames <- sapply(path_elem, function(x) paste(x[[length(path_elem[[1]])-1]], | 348 fidNames <- dir(path) |
367 x[[length(path_elem[[1]])]], sep = "_")) | 349 } |
368 }else {fidNames <- dir(path)} | 350 } else { |
369 | 351 fidNames <- sapply(X = fidDirs, FUN = getTitle, l = l, subdirs = subdirs, USE.NAMES = F) |
370 } else {fidNames <- sapply(X = fidDirs, FUN = getTitle, l = l, subdirs = subdirs, USE.NAMES = F)} | 352 } |
371 | 353 |
372 for (i in 1:length(fidNames)) { | 354 for (i in 1:length(fidNames)) { |
373 fidList <- ReadFid(fidDirs[i]) | 355 fidList <- ReadFid(fidDirs[i]) |
374 fid <- fidList[["fid"]] | 356 fid <- fidList[["fid"]] |
375 info <- fidList[["params"]] | 357 info <- fidList[["params"]] |
376 m <- length(fid) | 358 m <- length(fid) |
377 if (i == 1) { | 359 if (i == 1) { |
378 Fid_data <- matrix(nrow = length(fidNames), ncol = m, dimnames = list(fidNames, | 360 Fid_data <- matrix(nrow = length(fidNames), ncol = m, dimnames = list(fidNames, info[["DT"]] * (0:(m - 1)))) |
379 info[["DT"]] * (0:(m - 1)))) | 361 Fid_info <- matrix(nrow = length(fidNames), ncol = length(info), dimnames = list(fidNames, names(info))) |
380 Fid_info <- matrix(nrow = length(fidNames), ncol = length(info), dimnames = list(fidNames, | 362 } |
381 names(info))) | 363 print(paste("i=", i, "Fid_data=", ncol(Fid_data), "fid=", length(fid))) |
382 } | 364 |
383 Fid_data[i, ] <- fid | 365 Fid_data[i, ] <- fid |
384 Fid_info[i, ] <- unlist(info) | 366 Fid_info[i, ] <- unlist(info) |
385 } | 367 } |
386 | 368 } |
387 | 369 |
388 } | 370 # Check for non-unique IDs |
389 | 371 NonnuniqueIds <- sum(duplicated(row.names(Fid_data))) |
390 # Check for non-unique IDs ---------------------------------------------- | 372 cat("dim Fid_data: ", dim(Fid_data), "\n") |
391 NonnuniqueIds <- sum(duplicated(row.names(Fid_data))) | 373 cat("IDs: ", rownames(Fid_data), "\n") |
392 cat("dim Fid_data: ", dim(Fid_data), "\n") | 374 cat("non-unique IDs?", NonnuniqueIds, "\n") |
393 cat("IDs: ", rownames(Fid_data), "\n") | 375 if (NonnuniqueIds > 0) { |
394 cat("non-unique IDs?", NonnuniqueIds, "\n") | 376 warning("There are duplicated IDs: ", Fid_data[duplicated(Fid_data)]) |
395 if (NonnuniqueIds > 0) { | 377 } |
396 warning("There are duplicated IDs: ", Fid_data[duplicated(Fid_data)]) | 378 |
397 } | 379 # Return the results |
398 | 380 return(list(Fid_data = endTreatment("ReadFids", begin_info, Fid_data), Fid_info = Fid_info)) |
399 | 381 } |
400 # Return the results ---------------------------------------------- | |
401 return(list(Fid_data = endTreatment("ReadFids", begin_info, Fid_data), Fid_info = Fid_info)) | |
402 | |
403 } | |
404 |