9
$\begingroup$

so what I want to do is take an undirected graph, and remove all the "dead ends" (that is, vertices that are attached to only one other vertex), but do it in such a way that it does it until reaches "steady state", i.e., it keeps doing this until there are no more dead ends to remove.

For example, here's a starting graph, h:

enter image description here

I would like it to remove vertices 4 and 5 (and edges 3<->4 and 4<->5, of course), just leaving the loop really.

So I made a really simple function:

RemoveDeadEnds[g_] := (

  gcopy = g;
  Do[
   If[EdgeCount[gcopy, i <-> _] ==  1, gcopy = VertexDelete[gcopy, i]];
   , {i, Length@VertexList@g}];
  Return@gcopy;
  )

The problem is that, in the case of the example I had above, it just remove Vertex 5, because at the time in the loop when it checks vertex 4, vertex 4 had 2 edges. By the time it removes vertex 5, when vertex 4 has 1 edge (and should thus be removed), it is already past it, so it returns:

enter image description here

Obviously I could loop it several times. But that's obviously inelegant, and who knows how long this chain of dead ends is?

I can think of another way, but a little messy: you have a nested function so when you remove a vertex, you check the other vertex it was (formerly) attached to, and test that one. But that's not ideal either.

Is there a better way to do it? Ideally some magical Mathematica function that's already built in?

Edit: I implemented the method I said right above, using recursion:

CheckAndRemoveDeadEnd[g_, node0_] := (
gcopy = g;
 If[EdgeCount[gcopy, node0 <-> _] ==  1,
   j = First@AdjacencyList[gcopy, node0];
   gcopy = VertexDelete[gcopy, node0];
   gcopy = CheckAndRemoveDeadEnd[gcopy, j];
   ];
 Return@gcopy;
 )

DeleteAllDeadEnds[g_] := (
  gcopy = g;
  Do[
   gcopy = CheckAndRemoveDeadEnd[gcopy, i];
   , {i, Max@VertexList@g}];
  Return@gcopy;
  )
$\endgroup$
  • $\begingroup$ This is clearly a job for ReplaceRepeated... (or //. in shorthand). $\endgroup$ – LLlAMnYP May 6 '15 at 20:40
12
$\begingroup$

Update: It turns out that the built-in function KCoreComponents does exactly what you need:

KCoreComponents[g , k] gives the k-core components of the underlying simple graph of g.

A k-core component is a maximal weakly connected subgraph in which all vertices have degree at least k.

kccF[g_, o: OptionsPattern[Graph]] := Subgraph[g, KCoreComponents[g, 2], o]

kccF[g0, ## & @@ options]

Mathematica graphics

Original post:

You can also use VertexDelete with ReplaceRepeated or FixedPoint:

vdF = VertexDelete[#, v_ /; VertexDegree[#, v] <= 1] &; (* thanks: @Guesswhoitis  *)
(* or vdF = VertexDelete[#, _?(Function[v, VertexDegree[#, v] <= 1])] &; *)

Using vdF with ReplaceRepeated:

rrF = # //. g_Graph :> vdF[g] &;

and with FixedPoint:

fpF = FixedPoint[vdF, #] &;

You can rrF@g or fpF@g to remove dead ends from graph g.

Example:

options = {AspectRatio -> 1, VertexLabels -> Placed["Name", Center], 
   VertexSize -> Scaled[.1], VertexStyle -> Opacity[0], VertexLabelStyle -> 20, 
   BaseStyle -> Directive[Opacity[1], Thick], EdgeLabels -> "Name", ImageSize -> 300};
edges = UndirectedEdge @@@ {{1, 6}, {1, 2}, {2, 3}, {6, 3}, {3, 4}, {4, 5}};

g0 = Graph[Range[6], edges, ## & @@ options];
Row[{g0, rrF@g0, fpF@g0}, Spacer[20]]

gradual removal of dead ends

$\endgroup$
  • 1
    $\begingroup$ Why not vdF = VertexDelete[#, v_ /; VertexDegree[#, v] <= 1] &;? $\endgroup$ – J. M. will be back soon May 6 '15 at 20:45
  • $\begingroup$ Thank you @Guesswhoitis; updated the answer with that alternative. $\endgroup$ – kglr May 6 '15 at 21:02
  • $\begingroup$ I'd be curious to see if anything can be shorter and neater than @Guesswhoitis. vdF and your fpF. +1 for sure $\endgroup$ – LLlAMnYP May 6 '15 at 21:16
  • 2
    $\begingroup$ @LLlAMnYP, thank you for the upvote. Re shorter/neater, how about Subgraph[#, KCoreComponents[#, 2]] &?:) $\endgroup$ – kglr May 6 '15 at 21:57
  • $\begingroup$ @kguler can't upvote twice, so no need to thank me twice =P Yes, cool, preserves vertex names (?), I like that. $\endgroup$ – LLlAMnYP May 6 '15 at 22:01
9
$\begingroup$
ClearAll[RemoveDeadEnds];

RemoveDeadEnds[g_Graph] := 
 FixedPoint[
  Function[g2, 
   Subgraph[g2,
    Select[VertexList@g2, VertexDegree[g2, #] > 1 &]]], g]

{#, RemoveDeadEnds@#} &@
 Graph[{1 <-> 2, 2 <-> 3, 3 <-> 4, 4 <-> 5, 3 <-> 6, 6 <-> 1}]

enter image description here

$\endgroup$
3
$\begingroup$

Here's my "one-liner" for graphs with undirected edges.

FixedPoint[
 IncidenceGraph[
   Transpose[
    Transpose[
      Normal[IncidenceMatrix[#]] /. {0 ..., 1, 0 ...} -> 
        Unevaluated[Sequence[]]] /. {0 ..., 1, 0 ...} -> 
      Unevaluated[Sequence[]]]] &, graph]
$\endgroup$
  • $\begingroup$ (+1) This does not preserve the vertex names. A shorter variant : AdjacencyGraph@ FixedPoint[Select[Transpose@#, Tr[#] > 1 &] &, AdjacencyMatrix@g0] $\endgroup$ – kglr May 6 '15 at 21:37
  • $\begingroup$ Thanks. I almost never deal with graphs in MMA, so questions like these always earn an upvote as they force me to learn something new :-) $\endgroup$ – LLlAMnYP May 6 '15 at 21:44
  • $\begingroup$ ... or AdjacencyGraph@ FixedPoint[Transpose[# /. {0 ..., 1, 0 ...} :> (## &[])] &, Normal@AdjacencyMatrix@g0]. $\endgroup$ – kglr May 6 '15 at 21:45
  • $\begingroup$ @kguler, are you sure? The double transpose will return the matrix to the initial state, but can not FixedPoint get stuck between two alternating states in this case (for a directed graph)? You are absolutely right, that the conversion back to graph form should be moved outside of the FixedPoint. As for (##&[]), there was a lengthy discussion somewhere here on the merits of this vs. Unevaluated[Sequence[]]. $\endgroup$ – LLlAMnYP May 6 '15 at 21:50
  • 1
    $\begingroup$ LLlAMnYP, good point re directed graphs. I should have added "it works in OP's example". Re ##&[]: the cool kids... $\endgroup$ – kglr May 6 '15 at 22:09

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.