Destacar elementos na lista usando correspondência de padrões
A partir do seguinte list
:
list = {{a, b, c}, {d, e, f}, {g, h, i}, {b, c, d}, {c, a, m}, {c, d, n}};
Quero destacar os elementos em list
cuja interseção é maior que 2.
O código a seguir não pode obter o resultado que desejo:
list //.
{{a___, x:{_, _, _}, b___, y:{_, _, _}, c___} /;
Length@Intersection[x, y] >= 2 :>
{a, Style[x, Gray], b, Style[y, Gray], c}}

O resultado desejado é

Eu também considerei Gather
, mas isso vai mudar a ordem da lista.
Atualizado:
pensei em uma maneira, não elegante
list //. {a___,x:({_,_,_}|F[{_,_,_}]),b___,y:({_,_,_}),c___}/;
Length[Intersection[x/.F->Identity,y]]>=2:>{a,F@x,b,F@y,c}
% /. F->Highlighted
Respostas
rg = RelationGraph[UnsameQ @ ## && Length@Intersection[##] >= 2 &, list]

hl = VertexList @ EdgeList @ rg
{{a, b, c}, {b, c, d}, {c, a, m}, {c, d, n}}
list /. x : Alternatives @@ hl :> Style[x, Gray]

list /. x : Alternatives @@ hl :> Highlighted[x, BaseStyle -> Red]

HighlightGraph[rg, hl]

Você também pode usar ConnectedComponentse selecionar componentes com mais de 1 vértice:
ccs = Select[Length @ # >= 2 &] @ ConnectedComponents[rg]
{{{a, b, c}, {b, c, d}, {c, a, m}, {c, d, n}}}
list /. x : Alternatives @@ # :> Highlighted[x, BaseStyle -> Red]& /@ ccs

ClearAll[formatList]
formatList[list_] := Module[{rules},
rules =
AssociationThread[
list -> (If[Max[#] >= 2, Gray, Black] & /@
Function[{element},
Length@Intersection[element, #] & /@
Complement[list, {element}]] /@ list)
];
Style[#, rules[#]] & /@ list
]
formatList[list]

Uma variante da solução do OP que evita aninhamento de Highlighted
:
list //. {a___, x : ({_, _, _} | Highlighted[{_, _, _}, ___]), b___,
y : ({_, _, _}), c___} /; Length[Intersection[x /. Highlighted -> (# &), y]] >= 2 :>
{a, Highlighted[x /. Highlighted -> (# &)], b, Highlighted@y, c}

Mesma abordagem usando Style
:
list //. {a___, x : ({_, _, _} | Style[{_, _, _}, ___]), b___,
y : ({_, _, _}), c___} /; Length[Intersection[x /. Style -> (# &), y]] >= 2 :>
{a, Style[x /. Style -> (# &), Gray], b, Style[y /. Style -> (# &), Gray], c}

Acho que a maneira mais fácil ainda é usar Gather
e reordenar o índice. Aqui tratamos da situação geral.
SeedRandom[400];
list = Table[RandomSample[Alphabet[], 3], 40];
newlist = Thread[Range[Length@list] -> list];
result = Gather[newlist,
Length[Intersection[Last@#1, Last@#2]] >= 2 &];
keys = Keys /@ result;
keyc = Thread[keys -> RandomColor[Length@keys]]
map[j_] :=
MapAt[Style[#, Last@keyc[[j]], Bold] &, List /@ First@keyc[[j]]];
fig = Composition[Sequence @@ Table[map[j], {j, 1, Length@keyc}]]@
list
Grid[Partition[fig, 8], Frame -> All]

list /. x : {__Symbol} /;
Max[Length[Intersection[x, #]] & /@ DeleteCases[list, x]] >= 2 :>
Style[x, Gray]

Um método que usa GatherBy
:
gb = Join @@ Select[Length@# > 1 &]@
GatherBy[list, Function[x, Max[Length[Intersection[x, #]] & /@ DeleteCases[x][list]]]]
{{a, b, c}, {b, c, d}, {c, a, m}, {c, d, n}}
list /. x : Alternatives @@ gb :> Style[x, Gray]

Por Gather
que não funciona:
Tomando um exemplo mais simples:
list2 = Partition[Range@5, 3, 1];
GatherBy[list2, Function[x, Max[Length[Intersection[x, #]] & /@
DeleteCases[x][list2]] >= 2]]
{{{1, 2, 3}, {2, 3, 4}, {3, 4, 5}}}
Gather[list2, Length[Intersection[##]] >= 2 &]
{{{1, 2, 3}, {2, 3, 4}}, {{3, 4, 5}}}
Gather
não executa a função de teste em todos os pares da lista de entrada. Se a função de teste for avaliada como True
para o par {p1, p2}
(de modo que p1
e p2
sejam agrupados), o par {p1, p3}
é testado, mas {p2, p3}
é ignorado, conforme pode ser visto na Trace
saída:
Trace[Gather[list2, Length[Intersection[##]] >= 2 &]] // Rest // Rest // Column

Observe que os triplos {2, 3, 4}
e não{3, 4, 5}
são comparados (porque já{2, 3, 4}
está reunido }.
Ainda outra abordagem é pegar o Union
de 2 subconjuntos que satisfaçam a condição:
highlighted = Union @@ Select[Length[Intersection @@ #] >= 2 &] @ Subsets[list, {2}]
{{a, b, c}, {b, c, d}, {c, a, m}, {c, d, n}}
list /. x : Alternatives @@ highlighted :> Style[x, Gray]
