# Computing the mean difference between elements in a list with index $i$ and the closest elements with index $(i+1)$

I have a list that looks like this:

preprocessedList = {{1,5.3},{1,5.566},{1,1.4322},{2,3.443543},{2,3.444},{3,0.1223},{4,1.3243},{4,1.554343}}


Each element in the list is of the form $(i,j_k)$, where $i = 1,2,3,...,N$ is an integer index (which may be degenerate, i.e. there may be multiple list entries with the same $i$ value), and $j_k$ is some value associated with each list item.

I want to create a new list $L$ where, for each index starting with $i = 2$, we compute the median or mean of the difference between elements with the index $(i-1)$ and the nearest elements with index $i$ (in terms of one-dimensional Euclidean distance).

Starting with $i = 2$, we first take {1,5.3}, we compute that {2,3.444} is closest since the different between 3.444 and 5.3 is the minimum for all items with the index $i=2$. We compute this difference as $(3.444 - 5.3) = -1.856$. We then move on to {1,5.566}, notice again that {2,3.444} is closest to {1,5.3}, and compute this difference as $(3.444 - 5.566) = -2.122$. Finally, we move on to {1,1.4322}, notice that this is closest to {2,3.443543}, and compute the difference $(3.443543 - 1.4322) = 2.011343$. We then average these differences: $(-1.856 + -2.122 + 2.011343) / 3 = -0.6555...$ and place this at position $(i-1)$ in $L$.

So we have $L = (-0.6555..., ...)$ thus far. We then move on to $i = 3$ and so forth. Note that if there is no $i = 3$ elements, we'd just enter $0$ at that position in $L$.

Is there a fast and slick way to do this with a large initial preprocessedList?

Here's the naive (very slow) way to do this:

preprocessedList = {{1, 5.3}, {1, 5.566}, {1, 1.4322}, {2, 3.443543}, {2, 3.444}, {3, 0.1223}, {4, 1.3243}, {4, 1.554343}};

L = Array[0 &, Max[preprocessedList[[All, 1]]] - (Min[preprocessedList[[All, 1]]])];

