5
$\begingroup$

Starting from the following list:

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

I want to highlight elements in list whose intersection is greater than 2.

The following code cannot get the result I want:

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

obtained result, with second, third, fifth, sixth elements highlighted

The desired result is
desired result, with only second and third elements highlighted

I also considered Gather, but it will change the order of the list.

Updated:
I thought of a way, not elegant

list //. {a___,x:({_,_,_}|F[{_,_,_}]),b___,y:({_,_,_}),c___}/;
  Length[Intersection[x/.F->Identity,y]]>=2:>{a,F@x,b,F@y,c}
% /. F->Highlighted
$\endgroup$
3
$\begingroup$
rg = RelationGraph[UnsameQ @ ## && Length@Intersection[##] >= 2 &, list]

enter image description here

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

enter image description here

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

![enter image description here

HighlightGraph[rg, hl]

enter image description here

You can also use ConnectedComponents and select components with more than 1 vertex:

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

![enter image description here

$\endgroup$
2
$\begingroup$
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]

formatted list

$\endgroup$
1
$\begingroup$

A variant of OP's solution that avoids nesting of Highlighted:

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

enter image description here

Same approach using 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}

enter image description here

$\endgroup$
1
$\begingroup$

I think the easy way is still use Gather and reorder the index. Here we handle the general 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]

enter image description here

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

enter image description here

A method using 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]

enter image description here

Why Gather does not work:

Taking a simpler example:

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 does not perform the test function on all pairs of the input list. If the test function evaluates to True for the pair {p1, p2} (so that p1 and p2 are grouped together) then the pair {p1, p3} is tested but {p2, p3} is skipped as can be seen in Trace output:

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

enter image description here

Note that the triples {2, 3, 4} and {3, 4, 5} are not compared (because {2, 3, 4} is already gathered}.

$\endgroup$
1
  • 1
    $\begingroup$ Thank you! Until today I know that Gather must using ** equivalence relation** ,and Intersection[##]] >= 2 is not such relation. I think I need time to rewrite my code. $\endgroup$ – cvgmt Nov 27 '20 at 11:30
0
$\begingroup$

Yet another approach is to take the Union of 2-subsets that satisfy the condition:

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]

enter image description here

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.