Given list of associations, generate a list of all common associations

Question

Given a list of parameters and associated values, how can I generate a list of all common associations? For instance, given

list = {{AA, 3}, {AB, 2}, {AB, 4}, {BA, 2}, {BA, 5}, {BB, 6}};

I want to obtain

{{AA, 3}, {AB, {2, 4}}, {BA, {2, 5}}, {{AB, BA}, 2}, {BB, 6}}

(Edit) Both answers from both kglr and mef will break down under certain circumstances, eg., When

list = {{{15, "->", 15}, 3}, {{15, "->", 15}, 8}, {{16, "->", 16}, 2}, {{16,"->", 16}, 3}, {{16, "->", 16}, 4}, {{16, "->", 16}, 5}, {{16, "->", 16}, 6}, {{16, "->", 16}, 7}, {{16, "->", 16}, 8}}

the solution from kglr gives

{{{15, "->", 15}, {3, 8}}, {{16, "->", 16}, {2, 3, 4, 5, 6, 7, 8}}, {{{15, "->", 15}, {16, "->", 16}}, 3}}

and the solution from mef gives

{{{15, "->", 15}, {3, 8}}, {{16, "->", 16}, {2, 3, 4, 5, 6, 7, 8}}, {{{15, "->", 15}, {16, "->", 16}}, 8}}

where the desired result is

{{{15, "->", 15}, {3, 8}}, {{16, "->", 16}, {2, 3, 4, 5, 6, 7, 8}}, {{{15, "->", 15}, {16, "->", 16}}, {3, 8}}}

