# How do you turn a normal intersection to a strict one for arbitrary number of sets?

What is the best way to generalize the following interaction of 3 sets to any number of sets:

intersections[assoc_Association]:=Block[{
α0,α1,α2,α3,α1α2,α1α3,α2α3,α1α2α3
},
{α0,α1,α2,α3,α1α2,α1α3,α2α3,α1α2α3}=Values@assoc;
α0-(α1+α2+α3-α1α2-α1α3-α2α3+α1α2α3),
α1-α1α2-α1α3+α1α2α3,
α2-α1α2-α2α3+α1α2α3,
α3-α1α3-α2α3+α1α2α3,
α1α2-α1α2α3,
α1α3-α1α2α3,
α2α3-α1α2α3,
α1α2α3
}]]
]


The function applied to a particular collection:

intersections@<|"Total"->50,"Boys"->25,"Passed"->30,"Athletic"->28,"Boys"⊓"Passed"->16,"Boys"⊓"Athletic"->18,"Passed"⊓"Athletic"->17,"Boys"⊓"Passed"⊓"Athletic"->15|>


Produces:

<|"Rest" -> 3, "Boys" -> 6, "Passed" -> 12, "Athletic" -> 8,
"Boys" ⊓ "Passed" -> 1,
"Boys" ⊓ "Athletic" -> 3,
"Passed" ⊓ "Athletic" -> 2,
"Boys" ⊓ "Passed" ⊓
"Athletic" -> 15|>


Below is a general layout of inputs for a varying number of sets:

### The mathematical setup

I'll spare you the mathematical proof (unless you want it!), but say:

