Data selection by comparing elements from different sublists in a nested list

Question

I have a huge nested list in the following general format:

$\textrm{originaltab} = \{e_i^j\} = \{\{e_1^1,e_1^2,e_1^3,e_1^4,e_1^5,e_1^6,e_1^7,e_1^8\},\{e_2^1,e_2^2,e_2^3,e_2^4,e_2^5,e_2^6,e_2^7,e_2^8\},\cdots\}$

with 8 elements per sublist and a total of around 1,000,000 sublists in the nested list $\textrm{originaltab}$.

What I need to do is the following:

1) Sort the sublists by increasing values of the elements $e_i^3$. This is easy to do using the command Sort in Mathematica:

Sort[originaltab, #1[[3]] < #2[[3]] &]

2) Now I need to define a new nested list, let me call it $\textrm{newtab}$, which consists of all the sublists in $\textrm{originaltab}$ satisfying the following criteria:

$(e_i^1 \neq e_j^1 \, || \, e_i^2 \neq e_j^2) \,\&\& \, (e_j^3\in [e_i^3-\epsilon,e_i^3+\epsilon] \,\&\& \, e_j^4\in [e_i^4-\delta,e_i^4+\delta]),\, i\neq j$

where $\epsilon$ and $\delta$ are some small positive numbers. Since I sorted the sublists in $\textrm{originaltab}$ such that they are ordered by increasing values of $e_i^3$, the sublists in $\textrm{originaltab}$ which eventually satisfy the above criteria are necessarily close to each other, such that it would be a waste of time to compare the first sublist in $\textrm{originaltab}$ with the last one, because they will obviously not satisfy the above criteria, since $e_{1000000}^3-e_1^3\gg\epsilon$. The sublists in $\textrm{newtab}$ should be sorted as in the case of $\textrm{originaltab}$.

3) Once I have defined $\textrm{newtab}$, as schematically depicted above, I need to define a new nested list, which I will call $\textrm{auxiliarytab}$, which should be composed as follows: for all the sublists in $\textrm{newtab}$ satisfying $(e_j^3\in [e_i^3-\epsilon,e_i^3+\epsilon] \,\&\& \, e_j^4\in [e_i^4-\delta,e_i^4+\delta])$, we should delete the ones with the highest value of $e_j^5$. This deletion should be immediate, preventing an excluded sublist to be called again to be compared with other sublists (in the case of overlapping zones).

4) Once the step 3 above is done, I need to remove from originaltab the set of sublists contained in $\textrm{auxiliarytab}$. This is easy to do using the command Complement in Mathematica:

finaltab = Complement[originaltab, auxiliarytab]

So, as a very simple illustration of what the algorithm should do, consider the example below, with $\epsilon=0.1$:

originaltab = {{0.3,0.1,50,0,200,0,0,0},{0.4,0.2,50.1,0,600,0,0,0},{0.3,0.2,50.2,0,10,0,0,0},{1.5,0.8,50.3,0,230,0,0,0},{0.1,0.9,123,0,3000,0,0,0}}

newtab = {{0.3,0.1,50,0,200,0,0,0},{0.4,0.2,50.1,0,600,0,0,0},{0.3,0.2,50.2,0,10,0,0,0},{1.5,0.8,50.3,0,230,0,0,0}}

auxiliarytab = {{0.3,0.1,50,0,200,0,0,0},{0.3,0.2,50.2,0,10,0,0,0}}

finaltab = {{0.4,0.2,50.1,0,600,0,0,0},{1.5,0.8,50.3,0,230,0,0,0},{0.1,0.9,123,0,3000,0,0,0}}

How could I do steps 2 and 3 above in a efficient way (remember that the actual situation comprises a nested list with around 1,000,000 sublists!)?

I thank in advance for any possible suggestion!

========================

EDIT: below I give a possible way of doing what I want, but this way is extremely inefficient in terms of computation time and memory usage. It is simply infeasible if originaltab has 1,000,000 sublists (but works well for a nested list with just 2,000 sublists, for instance).

