Fast way to compute intersection of equivalence classes

Question

There is a set $S=\{1, 2, \dots, m\}$ and $n$ equivalence relations on the set: $a \sim_i b $, where $a,b \in S$, $i=1, \dots, n$. Now we define $a \sim b$ iff $ a \sim_i b$ $\forall i=1, \dots, n$.

The equivalence relations $\sim_i$ are given with the equivalence classes and our task is to calculate the equivalence classes of $\sim$.

What is a fast way to compute it?

In the following example $n=3$ and $m=60$.

We have the equivalence classes in a list (the first element of the list corresponds to the first equivalence relations and so on) as lists of lists:

input = {
 {{1, 56, 47, 48, 15, 18, 25, 33, 35, 24, 50, 60, 5, 59, 2, 21, 22, 
   29, 30, 8, 17, 23, 36, 49, 9, 19, 26, 42, 52, 40, 51, 27, 46, 58, 
   16, 34, 53, 20, 41, 39, 54, 13, 31, 7, 55, 11, 10, 6, 37, 14, 12, 
   3, 43, 57}, {38, 44}, {45}, {32}, {28}, {4}},
 {{1, 10, 27, 35, 14, 34, 2, 21, 17, 52, 54, 58, 11, 29, 45, 40, 51,
   5, 23, 25, 46, 16, 7, 30, 9, 20, 47, 42, 60, 15, 18, 33, 57, 41, 22,
   50, 13, 24, 26, 39, 48, 49, 56, 53, 19, 59, 36, 6, 8, 37, 3, 28, 12,
   43, 31}, {55}, {44}, {38}, {32}, {4}},
 {{1, 10, 27, 35, 56, 6, 14, 2, 55, 48, 7, 47, 12, 18, 22, 26, 17, 52,
   58, 8, 25, 59, 41, 39, 49, 9, 46, 60, 16, 23, 33, 34, 30, 45, 20,
   24, 37, 40, 36, 19, 50, 21, 11, 29, 3, 15, 28, 13, 31, 53, 5, 42,
   57}, {38, 44}, {54}, {51}, {43}, {32}, {4}}
}

And the output should be the equivalence classes of the intersection of the equivalence relations:

output = {{1, 2, 3, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 
  21, 22, 23, 24, 25, 26, 27, 29, 30, 31, 33, 34, 35, 36, 37, 39, 40, 
  41, 42, 46, 47, 48, 49, 50, 52, 53, 56, 57, 58, 59, 
  60}, {54}, {51}, {43}, {55}, {44}, {38}, {45}, {32}, {28}, {4}}

I know how to do it as a brute-force but I am sure there are much efficient ways to do it:

Select[Flatten[Apply[Outer[Intersection, ##, 1] &, input], 2], UnsameQ[#, {}] &]

Answer 1

As a first stab at things, let's at least do things sequentially rather than "Outering" everything together. Let's take a simpler version:

input = {
  {{1, 2, 3, 4}, {5, 6, 7, 8, 9}, {10}},
  {{1, 2, 3}, {4, 5, 6, 7}, {8, 9}, {10}},
  {{1, 2, 3, 4}, {5}, {6, 7}, {8, 9, 10}}
 };

and do (using a simpler version of OP's code):

op = Cases[Apply[Outer[Intersection, ##, 1] &, input], {__}, {Length@input}];
march = Fold[Cases[Outer[Intersection, ##, 1], {__}, {2}] &, input]
op === march
(* {{1, 2, 3}, {4}, {5}, {6, 7}, {8, 9}, {10}} *)
(* True *)

This compares one set of equivalence classes to the next and refines them into a new set of equivalence classes, which is then compared to the next one in the list. This led to a factor of 3 or 4 speed up on the OP's example. I have not done any more testing, although having to select out the non-empty lists at every step is likely very time-consuming.