How to calculate the amount of offset about two list
Could also use ListCorrelate
.
{data1, data2} =
Uncompress[
FromCharacterCode@
Flatten[ImageData[Import["https://i.stack.imgur.com/ShSMY.png"],
"Byte"]]];
We remove the x axis values for now.
data1b = data1[[All, 2]];
data2b = data2[[All, 2]];
lc =
Reverse[Chop[ListCorrelate[data1b, data2b, {-1, -1}, 0]]];
maxPos = Ordering[lc, -1][[1]]
(* Out[98]= 33 *)
So we want to push the second set by 33-1 = 32 units along the +x axis. We'll see how that looks.
ListLinePlot[{data1b, Join[Take[data2b, maxPos - 1], data2b]},
PlotRange -> All]
One might wish to preprocess to remove the lower values, and possibly clip high ones. I used the code below for that purpose. In this case it did not change the outcome.
reScale[data_] := Module[{mn = Mean[data], newd},
newd = Clip[Threshold[data - Mean[data], mn/2], {0, mn/2}]]
data1c = reScale[data1b];
data2c = reScale[data2b];
--- edit ---
I should remark that what I did is quite similar to the (arguably more scientific) approach shown by @mikado. If I did not zero-pad the ListCorrelate
the list plot would be identical, up to a constant scale factor, to that of cc
in the @mikado response.
--- end edit ---
We can use Fourier techniques (cross-correlation) to estimate a misalignment between the signals.
Import the data
{data1, data2} =
Uncompress[
FromCharacterCode@
Flatten[ImageData[Import["https://i.stack.imgur.com/ShSMY.png"],
"Byte"]]];
The sample times associated with the two signals are the same
(First /@ data1) === (First /@ data2)
(* True *)
The sampling rate is close enough to uniform not to cause problems. The average sample interval is given by
dt = Mean[Differences[First /@ data1]]
(* 0.02 *)
Compute spectra, subtracting off the pedestal first.
spec[u_List] := Fourier[u - Median[u]]
spec1 = spec[Last /@ data1];
spec2 = spec[Last /@ data2];
Now compute the cross-correlation
cc = InverseFourier[Conjugate[spec2] spec1];
The cross-correlation has a clear peak
ListLinePlot[
Transpose[{Range[-100, 99] dt,
Abs[Join[Take[cc, -100], Take[cc, 100]]]}], PlotRange -> All]
This suggests that the delay is given by about
delay = First[First[(Position[Abs[cc], Max[Abs[cc]]] - 1) dt]]
(* 0.64 *)
Apply this delay to the data
shift[u_List, t_] := {t, 0} + # & /@ u
graph = ListLinePlot[{shift[data1, -32 dt], data2}, PlotRange -> All];
GraphicsColumn[{
Show[graph, PlotRange -> {{18, 24}, {0, 1000}}],
Show[graph, PlotRange -> {{36, 42}, {0, 3500}}],
Show[graph, PlotRange -> {{58, 64}, {0, 2500}}],
Show[graph, PlotRange -> {{78, 84}, {0, 1000}}]}]
We can see that the alignment is not perfect - it looks as if the delay may be somewhat variable.