Graph smoothing keeping vertices fixed?

Question

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.

(see also this question)

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.

Answer 1

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];

Answer 2

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}] +
  AdjacencyMatrix[skl2] SparseArray[Thread[deg2 -> 1], {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.