# Graph smoothing keeping vertices fixed?

## Context

Given a Graph like this one:

  skl2 = Get["https://dl.dropboxusercontent.com/u/659996/graph.m"];
skl2 = HighlighVertexDegree[skl2, VertexDegree[skl2]];
skl2 = Graph[skl2, VertexLabels -> "Name"]


I am interested in re-arranging the position of some of it vertices.

## Question

I would like to move about (=smooth) all the white vertices while keeping the others fixed.

## Attempt

Let me identify by hand such a branch between two yellow vertices: (vertical branch on the right)

  cc = {26, 36, 43, 49, 48, 55, 63, 71};
HighlightGraph[skl2, cc]


The following allows me to identify the corresponding points:

  pts = Table[
PropertyValue[{skl2, cc[[i]]}, VertexCoordinates], {i, Length[cc]}];


and move them using a BSplineFunction

 pts2 = BSplineFunction[pts] /@ (Range[0, Length[pts] - 1]/(Length[pts] - 1));
Do[PropertyValue[{skl2, cc[[i]]}, VertexCoordinates] = pts2[[i]],
{i, Length[cc]}];

HighlightGraph[skl2, cc]


So in principle all is 'fine and dandy' but

I would need to identify the relevant segments automatically.

It seems to me this functionality if of interest (?) beyond my specific problem.

One could think of this as which are the closest neighbours of a given (say yellow) vertex amongst the non white ones, as one scrolls the graph.

For the part

I would need to identify the relevant segments automatically.

you can use

vd2 = ConnectedComponents@Subgraph[g0, VertexList[g0, x_ /; (VertexDegree[g0, x] == 2)]]


{{36, 43, 49, 48, 55, 63}, {41, 42, 47, 54, 62}, {39, 40, 46, 53}, {94, 95, 96}, {82, 92, 99}, {77, 78, 84}, {38, 45, 52}, {13, 17, 18}, {9, 10, 11}, {104, 105}, {89, 90}, {86, 87}, {76, 81}, {75, 80}, {74, 79}, {69, 70}, {66, 67}, {37, 44}, {23, 24}, {16, 25}, {103}, {101}, {98}, {64}, {61}, {59}, {57}, {34}, {32}, {27}, {15}, {14}, {5}}

where g0 is the graph linked in the question.

Using the function HighlighVertexDegree from OP's related question:

g0b = HighlighVertexDegree[g0, VertexDegree[g0]]


HighlightGraph[g0, vd2, ImageSize -> 500, VertexLabels -> "Name"]


Update: If you wish to include the immediate neighbors of the nodes in each component, you can use

