# How to remove all dead ends from a undirected graph?

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: 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: 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,
gcopy = VertexDelete[gcopy, node0];
];
Return@gcopy;
)

gcopy = g;
Do[
, {i, Max@VertexList@g}];
Return@gcopy;
)

• This is clearly a job for ReplaceRepeated... (or //. in shorthand). – LLlAMnYP May 6 '15 at 20:40

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]


## 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, VertexLabelStyle -> 20,
BaseStyle -> Directive[Opacity, Thick], EdgeLabels -> "Name", ImageSize -> 300};
edges = UndirectedEdge @@@ {{1, 6}, {1, 2}, {2, 3}, {6, 3}, {3, 4}, {4, 5}};

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

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

Graph[{1 <-> 2, 2 <-> 3, 3 <-> 4, 4 <-> 5, 3 <-> 6, 6 <-> 1}] 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]

• (+1) This does not preserve the vertex names. A shorter variant : AdjacencyGraph@ FixedPoint[Select[Transpose@#, Tr[#] > 1 &] &, AdjacencyMatrix@g0] – kglr May 6 '15 at 21:37
• 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 :-) – LLlAMnYP May 6 '15 at 21:44
• ... or AdjacencyGraph@ FixedPoint[Transpose[# /. {0 ..., 1, 0 ...} :> (## &[])] &, Normal@AdjacencyMatrix@g0]. – kglr May 6 '15 at 21:45
• @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[]]. – LLlAMnYP May 6 '15 at 21:50
• LLlAMnYP, good point re directed graphs. I should have added "it works in OP's example". Re ##&[]: the cool kids... – kglr May 6 '15 at 22:09