Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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).

Using the about example list:

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, #[[1]] == i &];
  lowIndexList = Select[preprocessedList, #[[1]] == (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?

share|improve this question
add comment

3 Answers 3

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,#][[1]]-#&/@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}} *)
share|improve this answer
1  
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
add comment

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}}
share|improve this answer
add comment

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, #[[1]] == 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, #[[1]] == i &];
        lowIndexList = Select[lis, #[[1]] == (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, #][[1]] - # & /@ x], 0]};

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

0.343034

share|improve this answer
add comment

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.