# Quickly pruning elements in one structured array that exist in a separate unordered array

I have two lists, which we'll call testList and modifiedTestList. The first list looks something like this:

testList = Table[RandomReal[{0, 1000}, {RandomInteger[{0, 32}], 2}], {i, 1, 10}];


To generate modifiedTestList, I can flatten testList by strictly one level (never breaking up the pairs of real numbers specifying 2D coordinates), scramble the elements, and select and prune elements. For example:

modifiedTestList = Flatten[testList, 1];
modifiedTestList = RandomSample[modifiedTestList, Length[modifiedTestList]];
modifiedTestList = Select[modifiedTestList, #[[1]] > 700 &];


Once I've had my fun, I'd like to take testList and prune away all of the 2D coordinates that no longer exist in modifiedTestList while respecting the original array structure of testList (i.e. testList should not be flattened and elements should not be moved between subarrays).

Let's say testList and modifiedTestList are both quite large ($>10^6$ elements each). Is there a fast way to do the above pruning provided these large data structures?

-

This method assumes modifiedTestList is a given.

rules = Dispatch@Thread[Rule[modifiedTestList, Sequence[]]]
tmp1=Replace[testList, rules, {2}]


Also

tmp2=DeleteCases[testList, Alternatives @@ modifiedTestList, {2}]


I've limited these to looking at level 2 so as to eliminate any unneeded level snooping. I'm sure others will have some alternatives but best to try on your real world example and report back the timings.

tmp1==tmp2
(*  True *)


Edit

I may have misread. In the above I've deleted the elements of modifiedTestList from testList. If you want the opposite then

tmp3=DeleteCases[testList, Except[Alternatives @@ modifiedTestList], {2}]


or

rules2 = Dispatch@Thread[Rule[Complement[Flatten[testList, 1], modifiedTestList],
Sequence[]]]
tmp4 = Replace[testList, rules2, {2}]

tmp3==tmp4
(*  True  *)

-
Sorry for the late response, but thanks for your answer! –  RTaylor Oct 28 '13 at 2:33
+1. You're right, I've deleted mine since it's very similar. –  RunnyKine Oct 28 '13 at 2:34
@RunnyKine changing modifiedTestList is also a possibility but I took it as a given for the purposes of answering the question. –  Mike Honeychurch Oct 28 '13 at 2:38
@MikeHoneychurch. Your answer is excellent. If I think up something really different I'll post. You already have my vote. –  RunnyKine Oct 28 '13 at 2:41
@MikeHoneychurch By the way, thanks for your edit, I could have worked around it, but this latter section correctly interprets my question. –  RTaylor Oct 28 '13 at 2:42

Here are fresh-kernel times (on a slower machine) for tmp4, tmp5, and three more methods. tmp6 is just tmp5 using Scan instead of Do. tmp7 and tmp8 get the Intersection of the modified list with each original sublist; the results are sorted within sublists. tmp8 saves time by reducing the modified list from one comparison to the next.

In[1]:= Length /@ (A = Table[RandomReal[{0, 1000}, {RandomInteger[{1*^4, 5*^4}], 2}], {10}])
Out[1]= {42008, 46556, 23970, 45599, 12340, 32636, 45232, 39218, 24238, 14579}

In[2]:= Length[B = RandomSample@Select[Join @@ A, #[[1]] > 700 &]]
Out[2]= 97983

In[3]:= First@AbsoluteTiming[
rules2 = Dispatch@Thread[Rule[Complement[Flatten[A, 1], B], Sequence[]]];
tmp4 = Replace[A, rules2, {2}];]
Out[3]= 6.239390

In[4]:= First@AbsoluteTiming[tmp5 = Block[{f}, Do[f[p] = p, {p, B}];
f[_] := Sequence[]; Map[f, A, {2}]];]
Out[4]= 6.078836

In[5]:= First@AbsoluteTiming[tmp6 = Block[{f}, Scan[(f@# = #)&, B];
f[_] := Sequence[]; Map[f, A, {2}]];]
Out[5]= 4.580439

In[6]:= SameQ[tmp4, tmp5, tmp6]
Out[6]= True

In[7]:= First@AbsoluteTiming[tmp7 = Intersection[#, B]& /@ A;]
Out[7]= 2.802139

In[8]:= First@AbsoluteTiming[tmp8 = Block[{b = B}, Join[
((b = Complement[b, #]; #)& @ Intersection[#, b])& /@ Most@A, {b}] ]]
Out[8]= 1.288282

In[9]:= SameQ[Sort/@tmp6, tmp7, tmp8]
Out[9]= True

-
It appears that tmp7 and tmp8 do not return the same as tmp6 if A contains duplicates -- if a pair should remain, then its duplicates should remain, too. (I changed RandomReal to RandomInteger to check.) –  Michael E2 Oct 29 '13 at 0:30
tmp7 and tmp8 are meant for situations in which the probability of any duplicates is negligible, as would be the case with RandomReal data. –  Ray Koopman Oct 29 '13 at 8:48
Well, this question doesn't seem to be attracting much interest, even from the OP, so perhaps it was a moot point anyway. +1 for Scan. –  Michael E2 Oct 29 '13 at 18:26

Here is a slight variation on Mike Honeychurch's Replace idea, with the rules stored as down values. However it seems to run in 65% - 90% of the time on larger lists, which is still not that fast.

tmp5 = Block[{f},
Do[f[p] = p, {p, modifiedTestList}];
f[_] := Sequence[];
Map[f, testList, {2}]
]


Comparison

SeedRandom[1];
testList = Table[RandomReal[{0, 1000}, {RandomInteger[{10000, 200000}], 2}], {i, 1, 10}];

modifiedTestList = Flatten[testList, 1];
modifiedTestList = RandomSample[modifiedTestList, Length[modifiedTestList]];
modifiedTestList = Select[modifiedTestList, #[[1]] > 700 &];

(rules2 =
Dispatch@
Sequence[]]];
tmp4 = Replace[testList, rules2, {2}]); // AbsoluteTiming // First

tmp5 = Block[{f},
Do[f[p] = p, {p, modifiedTestList}];
f[_] := Sequence[];
Map[f, testList, {2}]
]; // AbsoluteTiming // First


3.188436
2.610696

tmp4 == tmp5
(* True *)


One annoying thing is that the time varies widely. The above two were done with a fresh kernel. If the order is reversed, I got 3.335085 vs. 2.426648 (again from a fresh kernel). If they are executed repeatedly, the time grows to about 4.15 vs. 2.8.

Appendix: Alternate formulation of the problem

I wish to suggest a different approach, which may or may not be feasible in the OP's actual use case. It also changes the parameters of the problem somewhat, but in a way that plays to some strengths of Mathematica and is about 30 times faster. The speed gain is at the expense of using about twice as much memory.

Overview

I would suggest augmenting testList with the positions of each pair of real numbers so that each list in testList is of the form

{..., {position, {x, y}}, ...}


Then have fun mixing and selecting the data to produce the list modifiedTestList, which will be of the same form. One can then use the positions to sort modifiedTestList back into the right places and in the right subarrays. If the arrays are kept packed whenever possible, putting the elements back into place can be done quite quickly.

One question, which only the OP could answer, is whether the modifiedTestList can be used in the augmented form in the real application and kept packed.

Prepping the data

We add the positions posList of each pair in testList to the pair and store the result in testListAug. We put the positions in front so that we can later use the default Sort, which is the faster than using sorting functions or SortBy. To get the arrays as packed as possible, I used N on the positions, Join to join the packed arrays that make up testListAug, and the compiled version of Select. Flatten and the normal Select do not produce packed arrays.

SeedRandom[1];
testList = Table[RandomReal[{0, 1000}, {RandomInteger[{10000, 200000}], 2}], {i, 1, 10}];
(posList = Table[N@Table[{i, j}, {j, Length@testList[[i]]}], {i, Length@testList}];
testListAug = MapThread[Transpose[{##}] &, {posList, testList}];
modifiedTestList = Join @@ testListAug;
modifiedTestList = RandomSample[modifiedTestList, Length[modifiedTestList]];
modifiedTestList = Compile[{{list, _Real, 3}}, Select[list, #[[2, 1]] > 700 &]] @
modifiedTestList;) // AbsoluteTiming //First
(* 0.432593 *)


The processing of the original modifiedTestList took 1.99 seconds, so adding the positions does not add a lot to the processing time.

Putting the data back into place

We can Sort the data in modifiedTestList; since the positions are first, the sort will be by position. We can then split the data up into its original subarrays using the Differences in the first position index. (SplitBy partially unpacks and is considerably slower.)

tmp9 = Module[{last = 0, mod},
mod = Sort[modifiedTestList];
With[{tl = mod[[All, 2]]},
Rest @ FoldList[tl[[last + 1 ;; (last = #2)]] &, {{}}, # ~Join~ {-1}]] &@
Flatten @
SparseArray[ Differences[ mod[[All, 1, 1]] ] ]["NonzeroPositions"]
]; // AbsoluteTiming // First
(* 0.084893 *)

tmp9 == tmp5
(* True *)

-