Clear[\[Epsilon],\[Delta],originaltab,auxiliarytab,finaltab]
\[Epsilon]=0.1;
\[Delta]=0.1;
originaltab=Sort[{{0.3,0.1,50,0,200,0,0,0},{0.4,0.2,50.1,0,600,0,0,0},{0.3,0.2,50.2,0,10,0,0,0},{1.5,0.8,50.3,0,230,0,0,0},{0.1,0.9,123,0,3000,0,0,0}},#1[[3]]<#2[[3]]&]
auxiliarytab=Sort[DeleteDuplicates[DeleteMissing[Flatten[Table[
  If[(originaltab[[i, 1]] != originaltab[[j, 1]] || 
      originaltab[[i, 2]] != 
       originaltab[[j, 2]]) && (IntervalMemberQ[
       Interval[{originaltab[[i, 3]] - \[Epsilon], 
         originaltab[[i, 3]] + \[Epsilon]}], 
       originaltab[[j, 3]]] && 
      IntervalMemberQ[
       Interval[{originaltab[[i, 4]] - \[Delta], 
         originaltab[[i, 4]] + \[Delta]}], originaltab[[j, 4]]]),
   DeleteCases[{originaltab[[i, All]], originaltab[[j, All]]},
    {_, _, _, _, 
     Max@{originaltab[[i, 5]], originaltab[[j, 5]]}, _, _, _}
    ], Missing[]],
  {i, 1, Length[originaltab] - 1}, {j, i + 1, 
   Length[originaltab]}], 2]]], #1[[3]] < #2[[3]] &]
finaltab=Sort[Complement[originaltab,auxiliarytab],#1[[3]]<#2[[3]]&]

Answer 1

So here's the implementation I discussed in my comments. We'll take advantage of a similar ParallelTable structure as Ali, but cleaned up a bit, and, here's the crucial bit, we'll restrict the size of our chunks, while making sure nothing slips through the cracks. Here's the data setup:

n = 100000;
ot =
  SortBy[#[[3]] &]@
   Transpose@
    {RandomReal[1, n], RandomReal[1, n], RandomReal[100, n],
     ConstantArray[0, n],
     RandomInteger[600, n],
     ConstantArray[0, n], ConstantArray[0, n], ConstantArray[0, n]};

And now here's where we figure out which chunks we'll need:

chunk = 1000;
cutPoints =
  Riffle[#, # + 1] &@Range[chunk, Length@ot - chunk, chunk];
col = ot[[All, 3]];
chunks =
  Partition[
   Flatten@{
     1,
     Table[
      If[OddQ@i,
       SelectFirst[Range[i, 1, -1], 
        col[[i]] - col[[#]] > \[Epsilon] &],
       SelectFirst[Range[i, Length@col], 
        col[[#]] - col[[i]] > \[Epsilon] &]
       ],
      {i, cutPoints}
      ],
     Length@col
     },
   2
   ];

Then we'll adapt the auxiliarytab code to work in chunks, rather than all together:

auxChunk[{start_, end_}] :=
  Flatten[
   ParallelTable[
    If[(ot[[i, 1]] != ot[[j, 1]] || 
        ot[[i, 2]] != ot[[j, 2]]) && (ot[[i, 3]] - \[Epsilon] <= 
        ot[[j, 3]] <= 
        ot[[i, 3]] + \[Epsilon]) && (ot[[i, 4]] - \[Delta] <= 
        ot[[j, 4]] <= ot[[i, 4]] + \[Delta]),
     MinimalBy[{ot[[i]], ot[[j]]}, #[[5]] &],
     Nothing
     ],
    {i, start, end - 1},
    {j, i + 1, end}
    ],
   2];

And then we'll string this together:

In[69]:= AbsoluteTiming[
  aut =
    SortBy[
     DeleteDuplicates[
      Join @@ Map[auxChunk, chunks]
      ],
     #[[3]] &
     ];
  ] // First

Out[69]= 287.988

Note that this sample is 10x larger than the Ali's version (if I read his code right) but was only just over twice as slow. I cannot promise that 1000 is the best chunk size, you'll obviously want to optimize this. For another reference, on 1904 sublists with chunk size of 100 this takes 1.325 seconds.

Much more interesting problem than I expected (couldn't get away with a simple Compile or PackedArray solution) -- thanks for that.

Performance:

You'll generally want a smaller chunk size, I think, up to a point. The total number of computations will look like:

Range[#[[2]] - #[[1]]] & /@ chunks // Total@*Flatten

And so in this case we can test out a number of chunk sizes on a test sample of size 100,000:

• Chunks of 500: 49300203 computations
• Chunks of 1000: 72312519 computations
• Chunks of 5000: 270482828 computations
• Chunks of 10000: 519107039 computations

Which would suggest that chunks of 500 are best, but this isn't what we see:

• Chunks of 500: 316 seconds
• Chunks of 1000: 292 seconds
• Chunks of 5000: 472 seconds
• Chunks of 10000: 773 seconds

So yes, smaller chunks are better, but there are also more calls to account for, and this can slow down the process. Also with decreasing chunk size there's a corresponding increase in pre-processing time, so, for instance, while chunks of 1000 are better than chunks of 5000 by a large margin, the benefit from going from 1000 to, say, 750 might be washed out by the extra preprocessing time and extra calls, particularly as the size of n increases.

Answer 2

Here is a partial attempt to make your code faster. I would suggest the use of ParallelTable and SortBy rather than Sort. Perhaps in your case there is no need to use IntervalMemberQ and Interval.

list = RandomReal[{0, 1}, {10000, 8}];
(list = SortBy[list, #[[3]] &]); // Timing (* same as originaltab *)

(* {0., Null} *)

(auxiliarytab = 
SortBy[DeleteDuplicates[
  DeleteMissing[
   Flatten[ParallelTable[
     If[(list[[i, 1]] != list[[j, 1]] || 
         list[[i, 2]] != 
          list[[j, 2]]) && (list[[i, 3]] - \[Epsilon] <= 
         list[[j, 3]] <= 
         list[[i, 3]] + \[Epsilon]) && (list[[i, 4]] - \[Delta] <=
          list[[j, 4]] <= list[[i, 4]] + \[Delta]), 
      DeleteCases[{list[[i]], list[[j]]}, {_, _, _, _, 
        Max@{list[[i, 5]], list[[j, 5]]}, _, _, _}], 
      Missing[]], {i, 1, Length[list] - 1}, {j, i + 1, 
      Length[list]}], 2]]], #[[3]] &]); // Timing

(* {117.625, Null} *)

(finaltab = 
SortBy[Complement[list, auxiliarytab], #[[3]] &]); // Timing

(* {0.015625, Null} *)

I also checked for 1940 sublists as you mentioned in your comment. Compared to 39 seconds in your case, the modified code gives you ~ 3.84 seconds which is about 10X faster.

I tried using SetSharedFunction to use Sow with ParallelDo but that implementation was somehow slower and behaving unpredictably.

Hope it helps you partly if not much