vd2N = Complement[VertexList[NeighborhoodGraph[g0, #]], #] & /@ vd2;
vd2Np = FindShortestPath[g0, ##] & @@@ vd2N


{{26, 36, 43, 49, 48, 55, 63, 71}, {35, 41, 42, 47, 54, 62, 68}, {33, 40, 39, 46, 53, 60}, {93, 94, 95, 96, 97}, {83, 82, 92, 99, 108}, {73, 77, 78, 84, 93}, {31, 38, 45, 52, 58}, {3, 13, 17, 18, 26}, {8, 9, 10, 11, 12}, {106, 105, 104, 112}, {88, 89, 90, 91}, {85, 86, 87, 88}, {71, 76, 81, 91}, {68, 75, 80, 88}, {65, 74, 79, 85}, {68, 69, 70, 71}, {65, 66, 67, 68}, {29, 37, 44, 51}, {22, 23, 24, 33}, {12, 16, 25, 35}, {97, 103, 111}, {100, 101, 102}, {91, 98, 106}, {56, 64, 73}, {60, 61, 65}, {58, 59, 60}, {56, 57, 58}, {33, 34, 35}, {22, 32, 31}, {26, 27, 28}, {8, 15, 22}, {6, 14, 21}, {4, 5, 6}}

or

vd2O = Complement[VertexOutComponent[g0, #, 1], #] & /@ vd2;
vd2Op = FindShortestPath[g0, ##] & @@@ vd2O;
{vd2N == vd2O, vd2Np == vd2Op}
(* {True, True *)

HighlightGraph[g0, vd2Op, ImageSize -> 500]


Update 2: And, for the part

I would like to move about (=smooth) all the white vertices while keeping the others fixed.

bsF = BSplineFunction[#] /@ (Range[0, Length[#] - 1]/(Length[#] - 1)) &;

vc = PropertyValue[{g0, #}, VertexCoordinates] & /@ # & /@ vd2Op;
vcb = (bsF /@ vc);
(PropertyValue[{g0b, #}, VertexCoordinates] = #2) & @@@ Transpose[{Join @@ vd2Op, Join @@ vcb}];

g0b


This can be encapsulated as follows

GraphSmooth[skl_] := Module[{skl2, vd1, vd2, vd3, cc, pts, pts2, x},
vd1 = ConnectedComponents@
Subgraph[skl, VertexList[skl, x_ /; (VertexDegree[skl, x] == 2)]];
vd2 = VertexOutComponent[skl, #, 1] & /@ vd1;
vd3 = FindShortestPath[skl, #[[1]], #[[-1]]] & /@ vd2;
skl2 = skl;
Do[cc = vd3[[j]];If[Length[cc] > 2,pts =
Table[PropertyValue[{skl2, cc[[i]]}, VertexCoordinates], {i,
Length[cc]}];
pts2 = BSplineFunction[pts] /@ (Range[0, Length[pts] - 1]/(Length[pts] - 1));
Do[PropertyValue[{skl2, cc[[i]]}, VertexCoordinates] =
pts2[[i]], {i, Length[cc]}]],
{j, 1, Length[vd3]}]; skl2]

skl2 = GraphSmooth[skl];


• I hope you don't mind the minor edit? Commented Oct 27, 2014 at 20:37
• @chris, not at all. But, some vertices seems to be missed.
– kglr
Commented Oct 27, 2014 at 21:49

One can smooth the graph by averaging the position of each degree 2 vertex with its neighborhoods. In addition, if the vertex's original position is included in the average, the vertex will be pulled slightly toward it. (Thus four points are being averaged, hence the 0.25 below.) If one iterates this procedure, nice "curved" paths develop.

coords = PropertyValue[skl2, VertexCoordinates];
deg2 = Pick[VertexList[skl2], VertexDegree[skl2], 2];

(* coefficient matrix for the original points:
degree-2 vertices get weight 1/4
other vertices get weight 1, which will keep them in place *)
fixedM = SparseArray[Thread[deg2 -> 0.25], {113}, 1.];

(* averaging matrix for the degree-2 vertices:
degree-2 vertices and their adjacent neighbors get weight 1/4
other vertices get weight 0 via multiplication by SparseArray[Thread[deg2 -> 1], {113}] *)
relaxM =
SparseArray[{#, #} -> 1 & /@ deg2, {113, 113}] +

(* iterate until fixed positions are reached -
it's fast, otherwise limit the number of iterations (five is usually enough) *)
newcoords = FixedPoint[
fixedM coords + 0.25 relaxM.# &,
coords,
100];

(* set the new coordinates *)
newgraph =
Fold[SetProperty[{#1, #2}, VertexCoordinates -> newcoords[[#2]]] &,
skl2, deg2]


The procedure above is easily bundled into a function by declaring the variables and placing code in a Module. The technique is similar to the relaxation of surface tension.

Update - This is an apparently undocumented way to set all the new coordinates at once:

newgraph = SetProperty[{skl2, deg2}, VertexCoordinates -> newcoords[[#]] & /@ deg2]


The documentation advises "Use Fold to apply SetProperty repeatedly". Note that the second argument has to be a list of rules.

• Thanks; and thanks for the undocumented features: makes one feel smart looking under the hood of mathematica :-) Commented Oct 28, 2014 at 17:46
• @chris You're welcome. In case you only want the corners to move, you just have to select from deg2 the vertices whose coordinates are not the mean of the adjacent vertices', and use that list instead of deg2. Commented Oct 28, 2014 at 18:03