counter = 0;
For[i = Min[preprocessedList[[All, 1]]] + 1,
i <= Max[preprocessedList[[All, 1]]], i++,

counter += 1;

highIndexList = Select[preprocessedList, #[] == i &];
lowIndexList = Select[preprocessedList, #[] == (i - 1) &];

If[Length[highIndexList] > 0 && Length[lowIndexList] > 0,

differenceArray = Array[0 &, Length[lowIndexList]];
For[k = 1, k <= Length[lowIndexList], k++,
differenceArray[[k]] =
Nearest[highIndexList[[All, 2]], lowIndexList[[k, 2]]] - lowIndexList[[k, 2]];
];
L[[counter]] = {i, Mean[Flatten[differenceArray]]};
,
L[[counter]] = 0;
];

];


The output is:

L = {{2, -0.655552}, {3, -3.32147}, {4, 1.202}};


Perhaps there's a way to compile this?

You don't say that preprocessedList will always be sorted, so I sorted it.
Also, I'm not sure if this is how you want to handle gaps in the index sequence.

f[{{i_,x_},{j_,y_}}] := {j, If[j==i+1, Mean[Nearest[y,#][]-#&/@x], 0};

f /@ Partition[{#[[1,1]],#[[All,2]]}&/@SplitBy[Sort@preprocessedList,First],2,1]

(* {{2, -0.655552}, {3, -3.32147}, {4, 1.202}} *)


EDIT - Here is new code that implements suggestions by Jonie and Mr.Wizard. It inserts a sequence of (index,0} terms instead of just one, and uses a NearestFunction instead of repeating Nearest[y,#]. Also, it assumes (as they seem to have done) that the preprocessing has sorted the data with respect to the indices.

f2[{{i_,x_},{j_,y_}}] := If[j==i+1, {j, Mean[Flatten[Nearest@y/@x]-x]},
Sequence@@Table[{k,0},{k,i+1,j}]]

g[data_] := f2 /@ Partition[{#[[1,1]],#[[All,2]]}&/@SplitBy[data,First],2,1]

data = {{1,5.3},{1,5.566},{1,1.4322},{2,3.443543},{2,3.444},
{3,0.1223},{4,1.3243},{4,1.554343},{7,17},{7,13},{8,4},{8,6}};

g@data

(* {{2, -0.655552}, {3, -3.32147}, {4, 1.202}, {5, 0}, {6, 0}, {7, 0}, {8, -9}} *)

• he mentioned if there's no element for an i, it just returns 0. +1 for slick and efficient implementation! – Jonie Sep 3 '13 at 7:51
• I worked on this independently, and I came up with a similar method (though I believe using NearestFunction is superior). I must say my code looks rather long by comparison. +1 – Mr.Wizard Sep 3 '13 at 8:16
• @Mr.Wizard Yes, I considered using a NearestFunction but it was so clean and short this way that I couldn't resist. – Ray Koopman Sep 3 '13 at 9:26
• It takes next to no additional code length; please see my answer for an example. – Mr.Wizard Sep 3 '13 at 9:36

It would help to know more about your data. For example, on average how many times will a single index appear? That can dramatically affect the best way to approach this problem I believe.

Anyway, making the assumption that these index groups may be quite large I suggest building NearestFunction objects. Something like this:

fn[pp_] :=
Module[{group, del},
group[#[[1, 1]]] = #[[All, 2]]; & ~Scan~ GatherBy[pp, First];
group[_] := 0;
del = With[{a = group[# - 1], b = group[#]},
If[a === 0 || b === 0, 0, Mean[First /@ Nearest[b] /@ a - a]]] &;
Table[{i, del[i]}, {i, 1 + Min@#, Max@#}] & @ pp[[All, 1]]
]


Test:

{{1, 5.3}, {1, 5.566}, {1, 1.4322}, {2, 3.443543}, {2, 3.444}, {3, 0.1223},
{4, 1.3243}, {4, 1.554343}, {7, 17}, {7, 13}, {8, 4}, {8, 6}} // fn

{{2, -0.655552}, {3, -3.32147}, {4, 1.202}, {5, 0}, {6, 0}, {7, 0}, {8, -9}}


Here's the functional naive but slightly faster implementation:

f3[lis_] := Module[{},
min = Min[lis[[All, 1]]];
max = Max[lis[[All, 1]]];
t = Table[Select[lis, #[] == i &], {i, min, max}];
Table[
If[Length[t[[i]]] == 0 || Length[t[[i - 1]]] == 0,
{i, 0},
nearestValues =
Flatten[Nearest[t[[i, All, 2]], #] & /@ t[[i - 1, All, 2]]];
{i, Mean[MapThread[(#1 - #2) &, {nearestValues, Flatten[t[[i - 1, All, 2]]]}]]}]
, {i, min + 1, max}
]
]


Using

data = MapThread[List, {Sort[Table[RandomInteger[{1, 50}], {i, 10000}]],
Table[RandomReal[{-5, 5}], {j, 10000}]}];

f3[data] // AbsoluteTiming // First


1.697170

And the original implementation

f1[lis_] := Module[{},
L = Array[0 &, Max[lis[[All, 1]]] - (Min[lis[[All, 1]]])];
counter = 0;
For[i = Min[lis[[All, 1]]] + 1, i <= Max[lis[[All, 1]]], i++,
counter += 1;
highIndexList = Select[lis, #[] == i &];
lowIndexList = Select[lis, #[] == (i - 1) &];
If[Length[highIndexList] > 0 && Length[lowIndexList] > 0,
differenceArray = Array[0 &, Length[lowIndexList]];
For[k = 1, k <= Length[lowIndexList], k++,
differenceArray[[k]] =
Nearest[highIndexList[[All, 2]], lowIndexList[[k, 2]]] - lowIndexList[[k, 2]];];
L[[counter]] = {i, Mean[Flatten[differenceArray]]};,
L[[counter]] = 0;
];
];
L
]

f1[data] // AbsoluteTiming // First


2.263226

Using ParalleTable for f3 yields 0.894089 (presuming kernels already started)

Ray Koopman's method yields 1.093109 for the same data. With Parallelize wrapper, 0.343034.

f[{{i_, x_}, {j_, y_}}] := {j,
If[j == i + 1, Mean[Nearest[y, #][] - # & /@ x], 0]};

Parallelize[
f /@ Partition[{#[[1, 1]], #[[All, 2]]} & /@
SplitBy[Sort@data, First], 2, 1]] //  AbsoluteTiming // First


0.343034