Markieren Sie Elemente in der Liste mithilfe des Mustervergleichs

Question

Ausgehend von Folgendem list:

list = {{a, b, c}, {d, e, f}, {g, h, i}, {b, c, d}, {c, a, m}, {c, d, n}};

Ich möchte Elemente hervorheben, listderen Schnittpunkt größer als 2 ist.

Der folgende Code kann nicht das gewünschte Ergebnis erzielen:

list //. 
   {{a___, x:{_, _, _}, b___, y:{_, _, _}, c___} /; 
      Length@Intersection[x, y] >= 2 :> 
         {a, Style[x, Gray], b, Style[y, Gray], c}}

Das gewünschte Ergebnis ist

Ich habe auch darüber nachgedacht Gather, aber es wird die Reihenfolge der Liste ändern.

Aktualisiert:
Ich dachte an einen Weg, nicht elegant

list //. {a___,x:({_,_,_}|F[{_,_,_}]),b___,y:({_,_,_}),c___}/;
  Length[Intersection[x/.F->Identity,y]]>=2:>{a,F@x,b,F@y,c}
% /. F->Highlighted

Answer 1

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]

Sie können auch ConnectedComponentsKomponenten mit mehr als einem Scheitelpunkt verwenden und auswählen:

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

Answer 2

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]

Answer 3

Eine Variante der OP-Lösung, die das Verschachteln von Folgendem vermeidet Highlighted:

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

Gleicher Ansatz mit 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}

Answer 4

Ich denke, der einfache Weg ist immer noch, Gatherden Index zu verwenden und neu zu ordnen. Hier behandeln wir die allgemeine Situation.

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]

Answer 5

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

Eine Methode mit 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]

Warum Gatherfunktioniert das nicht:

Ein einfacheres Beispiel:

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}}}

Gatherführt die Testfunktion nicht für alle Paare der Eingabeliste aus. Wenn die Testfunktion Truefür das Paar ausgewertet wird {p1, p2}(so dass p1und p2zusammen gruppiert sind), wird das Paar {p1, p3}getestet, aber {p2, p3}übersprungen, wie in der TraceAusgabe zu sehen ist :

Trace[Gather[list2, Length[Intersection[##]] >= 2 &]] // Rest // Rest // Column

Beachten Sie, dass die Tripel {2, 3, 4}und {3, 4, 5}sind nicht miteinander verglichen (da {2, 3, 4}wird bereits gesammelt }.

Answer 6

Ein weiterer Ansatz besteht darin, Union2 Teilmengen zu verwenden, die die Bedingung erfüllen:

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]