/
mrs_data_proc.R
4556 lines (3714 loc) · 136 KB
/
mrs_data_proc.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
check_mrs_data <- function(mrs_data) {
if (inherits(mrs_data, "mrs_data", which = TRUE) == 1) {
return()
} else if (inherits(mrs_data, "list", which = TRUE) == 1) {
if (inherits(mrs_data[[1]], "mrs_data")) {
stop("Error, input is a list of mrs_data objects. Please only pass a
single mrs_data object to this function.")
} else {
stop("Error, input is not mrs_data class.")
}
} else {
stop("Error, input is not mrs_data class.")
}
}
#' Simulate a MRS data object containing a set of simulated resonances.
#' @param freq resonance frequency.
#' @param amp resonance amplitude.
#' @param lw line width in Hz.
#' @param lg Lorentz-Gauss lineshape parameter (between 0 and 1).
#' @param phase phase in degrees.
#' @param freq_ppm frequencies are given in ppm units if set to TRUE, otherwise
#' Hz are assumed.
#' @param acq_paras list of acquisition parameters. See
#' \code{\link{def_acq_paras}}
#' @param fp_scale multiply the first data point by 0.5.
#' @param back_extrap_pts number of data points to back extrapolate.
#' @param sum_resonances sum all resonances (default is TRUE), otherwise return
#' a dynamic mrs_data object.
#' @return MRS data object.
#' @examples
#' sim_data <- sim_resonances(freq = 2, lw = 5)
#' @export
sim_resonances <- function(freq = 0, amp = 1, lw = 0, lg = 0, phase = 0,
freq_ppm = TRUE, acq_paras = def_acq_paras(),
fp_scale = TRUE, back_extrap_pts = 0,
sum_resonances = TRUE) {
if (inherits(acq_paras, "mrs_data")) acq_paras <- get_acq_paras(acq_paras)
sig_n <- length(freq)
if (sig_n != length(amp)) {
if (length(amp) != 1) warning("amp length is not the same as freq length")
amp <- rep_len(amp, sig_n)
}
if (sig_n != length(lw)) {
if (length(lw) != 1) warning("lw length is not the same as freq length")
lw <- rep_len(lw, sig_n)
}
if (sig_n != length(phase)) {
if (length(phase) != 1) {
warning("phase length is not the same as freq length")
}
phase <- rep_len(phase, sig_n)
}
if (sig_n != length(lg)) {
if (length(lg) != 1) warning("lg length is not the same as freq length")
lg <- rep_len(lg, sig_n)
}
# generate data in TD
t <- seq(from = -back_extrap_pts / acq_paras$fs,
to = (acq_paras$N - 1) / acq_paras$fs, by = 1 / acq_paras$fs)
# covert freqs to Hz
if (freq_ppm) {
f_hz <- (acq_paras$ref - freq) * acq_paras$ft / 1e6
} else {
f_hz <- freq
}
data <- matrix(NA, sig_n, acq_paras$N + back_extrap_pts)
for (n in 1:sig_n) {
data[n,] <- amp[n] * exp(1i * pi * phase[n] / 180 + 2i * pi * f_hz[n] * t)
# LG peak model
data[n,] <- data[n,] * ((1 - lg[n]) * exp(-lw[n] * t * pi) +
lg[n] * exp(-lw2beta(lw[n]) * t * t))
}
# first point correction
if (fp_scale) data[, 1] <- data[, 1] * 0.5
mrs_data <- mat2mrs_data(data, fs = acq_paras$fs, ft = acq_paras$ft,
ref = acq_paras$ref, nuc = acq_paras$nuc,
fd = FALSE)
if (sum_resonances) mrs_data <- sum_dyns(mrs_data)
return(mrs_data)
}
sim_resonances_fast <- function(freq = 0, amp = 1, freq_ppm = TRUE,
N = def_N(), fs = def_fs(), ft = def_ft(),
ref = def_ref(), nuc = def_nuc()) {
sig_n <- length(freq)
if (sig_n != length(amp)) {
amp <- rep_len(amp, sig_n)
}
# generate data in TD
t <- seq(from = 0, to = (N - 1) / fs, by = 1 / fs)
# covert freqs to Hz
if (freq_ppm) {
f_hz <- (ref - freq) * ft / 1e6
} else {
f_hz <- freq
}
data <- rep(0, N)
for (n in 1:sig_n) {
temp_data <- amp[n] * exp(2i * pi * f_hz[n] * t)
data <- data + temp_data
}
# first point correction
data[1] <- data[1] * 0.5
data <- array(data,dim = c(1, 1, 1, 1, 1, 1, N))
res <- c(NA, NA, NA, NA, NA, NA, 1 / fs)
mrs_data <- mrs_data(data = data, ft = ft, resolution = res, ref = ref,
nuc = nuc, freq_domain = rep(FALSE, 7), affine = NULL,
meta = NULL, extra = NULL)
return(mrs_data)
}
sim_resonances_fast2 <- function(freq = 0, amp = 1, freq_ppm = TRUE,
N = def_N(), fs = def_fs(), ft = def_ft(),
ref = def_ref(), nuc = def_nuc()) {
sig_n <- length(freq)
if (sig_n != length(amp)) {
amp <- rep_len(amp, sig_n)
}
# covert freqs to Hz
if (freq_ppm) {
f_hz <- (ref - freq) * ft / 1e6
} else {
f_hz <- freq
}
# generate data in TD
t <- seq(from = 0, to = (N - 1) / fs, by = 1 / fs)
t_i_omega <- t * 2i * pi
# TODO should be able to loose a tranpose here
t_i_omega_mat <- matrix(t_i_omega, nrow = N, ncol = sig_n)
f_hz_mat <- matrix(f_hz, nrow = N, ncol = sig_n, byrow = TRUE)
temp <- t_i_omega_mat * f_hz_mat
#temp <- t(t(t_i_omega_mat) * f_hz)
td_sig <- exp(temp)
#td_sig <- matrix(exp(as.vector(temp)), nrow = N, ncol = sig_n, byrow = FALSE)
#expp <- exp(1)
#e <- matrix(expp, nrow = N, ncol = sig_n)
#td_sig <- e ^ temp
data <- td_sig %*% amp
# first point correction
data[1] <- data[1] * 0.5
data <- array(data, dim = c(1, 1, 1, 1, 1, 1, N))
res <- c(NA, NA, NA, NA, NA, NA, 1 / fs)
mrs_data <- mrs_data(data = data, ft = ft, resolution = res, ref = ref,
nuc = nuc, freq_domain = rep(FALSE, 7), affine = NULL,
meta = NULL, extra = NULL)
return(mrs_data)
}
#' Convert a vector into a mrs_data object.
#' @param vec the data vector.
#' @param fs sampling frequency in Hz.
#' @param ft transmitter frequency in Hz.
#' @param ref reference value for ppm scale.
#' @param nuc resonant nucleus.
#' @param dyns replicate the data across the dynamic dimension.
#' @param fd flag to indicate if the matrix is in the frequency domain (logical).
#' @return mrs_data object.
#' @export
vec2mrs_data <- function(vec, fs = def_fs(), ft = def_ft(), ref = def_ref(),
nuc = def_nuc(), dyns = 1, fd = FALSE) {
data <- array(vec, dim = c(length(vec), dyns))
data <- aperm(data,c(2, 1))
dim(data) <- c(1, 1, 1, 1, dyns, 1, length(vec))
res <- c(NA, NA, NA, NA, NA, NA, 1 / fs)
mrs_data <- mrs_data(data = data, ft = ft, resolution = res, ref = ref,
nuc = nuc, freq_domain = c(rep(FALSE, 6), fd),
affine = NULL, meta = NULL, extra = NULL)
return(mrs_data)
}
#' Convert a 7 dimensional array in into a mrs_data object. The array dimensions
#' should be ordered as : dummy, X, Y, Z, dynamic, coil, FID.
#' @param data_array 7d data array.
#' @param fs sampling frequency in Hz.
#' @param ft transmitter frequency in Hz.
#' @param ref reference value for ppm scale.
#' @param nuc nucleus that is resonant at the transmitter frequency.
#' @param fd flag to indicate if the matrix is in the frequency domain (logical).
#' @return mrs_data object.
#' @export
array2mrs_data <- function(data_array, fs = def_fs(), ft = def_ft(),
ref = def_ref(), nuc = def_nuc(), fd = FALSE) {
if (length(dim(data_array)) != 7) stop("Incorrect number of dimensions.")
res <- c(NA, NA, NA, NA, NA, NA, 1 / fs)
mrs_data <- mrs_data(data = data_array, ft = ft, resolution = res, ref = ref,
nuc = nuc, freq_domain = c(rep(FALSE, 6), fd),
affine = NULL, meta = NULL, extra = NULL)
return(mrs_data)
}
#' Convert mrs_data object to a matrix, with spectral points in the column
#' dimension and dynamics in the row dimension.
#' @param mrs_data MRS data object or list of MRS data objects.
#' @param collapse collapse all other dimensions along the dynamic dimension, eg
#' a 16x16 MRSI grid would be first collapsed across 256 dynamic scans.
#' @return MRS data matrix.
#' @export
mrs_data2mat <- function(mrs_data, collapse = TRUE) {
if (inherits(mrs_data, "list")) mrs_data <- append_dyns(mrs_data)
if (collapse) mrs_data <- collapse_to_dyns(mrs_data)
as.matrix(mrs_data$data[1,1,1,1,,1,])
}
#' Convert mrs_data object to a vector.
#' @param mrs_data MRS data object.
#' @param dyn dynamic index.
#' @param x_pos x index.
#' @param y_pos y index.
#' @param z_pos z index.
#' @param coil coil element index.
#' @return MRS data vector.
#' @export
mrs_data2vec <- function(mrs_data, dyn = 1, x_pos = 1,
y_pos = 1, z_pos = 1, coil = 1) {
# check the input
check_mrs_data(mrs_data)
as.vector(mrs_data$data[1, x_pos, y_pos, z_pos, dyn, coil,])
}
#' Convert a matrix (with spectral points in the column dimension and dynamics
#' in the row dimensions) into a mrs_data object.
#' @param mat data matrix.
#' @param fs sampling frequency in Hz.
#' @param ft transmitter frequency in Hz.
#' @param ref reference value for ppm scale.
#' @param nuc resonant nucleus.
#' @param fd flag to indicate if the matrix is in the frequency domain (logical).
#' @return mrs_data object.
#' @export
mat2mrs_data <- function(mat, fs = def_fs(), ft = def_ft(), ref = def_ref(),
nuc = def_nuc(), fd = FALSE) {
data <- array(mat, dim = c(1, 1, 1, 1, nrow(mat), 1, ncol(mat)))
res <- c(NA, NA, NA, NA, NA, NA, 1 / fs)
mrs_data <- mrs_data(data = data, ft = ft, resolution = res, ref = ref,
nuc = nuc, freq_domain = c(rep(FALSE, 6), fd),
affine = NULL, meta = NULL, extra = NULL)
return(mrs_data)
}
#' Simulate an mrs_data object containing simulated Gaussian noise.
#' @param sd standard deviation of the noise.
#' @param fs sampling frequency in Hz.
#' @param ft transmitter frequency in Hz.
#' @param N number of data points in the spectral dimension.
#' @param ref reference value for ppm scale.
#' @param dyns number of dynamic scans to generate.
#' @param fd return data in the frequency-domain (TRUE) or time-domain (FALSE)
#' @return mrs_data object.
#' @export
sim_noise <- function(sd = 0.1, fs = def_fs(), ft = def_ft(), N = def_N(),
ref = def_ref(), dyns = 1, fd = TRUE) {
data_pts <- dyns * N
vec <- stats::rnorm(data_pts, 0, sd) + 1i*stats::rnorm(data_pts, 0, sd)
data_array <- array(vec, dim = c(1, 1, 1, 1, dyns, 1, N))
array2mrs_data(data_array, fs = fs, ft = ft, ref = ref, fd = fd)
}
#' Add noise to an mrs_data object.
#' @param mrs_data data to add noise to.
#' @param sd standard deviation of the noise.
#' @param fd generate the noise samples in the frequency-domain (TRUE) or
#' time-domain (FALSE). This is required since the absolute value of the
#' standard deviation of noise samples changes when data is Fourier transformed.
#' @return mrs_data object with additive normally distributed noise.
#' @export
add_noise <- function(mrs_data, sd = 0.1, fd = TRUE) {
# covert data to the frequency domain if needed
if (fd & !is_fd(mrs_data)) mrs_data <- td2fd(mrs_data)
# covert data to the time domain if needed
if (!fd & is_fd(mrs_data)) mrs_data <- fd2td(mrs_data)
data_pts <- length(mrs_data$data)
noise <- stats::rnorm(data_pts, 0, sd) + 1i*stats::rnorm(data_pts, 0, sd)
mrs_data$data <- mrs_data$data + noise
mrs_data
}
#' Simulate an mrs_data object containing complex zero valued samples.
#' @param fs sampling frequency in Hz.
#' @param ft transmitter frequency in Hz.
#' @param N number of data points in the spectral dimension.
#' @param ref reference value for ppm scale.
#' @param dyns number of dynamic scans to generate.
#' @return mrs_data object.
#' @export
sim_zero <- function(fs = def_fs(), ft = def_ft(), N = def_N(),
ref = def_ref(), dyns = 1) {
data_pts <- dyns * N
vec <- rep(0, data_pts) * 1i
data_array <- array(vec, dim = c(1, 1, 1, 1, dyns, 1, N))
array2mrs_data(data_array, fs = fs, ft = ft, ref = ref)
}
#' Apply a function across given dimensions of a MRS data object.
#' @param mrs_data MRS data.
#' @param dims dimensions to apply the function.
#' @param fun name of the function.
#' @param ... arguments to the function.
#' @param data_only return an array rather than an MRS data object.
#' @export
apply_mrs <- function(mrs_data, dims, fun, ..., data_only = FALSE) {
# check the input
check_mrs_data(mrs_data)
dims <- sort(dims)
margins <- c(1:7)[-dims]
mrs_data$data <- plyr::aaply(mrs_data$data, margins, fun, ..., .drop = FALSE)
perm_vec <- 1:(7 - length(dims))
for (n in (1:length(dims))) {
perm_vec <- append(perm_vec, (n + 7 - length(dims)), after = dims[n] - 1)
}
#print(perm_vec)
mrs_data$data <- aperm(mrs_data$data, perm_vec)
if (data_only == FALSE) {
return(mrs_data)
} else {
return(mrs_data$data)
}
}
#' Apply a frequency shift to MRS data.
#' @param mrs_data MRS data.
#' @param shift frequency shift (in ppm by default).
#' @param units of the shift ("ppm" or "hz").
#' @return frequency shifted MRS data.
#' @export
shift <- function(mrs_data, shift, units = "ppm") {
# covert to time-domain
if (is_fd(mrs_data)) mrs_data <- fd2td(mrs_data)
if (units == "hz") {
shift_hz <- shift
} else if (units == "ppm") {
shift_hz <- ppm2hz(shift, mrs_data$ft, 0)
} else {
stop("Error, did not recognise the units.")
}
t_orig <- rep(seconds(mrs_data), each = Nspec(mrs_data))
t_array <- array(t_orig, dim = dim(mrs_data$data))
if (length(shift_hz) == 1) {
shift_array <- array(shift_hz, dim = dim(mrs_data$data))
} else if (length(shift_hz) == Ndyns(mrs_data)) {
# assume array should be applied in the dynamic dimension
shift_array <- array(shift_hz, dim = c(1, 1, 1, 1, Ndyns(mrs_data), 1,
Npts(mrs_data)))
} else if (dim(shift_hz)[1:6] && dim(mrs_data$data)[1:6]) {
shift_array <- array(shift_hz, dim = dim(mrs_data$data))
} else {
stop("Shift vector has an incorrect dimensions.")
}
shift_array <- exp(2i * pi * t_array * shift_array)
mrs_data$data <- mrs_data$data * shift_array
mrs_data
}
#' Apply phasing parameters to MRS data.
#' @param mrs_data MRS data.
#' @param zero_order zero'th order phase term in degrees.
#' @param first_order first order (frequency dependent) phase term in ms.
#' @return MRS data with applied phase parameters.
#' @export
phase <- function(mrs_data, zero_order, first_order = 0) {
if (inherits(mrs_data, "list")) {
res <- lapply(mrs_data, phase, zero_order = zero_order,
first_order = first_order)
return(res)
}
# check the input
check_mrs_data(mrs_data)
if ((first_order == 0) && (length(zero_order) == 1)) {
# single zero order phase term given
mrs_data$data <- mrs_data$data * exp(1i * zero_order * pi / 180)
} else if ((first_order == 0) && (is.null(dim(zero_order)))) {
# array of zero order phase terms given
if (length(zero_order) != Ndyns(mrs_data)) {
stop("Shift vector has an incorrect length.")
}
# assume array should be applied in the dynamic dimension
phase_array <- array(zero_order, dim = c(1, 1, 1, 1, Ndyns(mrs_data), 1,
Npts(mrs_data)))
mrs_data$data = mrs_data$data * exp(1i * phase_array * pi / 180)
} else if ((first_order == 0) && identical(dim(zero_order)[1:6],
dim(mrs_data$data)[1:6])) {
phase_array <- array(rep(zero_order, Npts(mrs_data)),
dim = dim(mrs_data$data))
mrs_data$data <- mrs_data$data * exp(1i * phase_array * pi / 180)
} else if ((length(zero_order) == 1) && (first_order != 0)) {
freq <- rep(hz(mrs_data), each = Nspec(mrs_data))
freq_mat <- array(freq, dim = dim(mrs_data$data))
# needs to be a freq-domain operation
if (!is_fd(mrs_data)) {
mrs_data <- td2fd(mrs_data)
}
mrs_data$data = mrs_data$data * exp(2i * pi * (zero_order / 360 - freq_mat
* first_order / 1000))
} else {
stop("Unsupported input options.")
}
return(mrs_data)
}
#' Perform a zeroth order phase correction based on the phase of the first data
#' point in the time-domain.
#' @param mrs_data MRS data to be corrected.
#' @param ret_phase return phase values (logical).
#' @return corrected data or a list with corrected data and optional phase
#' values.
#' @export
fp_phase_correct <- function(mrs_data, ret_phase = FALSE) {
if (inherits(mrs_data, "list")) {
return(lapply(mrs_data, fp_phase_correct, ret_phase = ret_phase))
}
# needs to be a time-domain operation
if (is_fd(mrs_data)) mrs_data <- fd2td(mrs_data)
phases <- Arg(mrs_data$data[,,,,,, 1, drop = F])
mrs_data$data <- mrs_data$data * array(exp(-1i * phases), dim = dim(mrs_data))
if (ret_phase) {
return(list(mrs_data, 180 / pi * abind::adrop(phases, 7)))
} else {
return(mrs_data)
}
}
#' Return the first time-domain data point.
#' @param mrs_data MRS data.
#' @return first time-domain data point.
#' @export
get_fp <- function(mrs_data) {
# needs to be a time-domain operation
if (is_fd(mrs_data)) mrs_data <- fd2td(mrs_data)
# drop the chem shift dimension
mrs_data$data[,,,,,, 1, drop = F]
}
#' Scale the first time-domain data point in an mrs_data object.
#' @param mrs_data MRS data.
#' @param scale scaling value, defaults to 0.5.
#' @return scaled mrs_data object.
#' @export
fp_scale <- function(mrs_data, scale = 0.5) {
# needs to be a time-domain operation
if (is_fd(mrs_data)) mrs_data <- fd2td(mrs_data)
# drop the chem shift dimension
mrs_data$data[,,,,,, 1] <- mrs_data$data[,,,,,, 1] * scale
return(mrs_data)
}
fp_mag <- function(mrs_data) {
# needs to be a time-domain operation
if (is_fd(mrs_data)) mrs_data <- fd2td(mrs_data)
# drop the chem shift dimension
abind::adrop(Mod(mrs_data$data[,,,,,, 1, drop = F]), 7)
}
#' Convolve two MRS data objects.
#' @param mrs_data MRS data to be convolved.
#' @param conv convolution data stored as an mrs_data object.
#' @return convolved data.
#' @export
conv_mrs <- function(mrs_data, conv) {
# needs to be a time-domain operation
if (is_fd(mrs_data)) mrs_data <- fd2td(mrs_data)
if (is_fd(conv)) conv <- fd2td(conv)
if (Ndyns(mrs_data) > 1) {
warning("Repeating convolution data to match mrs_data dynamics.")
conv <- rep_dyn(conv, Ndyns(mrs_data))
}
return(mrs_data * conv)
}
#' Deconvolve two MRS data objects.
#' @param mrs_data_a MRS data to be deconvolved.
#' @param mrs_data_b MRS data to be deconvolved.
#' @return deconvolved data.
#' @export
deconv_mrs <- function(mrs_data_a, mrs_data_b) {
# needs to be a time-domain operation
if (is_fd(mrs_data_a)) mrs_data_a <- fd2td(mrs_data_a)
if (is_fd(mrs_data_b)) mrs_data_b <- fd2td(mrs_data_b)
return(mrs_data_b / mrs_data_a)
}
#' Return the phase of the first data point in the time-domain.
#' @param mrs_data MRS data.
#' @return phase values in degrees.
#' @export
fp_phase <- function(mrs_data) {
# needs to be a time-domain operation
if (is_fd(mrs_data)) mrs_data <- fd2td(mrs_data)
# drop the chem shift dimension
abind::adrop(Arg(mrs_data$data[,,,,,, 1, drop = F]), 7) * 180 / pi
}
#' Apply line-broadening (apodisation) to MRS data or basis object.
#' @param x input mrs_data or basis_set object.
#' @param lb amount of line-broadening in Hz.
#' @param lg Lorentz-Gauss lineshape parameter (between 0 and 1).
#' @return line-broadened data.
#' @rdname lb
#' @export
lb <- function(x, lb, lg = 1) UseMethod("lb")
#' @rdname lb
#' @export
lb.list <- function(x, lb, lg = 1) {
res <- lapply(x, lb, lb = lb, lg = lg)
return(res)
}
#' @rdname lb
#' @export
lb.mrs_data <- function(x, lb, lg = 1) {
if (lg > 1 | lg < 0) {
cat("Error, lg values not between 0 and 1.")
stop()
}
# collapse to simplify
lb <- as.vector(drop(lb))
lg <- as.vector(drop(lg))
orig_dim <- dim(x$data)
orig_dimnames <- dimnames(x$data)
x <- collapse_to_dyns(x)
# needs to be a time-domain operation
if (is_fd(x)) {
x <- fd2td(x)
}
t <- rep(seconds(x), each = Nspec(x))
if (lg < 1) x$data = x$data * exp(-(1 - lg) * lb * t * pi)
if (lg > 0) {
sign <- ifelse(lb > 0, 1, -1)
x$data = x$data * exp((sign * lg * lb ^ 2 * pi ^ 2 / 4 / log(0.5)) *
(t ^ 2))
}
# revert back to original dims and unname
dim(x$data) <- orig_dim
return(x)
}
#' @rdname lb
#' @export
lb.basis_set <- function(x, lb, lg = 1) {
mrs_data2basis(lb(basis2mrs_data(x), lb, lg), x$names)
}
#' Apply a weighting to the FID to enhance spectral resolution.
#' @param mrs_data data to be enhanced.
#' @param re resolution enhancement factor (rising exponential factor).
#' @param alpha alpha factor (Gaussian decay)
#' @return resolution enhanced mrs_data.
#' @export
re_weighting <- function(mrs_data, re, alpha) {
if (inherits(mrs_data, "list")) {
return(lapply(mrs_data, re_weighting, re = re, alpha = alpha))
}
# needs to be a time-domain operation
if (is_fd(mrs_data)) mrs_data <- fd2td(mrs_data)
t <- rep(seconds(mrs_data), each = Nspec(mrs_data))
mrs_data$data = mrs_data$data * exp(re * t) * exp(-alpha * t ^ 2)
return(mrs_data)
}
#' Smooth data across the dynamic dimension with a Gaussian kernel.
#' @param mrs_data data to be smoothed.
#' @param sigma standard deviation of the underlying Gaussian kernel in seconds.
#' @return smoothed mrs_data object.
#' @export
smooth_dyns <- function(mrs_data, sigma) {
if (inherits(mrs_data, "list")) {
return(lapply(mrs_data, smooth_dyns, sigma = sigma))
}
if (is.na(tr(mrs_data)) | is.null(tr(mrs_data))) {
stop("TR not set, use set_tr function to set the repetition time.")
}
# covert data to the frequency domain if needed
if (!is_fd(mrs_data)) mrs_data <- td2fd(mrs_data)
if (sigma == 0) return(mrs_data)
# generate a 1D Gaussian kernel
gaus_ker <- mmand::gaussianKernel(sigma / tr(mrs_data))
# expand to 7D
dim(gaus_ker) <- c(1, 1, 1, 1, length(gaus_ker), 1, 1)
# apply to Re and Im parts separately
mrs_data$data <- mmand::morph(Re(mrs_data$data), gaus_ker,
operator = "*", merge = "sum") +
1i * mmand::morph(Im(mrs_data$data), gaus_ker,
operator = "*", merge = "sum")
return(mrs_data)
}
#' Zero-fill MRS data in the time domain.
#' @param x input mrs_data or basis_set object.
#' @param factor zero-filling factor, factor of 2 returns a dataset with
#' twice the original data points.
#' @param offset number of points from the end of the FID to insert the zero
#' values.
#' @return zero-filled data.
#' @rdname zf
#' @export
zf <- function(x, factor = 2, offset = 0) UseMethod("zf")
#' @rdname zf
#' @export
zf.list <- function(x, factor = 2, offset = 0) {
lapply(x, zf, factor = factor, offset = offset)
}
#' @rdname zf
#' @export
zf.mrs_data <- function(x, factor = 2, offset = 0) {
# needs to be a time-domain operation
if (is_fd(x)) x <- fd2td(x)
pts_orig <- Npts(x)
pts <- factor * pts_orig
data_dim <- dim(x$data)
zero_dim <- data_dim
zero_dim[7] <- pts - data_dim[7]
zero_array <- array(0, dim = zero_dim)
x$data = abind::abind(x$data, zero_array, along = 7)
if (offset > 0) {
orig_inds <- (pts_orig - offset + 1):pts_orig
new_inds <- (pts - offset + 1):pts
x$data[,,,,,,new_inds] <- x$data[,,,,,,orig_inds]
x$data[,,,,,,orig_inds] <- 0
}
dimnames(x$data) <- NULL
return(x)
}
#' @rdname zf
#' @export
zf.basis_set <- function(x, factor = 2, offset = 0) {
x_mrs_data <- basis2mrs_data(x)
mrs_data2basis(set_td_pts(x_mrs_data, factor * Npts(x_mrs_data)), x$names)
}
#' Set the number of time-domain data points, truncating or zero-filling as
#' appropriate.
#' @param mrs_data MRS data.
#' @param pts number of data points.
#' @return MRS data with pts data points.
#' @export
set_td_pts <- function(mrs_data, pts) {
if (inherits(mrs_data, "list")) {
res <- lapply(mrs_data, set_td_pts, pts = pts)
return(res)
}
# needs to be a time-domain operation
if (is_fd(mrs_data)) mrs_data <- fd2td(mrs_data)
data_dim <- dim(mrs_data$data)
if (data_dim[7] > pts) {
data_dim_trunc <- data_dim
data_dim_trunc[7] <- pts
mrs_data$data = array(mrs_data$data, data_dim_trunc)
} else if (data_dim[7] < pts) {
zero_dim <- data_dim
zero_dim[7] <- pts - data_dim[7]
zero_array <- array(0, dim = zero_dim)
mrs_data$data = abind::abind(mrs_data$data, zero_array, along = 7)
}
dimnames(mrs_data$data) <- NULL
return(mrs_data)
}
#' Set the ppm reference value (eg ppm value at 0Hz).
#' @param mrs_data MRS data.
#' @param ref reference value for ppm scale.
#' @export
set_ref <- function(mrs_data, ref) {
if (inherits(mrs_data, "list")) {
res <- lapply(mrs_data, set_ref, ref = ref)
return(res)
}
# check the input
check_mrs_data(mrs_data)
mrs_data$ref = ref
return(mrs_data)
}
#' Set the number of transients for an mrs_data object.
#' @param mrs_data MRS data.
#' @param n_trans number of acquired transients.
#' @export
set_Ntrans <- function(mrs_data, n_trans) {
if (inherits(mrs_data, "list")) {
res <- lapply(mrs_data, set_Ntrans, n_trans = n_trans)
return(res)
}
# check the input
check_mrs_data(mrs_data)
mrs_data$meta$NumberOfTransients = n_trans
return(mrs_data)
}
#' Check if the chemical shift dimension of an MRS data object is in the
#' frequency domain.
#' @param mrs_data MRS data.
#' @return logical value.
#' @export
is_fd <- function(mrs_data) {
# check the input is an mrs_data object
check_mrs_data(mrs_data)
mrs_data$freq_domain[7]
}
#' Apply the Fourier transform over the dynamic dimension.
#' @param mrs_data MRS data where the dynamic dimension is in the time-domain.
#' @param ft_shift apply FT shift to the output, default is FALSE.
#' @param ret_mod return the modulus out the transform, default is FALSE.
#' @param fd transform the chemical shift axis to the frequency domain first,
#' default is TRUE.
#' @return transformed MRS data.
#' @export
ft_dyns <- function(mrs_data, ft_shift = FALSE, ret_mod = FALSE, fd = TRUE) {
if (inherits(mrs_data, "list")) {
return(lapply(mrs_data, ft_dyns, ft_shift = ft_shift, ret_mod = ret_mod,
fd = fd))
}
# convert to the correct domain
if (fd & !is_fd(mrs_data)) {
mrs_data <- td2fd(mrs_data)
} else if (!fd & is_fd(mrs_data)) {
mrs_data <- fd2td(mrs_data)
}
data <- mrs_data$data
# permute the dynamic dimension to be the last (7th)
data <- aperm(data, c(1, 2, 3, 4, 6, 7, 5))
data_dim <- dim(data)
# convert to a matrix and transform
data <- matrix(data, ncol = Ndyns(mrs_data))
# fft and shift if requested
if (ft_shift) {
data <- t(ft_shift_mat(t(data)))
} else {
data <- t(stats::mvfft(t(data)))
}
# revert back to an array
dim(data) <- data_dim
# permute the dynamic dimension to be 5th
data <- aperm(data, c(1, 2, 3, 4, 7, 5, 6))
if (ret_mod) data <- Mod(data)
mrs_data$data <- data
return(mrs_data)
}
#' Transform time-domain data to the frequency-domain.
#' @param mrs_data MRS data in time-domain representation.
#' @return MRS data in frequency-domain representation.
#' @export
td2fd <- function(mrs_data) {
if (inherits(mrs_data, "list")) return(lapply(mrs_data, td2fd))
if (mrs_data$freq_domain[7] == TRUE) {
warning("Data is already in the frequency-domain.")
}
freq <- matrix(mrs_data$data, ncol = Npts(mrs_data))
freq <- t(ft_shift_mat(t(freq)))
dim(freq) <- dim(mrs_data$data)
mrs_data$data <- freq
mrs_data$freq_domain[7] <- TRUE
unname(mrs_data$data)
return(mrs_data)
}
#' Transform frequency-domain data to the time-domain.
#' @param mrs_data MRS data in frequency-domain representation.
#' @return MRS data in time-domain representation.
#' @export
fd2td <- function(mrs_data) {
if (inherits(mrs_data, "list")) return(lapply(mrs_data, fd2td))
if (mrs_data$freq_domain[7] == FALSE) {
warning("Data is already in the time-domain.")
}
time <- matrix(mrs_data$data, ncol = Npts(mrs_data))
time <- t(ift_shift_mat(t(time)))
dim(time) <- dim(mrs_data$data)
mrs_data$data <- time
mrs_data$freq_domain[7] <- FALSE
dimnames(mrs_data$data) <- NULL
return(mrs_data)
}
#' Reconstruct complex time-domain data from the real part of frequency-domain
#' data.
#' @param mrs_data MRS data.
#' @return reconstructed MRS data.
#' @export
recon_imag <- function(mrs_data) {
# data needs to be in the FD
if (!is_fd(mrs_data)) mrs_data <- td2fd(mrs_data)
mrs_data <- apply_mrs(mrs_data, 7, recon_imag_vec)
mrs_data$freq_domain[7] <- FALSE
return(mrs_data)
}
#' Return acquisition parameters from a MRS data object.
#' @param mrs_data MRS data.
#' @return list of acquisition parameters.
#' @export
get_acq_paras <- function(mrs_data) {
# check the input is an mrs_data object
check_mrs_data(mrs_data)
list(ft = mrs_data$ft, fs = fs(mrs_data), N = Npts(mrs_data),
ref = mrs_data$ref, nuc = mrs_data$nuc)
}
ft <- function(mrs_data, dims) {
apply_mrs(mrs_data, dims, ft_shift)
}
#' Apply the diff operator to an MRS dataset in the FID/spectral dimension.
#' @param mrs_data MRS data.
#' @param ... additional arguments to the diff function.
#' @return MRS data following diff operator.
#' @export
diff_mrs <- function(mrs_data, ...) {
apply_mrs(mrs_data, 7, fun = diff, ...)
}
#' Apply the max operator to an MRS dataset.
#' @param mrs_data MRS data.
#' @return MRS data following max operator.
#' @export
max_mrs <- function(mrs_data) {
apply_mrs(mrs_data, 7, max, data_only = TRUE)
}
#' Apply the max operator to an interpolated MRS dataset.
#' @param mrs_data MRS data.
#' @param interp_f interpolation factor.
#' @return Array of maximum values (real only).
#' @export
max_mrs_interp <- function(mrs_data, interp_f = 4) {
apply_mrs(mrs_data, 7, re_max_interp, interp_f, data_only = TRUE)
}
#' Apply Re operator to an MRS dataset.
#' @param z MRS data.
#' @return MRS data following Re operator.
#' @export
Re.mrs_data <- function(z) {
z$data <- Re(z$data)
z
}
#' Apply Im operator to an MRS dataset.
#' @param z MRS data.
#' @return MRS data following Im operator.
#' @export
Im.mrs_data <- function(z) {
z$data <- Im(z$data)
z
}
#' Apply Mod operator to an MRS dataset.
#' @param z MRS data.
#' @return MRS data following Mod operator.
#' @export
Mod.mrs_data <- function(z) {
z$data <- Mod(z$data)
z
}
#' Apply Arg operator to an MRS dataset.
#' @param z MRS data.
#' @return MRS data following Arg operator.
#' @export