How to do subtraction with sets in which the elements have multiplicity indicators? [duplicate]

I want to do subtraction with sets l1 and l2, which contain multiplicity indicators. For example,

 l1 = {{1, 1}, {1, 1}, {2, 2}, {3, 4}};
l2 = {{1, 1}, {2, 2}};
subset[l1, l2]

{{1, 1}, {3, 4}}


What's the best way to do this?

-

marked as duplicate by Mr.Wizard♦Dec 20 '13 at 17:41

Pardon me, why is {3,4} in the subset list? – Mr.Wizard Dec 19 '13 at 14:55
Do you know about Intersection and Complement? Intersection[l1, l2] == {{1, 1}, {2, 2}} and Complement[l1, l2] == {{3, 4}} – ssch Dec 19 '13 at 14:58
Per definition a set is a collection of distinct objects. Therefore, the double {1,1} in l1 is not OK. Otherwise, the solution to your question would be Complement[l1, l2]. – halirutan Dec 19 '13 at 16:28
I believe the OP is talking about multisets. Well, that seems to be andre's interpretation, too. If so, the question needs to be clarified. – Michael E2 Dec 19 '13 at 16:47
concerning the ordering, what sould be the result if l1={{1,2}}and l2={{2,1}}, {{1,2}} or {} ? – andre Dec 19 '13 at 17:18

l1={{1,1},{1,1},{2,2},{3,4}};
l2={{1,1},{2,2}};


You want to obtain :

Subset[l1,l2]={{1,1},{3,4}}


that is to say :

• remove elements of l1 which are in l2.
• If l1 has identical elements "elt1" you want the multiplicity of the removals to correspond to the multiplicity of "elt1" in l2.

This can be done with :

Fold[#1 /. {start___, #2, end___} :> {start, end} &, l1, l2]


{{1, 1}, {3, 4}}

The original order of l1 is preserved.

-

This is a fairly fast subtract-by-multiplicity.

deleteByMultiplicity[s1_, s2_] := Module[
{val, news2, h1},
news2 = Tally[s2];
Do[val[news2[[j, 1]]] = news2[[j, 2]], {j, Length[news2]}];
Reap[Do[
h1 = val[s1[[j]]];
If[IntegerQ[h1] && h1 > 0, val[s1[[j]]] -= 1, Sow[s1[[j]]]]
, {j, Length[s1]}]][[2, 1]]
]


Examples:

n = 4;
s1 = RandomInteger[100, {10^n, 2}];
s2 = RandomInteger[100, {Ceiling[10^n/2], 2}];

Timing[d1 = deleteByMultiplicity[s1, s2];]

(* Out[417]= {0.080000, Null} *)
Length[d1]

(* Out[413]= 7289 *)

n = 5;
s1 = RandomInteger[100, {10^n, 2}];
s2 = RandomInteger[100, {Ceiling[10^n/2], 2}];

Timing[d1 = deleteByMultiplicity[s1, s2];]

(* Out[422]= {0.660000, Null} *)

Length[d1]

(* Out[423]= 51692 *)

-
Thanks so much! – Eden Harder Dec 21 '13 at 4:09

An approach using Reap and Sow (where f is used just a wrapper):

fun[a_,b_]:=Join @@ (Table[#[[1]], {#[[2]]}] & /@ (Cases[
Last@Reap[
Join[Sow[1, f[#]] & /@a,
Sow[-1, f[#]] & /@ b], _, {#1 /. f[x_] :> x, Total@#2} &],
Except[{_, 0}]]))


fun[l1,l2] yields the desired:

{{1, 1}, {3, 4}}

Some other tests (just to be clear about what subtraction is desired):

fun[{{1, 1}, {1, 1}, {1, 1}, {1, 1}, {2, 2}, {3, 4}}, {{1, 1}, {2,
2}}]


yields:

{{1, 1}, {1, 1}, {1, 1}, {3, 4}}

If the second list contains elements that are not in the first list then the condition for the cases needs to be modified to Except[{_,_(?#<=0&)].

-