# Extracting sublists that contain similar elements

Let's say I have a list containing different sized sublists of string pairs structured like this

{{{"A", "B"}, {"C", "D"}}, {{"E", "D"}, {"G","B"}}, {{"H", "B"}}, {{"I", "B"}}}


where the first and second sublists each contain two string pairs and the third and fourth sublists each contain 1 string pair.

I want to get rid of every string pair where the second string of the string pair does not appear in each sublist. For example, there exists string pairs in each sublist where the second string of the string pair is "B". Thus, I only want to keep those string pairs. The final list should look like this

{{{"A", "B"}}, {{"G","B"}}, {{"H", "B"}}, {{"I", "B"}}}


Although each of the first two sublists contain a pair of strings where there is a "D" in the second element, these need to be removed since there aren't string pairs containing "D"'s in the second element of the string pairs in the third and fourth sublists.

I would like for this function to work no matter the number of sublists and no matter the number of elements contained in those sublists. I know how to do this if the list was completely flattened, but it is not in this case. There is no need for this to be an efficient process, so anything that can produce these results would be helpful. Any ideas?

I assume that it's always the second element that determines sublist eligibility:

L = {{{"A", "B"}, {"C", "D"}}, {{"E", "D"}, {"G", "B"}}, {{"H", "B"}}, {{"I", "B"}}};

Cases[{_, Alternatives @@ Intersection @@ L[[All, All, 2]], ___}] /@ L


{{{"A", "B"}}, {{"G", "B"}}, {{"H", "B"}}, {{"I", "B"}}}

If instead it's always the last element, then the pattern would be

Cases[{___, Alternatives @@ Intersection @@ L[[All, All, -1]]}] /@ L


{{{"A", "B"}}, {{"G", "B"}}, {{"H", "B"}}, {{"I", "B"}}}

• Sorry, I should have been more clear. Both work in my case. Thank you very much! – Eric May 11 '19 at 21:29
ClearAll[f1]
f1 = Apply[Join]@*Values@*KeyIntersection@*Map[GroupBy[Last]];

lst = {{{"A", "B"}, {"C", "D"}}, {{"E", "D"}, {"G", "B"}}, {{"H", "B"}}, {{"I", "B"}}};
f1 @ lst


{{{"A", "B"}}, {{"G", "B"}}, {{"H", "B"}}, {{"I", "B"}}}

DeleteCases seems to be faster:

ClearAll[f2]
f2 = DeleteCases[#, Except@{___, Alternatives @@ Intersection @@ #[[All, All, -1]]}, {2}]&;

f2 @ lst


{{{"A", "B"}}, {{"G", "B"}}, {{"H", "B"}}, {{"I", "B"}}}

• By applying my method at Cases-level 2 and then re-Listing, you lose information when multiple list members qualify: try L = {{{"A", "B"}, {"C", "D"}, {"X", "B"}}, {{"E", "D"}, {"G", "B"}}, {{"H", "B"}}, {{"I", "B"}}}, where your method takes the first list apart into {{"A", "B"}}, {{"X", "B"}} instead of keeping its structure as {{"A", "B"}, {"X", "B"}}. Not sure what's the right behavior in this question though. – Roman May 12 '19 at 6:34
• @Roman, very good point. I think the result for your example should be {{"A", "B"}, {"X", "B"}}. I removed Cases[... ,2] and replaced it with DeleteCases. – kglr May 12 '19 at 7:40
list={{{"A","B"},{"C","D"}},{{"E","D"},{"G","B"}},{{"H","B"}},{{"I","B"}}};

List/@Select[Flatten[list,1],MemberQ[Last@@@Select[list,Length@#==1&],#[[2]]]&]


{{{"A", "B"}}, {{"G", "B"}}, {{"H", "B"}}, {{"I", "B"}}}

a = {{{"A", "B"}, {"C", "D"}}, {{"E", "D"}, {"G", "B"}}, {{"H","B"}}, {{"I", "B"}}}
f = Select[ContainsAny[Intersection @@ Union @@@ #]@*List@*Last] /@ # &;

f[a]


{{{"A", "B"}}, {{"G", "B"}}, {{"H", "B"}}, {{"I", "B"}}}