Performance of calculation of mean squared displacement
Here is an FFT approach for those interested.
mFFT[lis_?VectorQ] := Module[{data, acf, len = Length @ lis},
data = Join[lis, ConstantArray[0., len]];
acf = InverseFourier[Abs[Fourier @ data]^2];
acf = Re @ acf[[1 ;; len]]/Range[len, 1., -1.]]
This first half gives the position correlation function of the particle. To get the mean squared displacement we still need to compute the first and last time autocorrelation function:
msd[lis_?MatrixQ, dt_?NumericQ] :=
Module[{t, acf, d2, d = Total[lis^2, {2}], ss, msd, len = Length@lis},
ss = 2. Total[d];
Scan[(d2[# - 1] = d[[#]]) &, Range[1, len]];
d2[-1] = d2[len] = 0.;
msd = ConstantArray[0., len]; acf = Total[mFFT /@ Transpose[lis]];
msd = Table[ss = ss - d2[k - 1] - d2[len - k];
ss/(len - k), {k, 0, len - 1}]; t = Range[0., dt (len - 1), dt];
Rest@Transpose[{t, msd - 2 acf}]]
Here is how to use it:
SetOptions[#, FourierParameters -> {1, -1}] & /@ {Fourier, InverseFourier}
data = ReadList["http://goo.gl/Fmm9fZ", {Number, Number}]; (* your data *)
res = msd[data, 1/60.];
ListLogLogPlot[res]
Note that you can include the FourierParameters
option in the code for meanSqD
, I chose not to. For the provided dataset, it's about 3 orders of magnitude faster than OP's code and an order of magnitude faster than the Differences
approach. But really, this approach begins to shine when the data is large.
Update
My previous code had an error, it should be Total[#^2] &
(sum of squares) instead of (Total@#^2) &
(square of sum).
The full code should look like this:
data = Import["http://goo.gl/Fmm9fZ", "Table"][[1 ;; -2]];
dx = 1.9*10.^-3; data = data*dx;
meanDisp[data_, dn_] := Mean[Total[#^2] & /@ Differences[data, 1, dn]];
meanStd[data_, dn_] :=
StandardDeviation[Total[#^2] & /@ Differences[data, 1, dn]];
meanXsq[data_, dn_] := Mean[#[[1]]^2 & /@ Differences[data, 1, dn]];
meanXsqStd[data_, dn_] :=
StandardDeviation[#[[1]]^2 & /@ Differences[data, 1, dn]];
meanYsq[data_, dn_] := Mean[#[[2]]^2 & /@ Differences[data, 1, dn]];
meanYsqStd[data_, dn_] :=
StandardDeviation[#[[2]]^2 & /@ Differences[data, 1, dn]];
{msdMean, msdStdDev, xSquaredMean, xSquaredStdDev,ySquaredMean, ySquaredStdDev} =
Table[#[data, dn], {dn, 1, Length@data - 2}] & /@ {meanDisp,
meanStd, meanXsq, meanXsqStd, meanYsq, meanYsqStd};
Update 2 We can further improve performance by exploiting the
^2
beingListable
allCalc[data_, dn_] :=
Module[{diff, x2, y2, x2m, y2m, x2s, y2s, disp, std},
diff = (Differences[data, 1, dn]^2);
{x2, y2} = Transpose@diff;
{{x2m, x2s}, {y2m,
y2s}} = {Mean[#], StandardDeviation[#]} & /@ {x2, y2};
std = StandardDeviation[x2 + y2];
disp = x2m + y2m;
{disp, std, x2m, x2s, y2m, y2s}];
We can also compile this new function:
allCalcCompile =
Compile[{{data, _Real, 2}, {dn, _Integer, 0}},
Module[{diff, x2, y2, x2m, y2m, x2s, y2s, disp, std},
(* the same body *)
], RuntimeOptions -> "Speed"];
Now if we compare performance:
{t, newCompile} =
AbsoluteTiming[
Transpose@
Table[allCalcCompile[data, dn], {dn, 1, Length@data - 2}]];
t
{t, new} =
AbsoluteTiming[
Transpose@Table[allCalc[data, dn], {dn, 1, Length@data - 2}]];
t
{t, old} =
AbsoluteTiming[
Table[#[data, dn], {dn, 1, Length@data - 2}] & /@ {meanDisp,
meanStd, meanXsq, meanXsqStd, meanYsq, meanYsqStd}];
t
(*
0.276597
0.632528
3.3952
*)