2
$\begingroup$

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]]&]
$\endgroup$
  • $\begingroup$ Add your list examples as Mathematica code, not as images, so people can play with them more easily. Also, when you do the sorting / selecting in a naive way, without any special tricks, is it really too slow? I wouldn't want to optimize something that doesn't need optimizing... $\endgroup$ – MarcoB Mar 17 '17 at 17:40
  • $\begingroup$ Hi, sorting the sublists by increasing values of their third elements is not the issue. But comparing the sublists in the way described in the question may be infeasible in terms of computation time if we naively compare each sublist with the other ones. This would give $k!/2!/(k - 2)!$ combinations, with k = 1,000,000. This is why the comparisons / selections should be done with just "nearby" sublists, with "nearby" being defined by the numbers $\epsilon$ and $\delta$ mentioned in the question. $\endgroup$ – stackmath Mar 17 '17 at 18:16
  • $\begingroup$ @stackmath I'm gonna guess your issues come in constructing axuiliarytab not in sorting it as Sort@RandomReal[1, 1000000] // AbsoluteTiming // First is only about .15 for me. Unless you're doing real-time manipulation and visualization of the data that's not bad at all. $\endgroup$ – b3m2a1 Mar 19 '17 at 0:51
  • $\begingroup$ @MB1965, in fact, the issue is not with the sorting procedure, but with the construction of auxiliarytab. It is extremely time demanding for k = Length[originaltab] = 1,000,000, since the way I implemented it above generates k!/2!/(k-2)! intermediate sublists. For k = 1,000,000 this gives 499,999,500,000 combinations! My notebook cannot handle this computation before running out of memory. A more efficient way of doing this would be to compare just "nearby" sublists, instead of each sublist with all the other ones. But I am struggling to figure out how to do this in Mathematica... $\endgroup$ – stackmath Mar 19 '17 at 1:07
  • $\begingroup$ @stackmath I think we can optimize without worry about "comparing nearby sublists". Let me see if I can knock up a better implementation. I think a more either a functional approach or judicious application of Compile should let us handle this. $\endgroup$ – b3m2a1 Mar 19 '17 at 1:09
2
$\begingroup$

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.

$\endgroup$
  • 1
    $\begingroup$ @AliHashmi Great idea to parallelize. This is really a much smaller boost than what you get from that. $\endgroup$ – b3m2a1 Mar 20 '17 at 0:57
  • $\begingroup$ just curious. how much speed boost do you get when you run the ParallelTable with and without chunks for your sample size? $\endgroup$ – Ali Hashmi Mar 20 '17 at 1:06
  • $\begingroup$ @AliHashmi Good question. I just retried the 1904 case and got 1.7 seconds all together and .88 seconds chunked. I'll try it on a larger case. $\endgroup$ – b3m2a1 Mar 20 '17 at 1:08
  • $\begingroup$ great ! i am really looking forward to what happens on an input size of 100,000. $\endgroup$ – Ali Hashmi Mar 20 '17 at 1:10
  • 1
    $\begingroup$ @AliHashmi I just got 57.09 seconds for 10,000 unchunked vs 6.98 chunked. Then 100,000 case will take a while to run. $\endgroup$ – b3m2a1 Mar 20 '17 at 1:12
1
$\begingroup$

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

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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