4
$\begingroup$

I have an list that I would like to reduce according to rules for combination. Examples of the input list (this will be a list of pairs and may be several hundred elements long) and the output I'm looking for with some function f are:

f[{{1,4},{1,6}}]
-> {{1,4,6}}

The two input lists both contain 1 and are combined. Or

f[{{1, 4}, {1, 6}, {2, 3}}]
-> {{1,4,6},{2,3}}

As in the first but {2,3} has no common elements with the others and remains separate. One way of doing this is with a repeated rule:

{{1, 4},{1,6}, {2, 3}} //. {head___, {x_, y_}, mid___, {x_, z_} | {z_, x_} | {y_, z_} | {z_, y_}, tail___} -> {head, {x, y, z}, mid, tail}
-> {{1,4,6},{2,3}}

This produces the correct output but has a problem that some other inputs makes clear - the last {4,6} term should have been combined with {1,4,6} and disappear:

{{1, 4},{1, 6}, {2, 3}, {4, 6}}//. {head___, {x_, y_}, mid___, {x_, z_} | {z_, x_} | {y_, z_} | {z_, y_}, tail___} -> {head, {x, y, z}, mid, tail}
-> {{1, 4, 6}, {2, 3}, {4, 6}}

The correct output should be:

{{1,4,6},{2,3}}

Or

{{1, 4}, {1, 6}, {2, 3}, {4, 6}, {3, 5}}//. {head___, {x_, y_}, mid___, {x_, z_} | {z_, x_} | {y_, z_} | {z_, y_}, tail___} -> {head, {x, y, z}, mid, tail}
-> {{1, 4, 6}, {2, 3, 5}, {4, 6}}

The correct output should be:

{{1, 4, 6}, {2, 3, 5}}

The repeated rule above builds longer lists than pairs (there are then not matched in subsequent iterations) but I haven't found a way of writing a pattern to deal with it (so maybe rule replacement isn't the way to go here), I've tried a couple of other approaches of a more functional nature but seem to be missing something. Any suggestions?

$\endgroup$
2
  • $\begingroup$ So, are you familiar with Union[] and Intersection[]? $\endgroup$
    – J. M.'s torpor
    Feb 18 at 13:10
  • $\begingroup$ @J.M. yes, of course, Union[{1,4},{1,6}] yields {1,4,6} but this isn't all there is to it, it would need to be selectively applied and some form of recursion is needed I think. I don't immediately see how Intersection would help here. $\endgroup$
    – EstabanW
    Feb 18 at 13:31
5
$\begingroup$
f[sep: List[__List]]:= Union @@@ Gather[
    sep, 
    IntersectingQ
]
f@{{1, 4}, {1, 6}, {2, 3}, {4, 6}, {3, 5}}
(* {{1, 4, 6}, {2, 3, 5}} *)
f@{{1, 4},{1, 6}, {2, 3}, {4, 6}}
(* {{1, 4, 6}, {2, 3}} *)

Alternatively, use pattern:

{{1,4},{1,6},{2,3},{4,6}} //. {
    {OrderlessPatternSequence[x1: {__}, x2: {__}, y___]}
    :> {Union[x1, x2], y}/;IntersectingQ[x1, x2]
}
(* {{1, 4, 6}, {2, 3}} *)
$\endgroup$
1
  • $\begingroup$ Thanks @Chromo Runge the Gather method is very elegant and I didn't know the OrderlessPatternSequence function until now $\endgroup$
    – EstabanW
    Feb 18 at 17:58
4
$\begingroup$

KCoreComponents

The function KCoreComponents with 1 as the second argument gives the desired result:

ClearAll[f1]

f1 = KCoreComponents[#, 1] &;

Examples:

f1  @ {{1, 4}, {1, 6}, {2, 3}}
{{1, 4, 6}, {2, 3}}  
f1  @ {{1, 4}, {1, 6}, {2, 3}, {4, 6}}
{{1, 4, 6}, {2, 3}}  
f1 @ {{1, 4}, {1, 6}, {2, 3}, {4, 6}, {3, 5}}
{{2, 3, 5}, {1, 4, 6}}  

ConnectedComponents

Alternatively, you can use ConnectedComponents and delete singleton elements:

ClearAll[f2]

f2 = DeleteCases[{_}] @* ConnectedComponents

Examples:

f2 @ {{1, 4}, {1, 6}, {2, 3}}
{{1, 4, 6}, {2, 3}}  
f2 @ {{1, 4}, {1, 6}, {2, 3}, {4, 6}}
{{1, 4, 6}, {2, 3}}  
f2 @ {{1, 4}, {1, 6}, {2, 3}, {4, 6}, {3, 5}}
{{2, 3, 5}, {1, 4, 6}}   

For fun:

pairs = {{1, 4}, {1, 6}, {2, 3}, {4, 6}, {3, 5}};

HighlightGraph[pairs, 
  Subgraph[pairs, #] & /@ KCoreComponents[pairs, 1], 
  GraphHighlightStyle -> "Thick", PlotTheme -> "IndexLabeled"]

enter image description here

Note: The fact that KCoreComponents, ConnectedComponents, Graph and HighlightGraph (as well as many other graph-related functions) accept a list of pairs as the first argument is not documented. The pairs are interpreted as undirected edges. (See also: this answer.)

$\endgroup$
1
  • $\begingroup$ Thanks @kglr I keep getting surprised by what can be done with graph functionality once a problem has been formulated in a way that exploits it $\endgroup$
    – EstabanW
    Feb 20 at 14:16
2
$\begingroup$

If I understand your question correctly, you would like to join all sub lists that have some elements in common und delete duplicates. This can be achieved by e.g.:

{{1, 4}, {1, 6}, {2, 3}, {4, 6}, {3, 
   5}} //. {y1___, x1:{__}, y2___, x2:{__}, y3___} /; 
   Intersection[x1, x2] != {} :> {y1, Union[x1, x2], y2, y3}

(*{{1, 4, 6}, {2, 3, 5}}*)
$\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.