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