(Edit #2) It may be helpful if I describe what I’m actually looking at. Given a list labeled graphs of order n which includes a mix of graphs which are pairwise either isomorphic or non-isomorphic, and each graph is uniquely identified by a number

listGi ={1,2,3,…};

Each labeled graph Gi has a Kirchhoff matrix which is invariant to some transformation from the permutation group.

KirchhoffMatrix[Gi] == Pj.KirchhoffMatrix[Gi].Transpose[Pj];

Each element of the permutation group is also uniquely identified by a number,

Pj = {1,2,3,…};

I then have a list of each Gi “associated” with an element of the permutation group which leaves its Kirchhoff matrix invariant (I ignore the identity element of the permutation group). For example, in a particular mix of graphs which are pairwise either isomorphic or non-isomorphic I have

listA = {{{1 -> 1}, 17}, {{2->2}, 17}, {{3->3}, 24}, {{4->4}, 24}, {{5->5}, 8}, {{6->6}, 17}, {{7->7}, 8}, {{8->8}, 2}, {{8->8}, 7}, {{8->8}, 8}, {{8->8}, 17}, {{8->8}, 18}, {{8->8}, 23}, {{8->8, 24}, {{9-9}, 6}, {{9-9}, 8}, {{9-9}, 10}, {{9-9}, 15}, {{9-9}, 17}, {{9-9}, 19}, {{9-9}, 24}};

What I want is a list of the Gi’s which are invariant to common Pj’s. And the list of all the P’j that leave KirchhoffMatrix[Gi] invariant which are not specified in the first instance. (LLIAMnYP describes this more rigorously with his analogy of sub-matrices.) For input listA above my desired output is:

{{{8->8}, {9->9}, {8, 17, 24}}, {{8->8}, {2,7,8,17,18,23,24}}, {{9->9},{6,8,10,15,17,19,24}}, {{{3->3},{4->4},{8,8},{9,9}}, 24}, {{{5->5},{7->7},{8->8},{9->9}}, {8}}, {{{1->1},{2->2},{6->6},{8->8},{9->9}}, 17}}

This solution is correctly obtained by LLIAMnYP in his answer. I thought I could get my point across with a single example, but I was wrong! When I repeatedly pointed out where proposed answers did not do what I wanted, I was accused of continuously changing the problem. Not true, I had to change the specific example of listA to show that the proposed answers were not solving the problem. My many thanks to LLIAMnYP for his insight and diligence to finally understand and solve my question. I am surprised that the solution proved to be as difficult as it was. And, again, I thought I could communicate the problem with a single simple example. Mr.Wizard proposed a solution which did not give the correct result. However his proposed solution did give results which were not part of my original quest, which, however, I found interesting in retrospect. His solution included those Pj which were unique to a Gi and were not otherwise included in the output list. For instance, an example from listA above, {Pj} = {2,7,18,23} are unique to {8->8}. If anyone could pose a solution which does the same thing as LLIAMnYP’s answer and included these unique “associations”, I would be grateful. I can visually compare an example input listA (one that is not too long, anyway) with the output list and see if it produces my desired output. My desired result is not ambiguous, apparently it is just tricky to describe.

Answer 1

gather[x_] := {#[[1, 1]], #[[All, -1]]}& /@ Join[GatherBy[x, First], 
 GatherBy[{#[[All, 1]], #[[1, -1]]}&/@ Select[GatherBy[x, Last], Length@# >1&], First]] /.
 {{} -> Sequence[], {a_, {y_}} :> {a, y}}

gather @ list

{{AA, 3}, {AB, {2, 4}}, {BA, {2, 5}}, {BB, 6}, {{AB, BA}, 2}}

gather @ list2

{{{15, "->", 15}, {3, 8}}, {{16, "->", 16}, {2, 3, 4, 5, 6, 7, 8}}, {{{15, "->", 15}, {16, "->", 16}}, {3, 8}}}

Answer 2

Here is an alternative approach. It relies on Merge. It works with the example, but I'm not sure it's fully general.

It's convenient to start with a list of rules:

rlist = Rule @@@ list

Here are the functions used in the merges:

fun1 = If[Length[#] == 1, #[[1]], #] &
fun2 = Sort[#][[-1]] &

Here's the main part:

List @@@
 Normal @
  Merge[{
   Normal @ Merge[rlist, fun1],
   Reverse /@ Normal @ Merge[Reverse /@ rlist, fun1]
  },
  fun2
 ]

Answer 3

list = {{AA, 3}, {AB, 2}, {AB, 4}, {BA, 2}, {BA, 5}, {BB, 6}};
list2 = {{{15, "->", 15}, 3}, {{15, "->", 15}, 8}, {{16, "->", 16}, 
    2}, {{16, "->", 16}, 3}, {{16, "->", 16}, 4}, {{16, "->", 16}, 
    5}, {{16, "->", 16}, 6}, {{16, "->", 16}, 7}, {{16, "->", 16}, 8}};

list3 = {{{1, "->", 1}, 8}, {{3, "->", 3}, 8}, {{10, "->", 10}, 
8}, {{12, "->", 12}, 8}, {{13, "->", 13}, 2}, {{13, "->", 13}, 
7}, {{13, "->", 13}, 8}, {{14, "->", 14}, 6}, {{14, "->", 14}, 
8}, {{15, "->", 15}, 3}, {{15, "->", 15}, 8}, {{16, "->", 16}, 
2}, {{16, "->", 16}, 3}, {{16, "->", 16}, 4}, {{16, "->", 16}, 
5}, {{16, "->", 16}, 6}, {{16, "->", 16}, 7}, {{16, "->", 16}, 
8}};

  fun[lista_List] := Module[{as1, as4,as5}
  ,
  as1 = GroupBy[lista, First -> Last];
  as4 = Select[Reverse@GroupBy[lista, Last -> First], Length[#] > 1 &];
  as5 = Merge[Association[Thread[Subsets[Lookup[as4, #], {2}] -> #]] & /@ Keys@as4, Identity];

  {#[[1]], Sort[#[[2]]]} & /@  Transpose[{Keys[#], List @@ Normal @@@ #}] &@ Merge[{as1, as5}, Identity]]


fun[list2]

gives me :

{{15, "->", 15}, {3, 8}}, {{16, "->", 16}, {2, 3, 4, 5, 6, 7, 8}}, {{{15, "->", 15}, {16, "->", 16}}, {3,8}}}

while

Grid@fun[list3]

gives me:

{{{1, "->", 1}, {8}}, {{3, "->", 3}, {8}}, {{10, "->", 10}, {8}}, {{12, "->", 12}, {8}}, {{13, "->", 13}, {2, 7, 8}}, {{14, "->", 14}, {6, 8}}, {{15, "->", 15}, {3, 8}}, {{16, "->", 16}, {2, 3, 4, 5, 6, 7, 8}}, {{{15, "->", 15}, {16, "->", 16}}, {3, 8}}, {{{14, "->", 14}, {16, "->", 16}}, {6, 8}}, {{{13, "->", 13}, {16, "->", 16}}, {2, 7, 8}}, {{{1, "->", 1}, {3, "->", 3}}, {8}}, {{{1, "->", 1}, {10, "->", 10}}, {8}}, {{{1, "->", 1}, {12, "->", 12}}, {8}}, {{{1, "->", 1}, {13, "->", 13}}, {8}}, {{{1, "->", 1}, {14, "->", 14}}, {8}}, {{{1, "->", 1}, {15, "->", 15}}, {8}}, {{{1, "->", 1}, {16, "->", 16}}, {8}}, {{{3, "->", 3}, {10, "->", 10}}, {8}}, {{{3, "->", 3}, {12, "->", 12}}, {8}}, {{{3, "->", 3}, {13, "->", 13}}, {8}}, {{{3, "->", 3}, {14, "->", 14}}, {8}}, {{{3, "->", 3}, {15, "->", 15}}, {8}}, {{{3, "->", 3}, {16, "->", 16}}, {8}}, {{{10, "->", 10}, {12, "->", 12}}, {8}}, {{{10, "->", 10}, {13, "->", 13}}, {8}}, {{{10, "->", 10}, {14, "->", 14}}, {8}}, {{{10, "->", 10}, {15, "->", 15}}, {8}}, {{{10, "->", 10}, {16, "->", 16}}, {8}}, {{{12, "->", 12}, {13, "->", 13}}, {8}}, {{{12, "->", 12}, {14, "->", 14}}, {8}}, {{{12, "->", 12}, {15, "->", 15}}, {8}}, {{{12, "->", 12}, {16, "->", 16}}, {8}}, {{{13, "->", 13}, {14, "->", 14}}, {8}}, {{{13, "->", 13}, {15, "->", 15}}, {8}}, {{{14, "->", 14}, {15, "->", 15}}, {8}}}

Answer 4

commonAssociations[list_] := 
 Module[{assoc = Merge[Association@*Rule @@@ list, Union], keys, vals,
    result},
  keys = Rest@Subsets[Keys@assoc];
  vals = Intersection @@@ Map[assoc, keys, {2}];
  result = DeleteCases[Thread[{keys, vals}], {_, {}}];
  Map[If[Length@# == 1, #[[1]], #] &, result, {2}]
  ]

This works on both your test cases.

For the second one:

list = {{{15, "->", 15}, 3}, {{15, "->", 15}, 8}, {{16, "->", 16}, 2},
        {{16, "->", 16}, 3}, {{16, "->", 16}, 4}, {{16, "->", 16}, 5},
        {{16, "->", 16}, 6}, {{16, "->", 16}, 7}, {{16, "->", 16}, 8}};
commonAssociations[list]

{{{15, "->", 15}, {3, 8}}, {{16, "->", 16}, {2, 3, 4, 5, 6, 7, 8}},
 {{{15, "->", 15}, {16, "->", 16}}, {3, 8}}}

Explanation:
As I understand, the input is a list of pairs {{key1, value1}, ...}. First we group values associated to each key (Merge[Association@*Rule @@@ list, Union]).

Common associations I interpret as values common to more than one key. So I take all possible subsets of the keys keys = Rest@Subsets[Keys@assoc]; then get the values associated to each of these subsets Map[assoc, keys, {2}] then extract those values, which where common for every key in the subset by taking the intersection of the lists of values (Intersection@@@).

Finally, I delete associations to subsets of keys that had no common element (that is { set_of_keys, {(*no values here*)}}) which are matched by the pattern {_, {}}) and then replace all lists of length 1 by their only element.

Update 05.03.18
My algorithm above, unfortunately, grows exponentially with the number of keys (there are 2^n subsets of n keys). For the examples provided by OP the number of keys was quite small, but for a general solution a different approach is probably in order. Before going on, I'd acknowledge that I do not have a solution to this right now, but there is an alternative take to this problem which may be of interest: let's take a new example list that was provided in a comment:

list = 
{{{14, "->", 14}, 6}, {{14, "->", 14}, 8}, {{14, "->", 14}, 10},
 {{15, "->", 15}, 3}, {{15, "->", 15}, 8}, {{15, "->", 15}, 11},
 {{16, "->", 16}, 2}, {{16, "->", 16}, 3}, {{16, "->", 16}, 4},
 {{16, "->", 16}, 5}, {{16, "->", 16}, 6}, {{16, "->", 16}, 7},
 {{16, "->", 16}, 8}, {{16, "->", 16}, 9}, {{16, "->", 16}, 10},
 {{16, "->", 16}, 11}, {{16, "->", 16}, 12}}

I'm not particularly interested in what exactly the keys and values are, so I'll simply enumerate them with a helper function:

Block[{key, val, k = 0, v = 0},
  key[x_] := key[x] = ++k; val[x_] := val[x] = ++v; {key@#1, val@#2} & @@@ list]

{{1, 1}, {1, 2}, {1, 3}, {2, 4}, {2, 2}, {2, 5}, {3, 6}, {3, 4},
 {3, 7}, {3, 8}, {3, 1}, {3, 9}, {3, 2}, {3, 10}, {3, 3}, {3, 5}, {3, 11}}

MatrixPlot@SparseArray@Thread[% -> 1]

So In a way, what the OP wants, is to pick out the largest sub-matrices of this matrix which are

• filled with ones.
• cover all the non-zero entries of the original matrix
• and no sub-matrix should be the sub-matrix of another one.

My algorithm failed here, since it generates redundantly e.g. the following associations:

{{1, 2}, 2}
{{1, 2, 3}, 2}

This is easily fixed by adding an extra step to my algorithm:

commonAssociations[list_] := 
 Module[{assoc = Merge[Association@*Rule @@@ list, Union], keys, vals,
    result},
  keys = Rest@Subsets[Keys@assoc];
  vals = Intersection @@@ Map[assoc, keys, {2}];
  result = DeleteCases[Thread[{keys, vals}], {_, {}}];
  result = Union@@@GroupBy[result, Last -> First];
  result = Thread[{Values[result], Keys[result]}];
  Map[If[Length@# == 1, #[[1]], #] &, result, {2}]
  ]

Since the order of key-value pairs doesn't matter, one can, at the very least, write a helper function that will automatically reverse the key-value pairs, so as to work with the subsets of the smaller set of the two.

Update 06.03.18
Having shown, that this problem amounts to selecting a number of submatrices, I find that

• Given a large binary matrix, find the largest submatrix containing non-zero elements

is very relevant here. However, I still do not see a trivial way to move forward here.

Answer 5

I'm not entirely clear on what you want but I think this might be it, and fairly cleanly.

I'll start with more concise data to reduce clutter:

list = {{"dog", 3}, {"dog", 8}, {"cat", 2}, {"cat", 3}, {"cat", 4},
        {"cat", 5}, {"cat", 6}, {"cat", 7}, {"cat", 8}, {"bird", 7}};

Note the inclusion of {"bird", 7} as there is no analog in your example.

m = Normal @* Merge[Identity];
mr = m @ Reverse[#, 2] &;
rls = Rule @@@ list;

m @ rls
mr @ mr @ rls

{"dog" -> {3, 8}, "cat" -> {2, 3, 4, 5, 6, 7, 8}, "bird" -> {7}}
{{"dog", "cat"} -> {3, 8}, {"cat"} -> {2, 4, 5, 6}, {"cat", "bird"} -> {7}}

My question to you is which parts of the second output line do you want to keep?

Answer 6

Using

atomizeSingleton = ReplaceAll[{x_} :> x];

The query:

list  // Query[{GroupBy[First -> Last] /* atomizeSingleton, 
     GroupBy[Last -> First] /* atomizeSingleton /* Normal /* 
      Map[Reverse] /* Association} /* Merge[Flatten /* Union]] // 
 KeyValueMap[List /* atomizeSingleton]

{{AA, 3}, {AB, {2, 4}}, {BA, {2, 5}}, {BB, 6}, {{AB, BA}, 2}}

Answer 7

(Edit) Second Attempt

list

(list // Rest@Subsets[DeleteDuplicates[#[[All, 1]]]] & // (Transpose[{#,
Intersection @@@ Join[# /. GroupBy[list, First -> Last]]}] /. {x_} -> 
   x) &) /. {{x__}, {}} -> Nothing

{{AA, 3}, {AB, {2, 4}}, {BA, {2, 5}}, {BB, 6}, {{AB, BA}, 2}}

Or as a function

assocs := Function[x, (x // Rest@Subsets[DeleteDuplicates[#[[All, 1]]]] &
 // (Transpose[{#, 
      Intersection @@@ 
       Join[# /. GroupBy[x, First -> Last]]}] /. {x_} -> 
     x) &) /. {{x__}, {}} -> Nothing]

list2

assocs@list2

{{{15, "->", 15}, {3, 8}}, {{16, "->", 16}, {2, 3, 4, 5, 6, 7, 8}}, {{{15, "->", 15}, {16, "->", 16}}, {3, 8}}}

list3

assocs@list3

{{"dog", 8}, {"cat", {2, 7, 8, 17, 18, 23, 24}}, {"bird", {6, 8, 10, 15, 17, 19, 24}}, {"rat", {3, 8, 11, 14, 17, 22, 24}}, {"man", {2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23}}, {{"dog", "cat"}, 8}, {{"dog", "bird"}, 8}, {{"dog", "rat"}, 8}, {{"dog", "man"}, 8}, {{"cat", "bird"}, {8, 17, 24}}, {{"cat", "rat"}, {8, 17, 24}}, {{"cat", "man"}, {2, 7, 8, 17, 18, 23}}, {{"bird", "rat"}, {8, 17, 24}}, {{"bird", "man"}, {6, 8, 10, 15, 17, 19}}, {{"rat", "man"}, {3, 8, 11, 14, 17, 22}}, {{"dog", "cat", "bird"}, 8}, {{"dog", "cat", "rat"}, 8}, {{"dog", "cat", "man"}, 8}, {{"dog", "bird", "rat"}, 8}, {{"dog", "bird", "man"}, 8}, {{"dog", "rat", "man"}, 8}, {{"cat", "bird", "rat"}, {8, 17, 24}}, {{"cat", "bird", "man"}, {8, 17}}, {{"cat", "rat", "man"}, {8, 17}}, {{"bird", "rat", "man"}, {8, 17}}, {{"dog", "cat", "bird", "rat"}, 8}, {{"dog", "cat", "bird", "man"}, 8}, {{"dog", "cat", "rat", "man"}, 8}, {{"dog", "bird", "rat", "man"}, 8}, {{"cat", "bird", "rat", "man"}, {8, 17}}, {{"dog", "cat", "bird", "rat", "man"}, 8}}

list4

assocs@list4

{{"dog", {6, 8, 10}}, {"cat", {3, 8, 11}}, {"bird", {2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12}}, {{"dog", "cat"}, 8}, {{"dog", "bird"}, {6, 8, 10}}, {{"cat", "bird"}, {3, 8, 11}}, {{"dog", "cat", "bird"}, 8}}

where:

list = {{AA, 3}, {AB, 2}, {AB, 4}, {BA, 2}, {BA, 5}, {BB, 6}};
list2 = {{{15, "->", 15}, 3}, {{15, "->", 15}, 8}, {{16, "->", 16}, 
2}, {{16, "->", 16}, 3}, {{16, "->", 16}, 4}, {{16, "->", 16}, 
5}, {{16, "->", 16}, 6}, {{16, "->", 16}, 7}, {{16, "->", 16}, 
8}};
list3 = {{"dog", 8}, {"cat", 2}, {"cat", 7}, {"cat", 8}, {"cat", 
17}, {"cat", 18}, {"cat", 23}, {"cat", 24}, {"bird", 6}, {"bird", 
8}, {"bird", 10}, {"bird", 15}, {"bird", 17}, {"bird", 
19}, {"bird", 24}, {"rat", 3}, {"rat", 8}, {"rat", 11}, {"rat", 
14}, {"rat", 17}, {"rat", 22}, {"rat", 24}, {"man", 2}, {"man", 
3}, {"man", 4}, {"man", 5}, {"man", 6}, {"man", 7}, {"man", 
8}, {"man", 9}, {"man", 10}, {"man", 11}, {"man", 12}, {"man", 
13}, {"man", 14}, {"man", 15}, {"man", 16}, {"man", 17}, {"man", 
18}, {"man", 19}, {"man", 20}, {"man", 21}, {"man", 22}, {"man", 
23}};
list4 = {{"dog", 6}, {"dog", 8}, {"dog", 10}, {"cat", 3}, {"cat", 
8}, {"cat", 11}, {"bird", 2}, {"bird", 3}, {"bird", 4}, {"bird", 
5}, {"bird", 6}, {"bird", 7}, {"bird", 8}, {"bird", 9}, {"bird", 
10}, {"bird", 11}, {"bird", 12}};

Original Answer

(I still think this is the most reasonable interpretation of the OP question as posted.)

(list // KeyValueMap[{##} &, Merge[{KeyMap[List, GroupBy[#, {First -> Last}]], 
   PositionIndex[GroupBy[#, Last -> First]]}, DeleteDuplicates@*Flatten]] &) /. {x_} -> x

{{AA, 3}, {AB, {2, 4}}, {BA, {2, 5}}, {BB, 6}, {{AB, BA}, 2}}

list // Merge[{KeyMap[List, GroupBy[#, {First -> Last}]], 
PositionIndex[GroupBy[#, Last -> First]]}, DeleteDuplicates@*Flatten] &

<|{AA} -> {3}, {AB} -> {2, 4}, {BA} -> {2, 5}, {BB} -> {6}, {AB, BA} -> {2}|>