• $$\cal G$$ is the set of atomic labels (like "Passed")
• We identify the powerset $$\cal PG$$ as the set of strings formed from them (e.g. $$\{$$"Boys"$$\text{, }$$"Passed"$$\}$$ corresponds to "Boys" ⊓ "Passed". Note the switch that happens here: If $$\cal N,M\in PG$$ satisfy $$\cal N \subseteq M$$, then the "actual intersections" corresponding to those sets $$[{\cal N}],[{\cal M}]$$ (e.g. the actual set represented by "Boys" ⊓ "Passed") would satisfy $$[{\cal N}] \supseteq [{\cal M}]$$.
• for $${\cal N}\subseteq{\cal G}$$, define $$\gamma({\cal N})$$ to be the "count" of the element corresponding to $$[{\cal N}]$$, i.e. the number you're given in your input association.
• for $$\cal N \subseteq G$$, define $$\chi({\cal N})$$ to be the size of the "exclusive" intersection of the atoms in $$\cal N$$, i.e. the number you want to calculate.

Then for any $$\cal N \subseteq G$$ we have

$$\chi({\cal N})=\sum_{\cal M \supseteq N} (-1)^{\left|{\cal M}\right|-\left|{\cal N}\right|}\gamma({\cal N})$$

I.e. it's the sum over the sizes of all "supersets", graded by number of elements in the set. (I put supersets in scare quotes because we need to keep straight what is a superset in our set of labels, i.e. in $$\cal G$$, and what would be a superset among the "actual" represented sets, like "Boys" ⊓ "Passed", since these are opposite notions. Here, I mean the former, which is equivalent to asking for all "actual" subsets.)

So, with that in hand, let's set up the code.

### The code

(Don't worry, I'll collect all the code in a block at the end!)

Setting up

Just for the sake of keeping things organized, I recommend using different notation for the representations of intersections as is commonly defined vs. exclusive intersections. Here I'll use Wedge for the typical notion of intersection (input) and SquareIntersection for the exclusive one (signaling by its squareness that there's a notion of "disjointness" among the results, in keeping with the notation for disjoint union). (If you don't like this, feel free to simply find+replace Wedge with SquareIntersection before evaluating.)

Just to make sure those are commutative and behave like the identity function when evaluated with a single argument:

SetAttributes[{Wedge, SquareIntersection}, Orderless]
Wedge[a_] := a; SquareIntersection[a_] := a;
Wedge[] := "Total"; SquareIntersection[] := "Rest";


(I'd also like to make these Flat to make them associative, but that interferes with the null definition somehow; not sure how to fix that.)

Name a pattern that matches intersections and exclusive intersections:

intersection = Association[((_String | Wedge[__String]) -> _Integer)...];
exintersection = Association[((_String | SquareIntersection[__String]) ->  _Integer)...];


Note that these are pretty broad as patterns—they don't check that all elements are included, and they don't check that the numbers satisfy the constraints they need to (for example, "Total" has to be bigger than all other elements, "a" \[Wedge] "b" must be less than both "a" and "b", etc.)

We'll use Combinatorica's NthSubset function for quick identification of subsets with integers. NthSubset[n, l] gives the nth subset of list, for some built-in way of indexing the subsets. So, instead of having a value for $$\chi({\cal N})$$ per se, we'll actually just store a value for $$\chi(n)$$, where $$n$$ is whatever number NthSubset assigns to that subset.

Quiet @ Get["Combinatorica"]


There are two nice things about NthSubset[n, list].

One is that it goes through the subsets in order of size. This ensures that if NthSubset[n, list] $$\subseteq$$ NthSubset[m, list], then $$n \leq m$$. So we can be sure that progressing through the integer indices n will never "miss out" any subset; that is, if we start at 0 and increase our index up to n, then by the time we get to NthSubset[n, list], we'll have already encountered all of its subsets.

The other nice thing is that you can use negative numbers too. This lets you start with the full set at n = -1 and progress down through its subsets. So if you start at -1 and go down, by the time you reach NthSubset[-n, list], you'll have encountered all of its supersets. This is what we want!

Let's note that for an intersection count association <| "Total" -> x0, "A1" -> x1, "A2" -> x2, "A1" \[Wedge] "A2" -> x3, <...> |>, we want to represent the keys of the association like "A1" \[Wedge] "A2" by a subset of the "generating elements" {"A1", "A2", "A3", <...>}. So we need to extract the basis from an intersection association:

gens[a : intersection] := Cases[Keys[a], Except["Total", _String]]


Computation

In a context where some intersection count association a is defined, agens is gens[a], l0 is Length[agens], and we have all of these variables as temporary ones, we expect to naively define

\[Chi][n_] := (
calN = NthSubset[-n, agens];
l = Length[calN];
chi0 = 0;
Do[
calM0 = NthSubset[m, Complement[agens, calN]];
chi0 += If[EvenQ[Length[calM0]], 1, -1] * a[Wedge @@ Join[calN,calM0]];,
{m, 2^(l0 - l)}];
(SquareIntersection @@ calN) -> chi0)


where this returns the rule that associates calN to its new value.

I do it with a Do to avoid using up too much memory for sufficiently large sets, but I don't know—maybe building up the list and using Total is better. Another way to do this is, if a0 = Normal[a],

length0[] := 0
length0[e_] := 1
length0[e0_, e1__] := Length[{e0, e1}]
length0[w_Wedge] := Length[w]

\[Chi][n_] := (
calN = NthSubset[n, agens];
chi0 = 0;
Replace[a0,
((Wedge @@ calN | Wedge @@ Append[calN, s__]) -> x_) :> (chi0 += If[EvenQ[length0[s]], x, -x];), 1];
(SquareIntersection @@ calN) -> chi0)


which is a bit harder to read, but a bit faster on a single kernel. I wish I could just do Wedge @@ Append[calN, s___], but it doesn't work as you'd expect with single arguments. Also, the helper function length0 unfortunately seems necessary as opposed to Length[{s}], since sometimes—and I'm not sure when or why—Mathematica seems to pass s wrapped in Wedge. However, the above Do could be parallelized, which might be better.

exclusivize[a : intersection] :=
Module[{a0 = Normal[a], agens = gens[a], calN, \[Chi], chi0},
\[Chi][n_] := (
calN = NthSubset[n, agens];
chi0 = 0;
Replace[a0,
((Wedge @@ calN | Wedge @@ Append[calN, s__]) -> x_) :> (chi0 += If[EvenQ[length0[s]], x, -x];), 1];
SquareIntersection @@ calN) -> chi0);
Association @ Table[\[Chi][k], {k, 0, 2^Length[agens] - 1}]
]


Importantly, we can do this in parallel, by using ParallelTable, but we need to be sure to give it the option DistributedContexts -> Full so that it can use Combinatorica (or something more specific involving "Combinatorica\", if you've got lots of contexts you don't want to distribute). However, this still seems to behave differently than the normal code, even when attempting to account for variable nonlocality. (I'm going to look into this further and see if it's a bug.)

We can also parallelize \[Chi] in a couple different ways; by using a ParallelDo as mentioned earlier (but this takes a bit more work to make sure variables are shared/not shared appropriately), or by dividing up a0 into chunks and working on it in parallel, but this takes a bit more work. (I'll add it if I get the chance; let me know if it would be useful to you!)

Potential optimizations

There are still quite a few optimizations available, I think.

For future testing, I wrote a function that generates (real) random intersections:

RandomIntersection[n_, pool_] :=
With[{G =
Table[{ToString[i], RandomSubset[Table[i, {i, pool}]]}, {i, n}]},
Association[
If[MatchQ[#, {}], "Total" -> Table[i, {i, pool}],
Wedge @@ (First /@ #) -> Intersection @@ (Last /@ #)] & /@
Subsets[G]]]

RandomIntersectionCounts[n_, pool_] := Length /@ RandomIntersection[n, pool]


For example, inlining \[Chi] sped things up a bit. I also think it's possible to speed up the pattern matching by encoding each key as a binary number in the obvious way (each atom gets a position, that position is 1 if and only if the atom appears in the key), and using BitOr or BitAnd (and checking equality) to determine the subset relation on keys, so that could be interesting.

Code block

Since it turns out that inlining the definition of \[Chi] right into the definition of Table gives a small speedup, that's what I'll do in the final code.

Quiet @ Get["Combinatorica"]

ClearAll[Wedge, SquareIntersection, gens, exclusivize, parallelExclusivize]

SetAttributes[{Wedge, SquareIntersection}, Orderless]

Wedge[a_] := a; SquareIntersection[a_] := a;
Wedge[] := "Total"; SquareIntersection[] := "Rest";

intersection = Association[(_String | Wedge[__String] -> _Integer) ...];
exintersection =
Association[((SquareIntersection[__String] | _String) -> _Integer) \
...];

gens[a : intersection] := Cases[Keys[a], Except["Total", _String]]

length0[] := 0
length0[e_] := 1
length0[e0_, e1__] := Length[{e0, e1}]
length0[w_Wedge] := Length[w]

exclusivize[a : intersection] :=
Module[{a0 = Normal[a], agens = gens[a], calN, \[Chi], chi0},
Association@Table[(calN = NthSubset[n, agens];
chi0 = 0;
Replace[a0,
((Wedge @@ calN | Wedge @@ Append[calN, s__]) -> x_) :> (chi0 += If[EvenQ[length0[s]], x, -x];), 1];
SquareIntersection @@ calN -> chi0), {n, 0, 2^Length[agens] - 1}]
]

(* Testing *)

a = <|"Total"->50,"Boys"->25,"Passed"->30,"Athletic"->28,"Boys"⊓"Passed"->16,"Boys"⊓"Athletic"->18,"Passed"⊓"Athletic"->17,"Boys"⊓"Passed"⊓"Athletic"->15|>;
a = KeyMap[# /. SquareIntersection -> Wedge &, a];

exclusivize[a]

RandomIntersection[n_, pool_] :=
With[{G =
Table[{ToString[i], RandomSubset[Table[i, {i, pool}]]}, {i, n}]},
Association[
If[MatchQ[#, {}], "Total" -> Table[i, {i, pool}],
Wedge @@ (First /@ #) -> Intersection @@ (Last /@ #)] & /@
Subsets[G]]]

RandomIntersectionCounts[n_, pool_] := Length /@ RandomIntersection[n, pool]

A = RandomIntersection[10, 200];
a = Length /@ A;

ea = exclusivize[a];

Total[Values[ea]] == 200



You might also want to change the intersection pattern to use simply _ or _Integer | _Symbol instead of just _Integer as a value, so that you can use abstract terms.

Let me know if you want the proof of the formula for $$\chi$$ or clarification on anything I've said! :)

1- calculate subsets of your primary variables (excluding {}):

ss = Select[Subsets[{a1, a2, a3}], Length@# > 0 &]

(*Out: {{a1}, {a2}, {a3}, {a1, a2}, {a1, a3}, {a2, a3}, {a1, a2, a3}} *)


2- Define a function that extracts lists contain given input:

ch[elem_List] := Select[ss, ContainsAll[#, elem] &]

ch[{a1}]

(*Out: {{a1}, {a1, a2}, {a1, a3}, {a1, a2, a3}}*)


3- Define another function to make the final expression:

mySum[elem_List] := Module[{gb},
gb = GatherBy[elem,
StringCount[ToString@#, "a"] &];

Plus @@ Flatten@Join[gb[[;; ;; 2]], gb[[2 ;; ;; 2]]*-1]
]

mySum[{a1, a1a2, a1a3, a1a2a3}]

(*Out: a1 - a1a2 + a1a2a3 - a1a3 *)


4- Map ToString to all sub-elements, then joined them and apply Symbol:

Map[Symbol@StringJoin[ToString /@ #] &, ch /@ ss, {2}]

(*Out: {{a1, a1a2, a1a3, a1a2a3}, ... , {a2a3, a1a2a3}, {a1a2a3}} *)


Map mySum:

mySum /@ Map[Symbol@StringJoin[ToString /@ #] &, ch /@ ss, {2}]

(*Out: {a1 - a1a2 + a1a2a3 - a1a3, ... , -a1a2a3 + a2a3, a1a2a3} *)


5- Generate first expression which includes a0:

mySum@Prepend[Symbol@StringJoin[ToString /@ #] & /@ ss, b0] /.
b0 -> a0;

(*Out: a0 - a1 + a1a2 - a1a2a3 + a1a3 - a2 + a2a3 - a3 *)


Because mySum calculation is base on how many a is in the symbol, variable names should have single a like a1, a2, ...

Full code:

ss = Select[Subsets[{a1, a2, a3}], Length@# > 0 &];

ch[elem_List] := Select[ss, ContainsAll[#, elem] &];

mySum[elem_List] := Module[{gb},
gb = GatherBy[elem,
StringCount[ToString@#, "a"] &];

Plus @@ Flatten@Join[gb[[;; ;; 2]], gb[[2 ;; ;; 2]]*-1]
]

mySum@Prepend[Symbol@StringJoin[ToString /@ #] & /@ ss, b0] /. b0 -> a0

mySum /@ Map[Symbol@StringJoin[ToString /@ #] &, ch /@ ss, {2}]


Outputs:

a0 - a1 + a1a2 - a1a2a3 + a1a3 - a2 + a2a3 - a3

{a1 - a1a2 + a1a2a3 - a1a3, -a1a2 + a1a2a3 + a2 - a2a3,
a1a2a3 - a1a3 - a2a3 + a3,
a1a2 - a1a2a3, -a1a2a3 + a1a3, -a1a2a3 + a2a3, a1a2a3}
`