12
$\begingroup$

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

Mathematica graphics

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]

Mathematica graphics

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]

Mathematica graphics

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.

$\endgroup$
8
$\begingroup$

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

enter image description here

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

enter image description here

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]

enter image description here

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

enter image description here

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

Mathematica graphics

$\endgroup$
2
  • $\begingroup$ I hope you don't mind the minor edit? $\endgroup$ – chris Oct 27 '14 at 20:37
  • $\begingroup$ @chris, not at all. But, some vertices seems to be missed. $\endgroup$ – kglr Oct 27 '14 at 21:49
3
$\begingroup$

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]

Mathematica graphics

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.

$\endgroup$
2
  • $\begingroup$ Thanks; and thanks for the undocumented features: makes one feel smart looking under the hood of mathematica :-) $\endgroup$ – chris Oct 28 '14 at 17:46
  • $\begingroup$ @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. $\endgroup$ – Michael E2 Oct 28 '14 at 18:03

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.