# Vertex merging in graph?

## Context

Given a Graph such as the one produced with the following code

 u = GaussianRandomField[n = 16, 2, Function[k, 1/k^2 Exp[-1/40 k^2]]] // Chop;
skl = Map[If[# == 0, 1, 0] &, u // Image // WatershedComponents, {2}] // SparseArray;
skl2 = arrayGraph[Normal@skl, VertexSize -> 0.4, EdgeStyle -> Directive[Thick, Red]];
HighlighVertexDegree[skl2, VertexDegree[skl2]]


which is available here ## Question

I would like

• to merge all groups of two (or more) yellow vertices by one single vertex which should have as a position their center of mass (I have highlighted them with ellipses by hand on this example).

For this second goal (which I should have posted as an independent question) the idea would be to write a function, say, SmoothGraph so that when given a graph, would return the same graph but with VertexCoordinates modified for all the light yellow points so as to provide a smoother version.

PS: The yellow vertices are those which vertex degree is equal to two.

PS: these are the codes I used to produce the above graph

   arrayGraph[mat_, opts : OptionsPattern[]] :=
Module[{m = Module[{i = 1}, mat /. 1 :> i++], edges, vcs, v},
v = ComponentMeasurements[m, "Label"][[All, 1]];
vcs = ComponentMeasurements[m, "Centroid", CornerNeighbors -> False];
edges = UndirectedEdge @@@
DeleteDuplicates[
Sort /@ Flatten[Thread /@  ComponentMeasurements[m, "Neighbors",
CornerNeighbors -> False]]];
Graph[v, edges, VertexCoordinates -> vcs, opts]]

HighlighVertexDegree[g_, vd_] :=
HighlightGraph[g,
Table[Style[VertexList[g][[i]],
ColorData["TemperatureMap"][vd[[i]]/Max[vd]]], {i, VertexCount[g]}]];

GaussianRandomField[size : (_Integer?Positive) : 256, dim : (_Integer?Positive) : 2,
Pk_: Function[k, k^-3]] := Module[{Pkn, fftIndgen, noise, amplitude, s2},
Pkn = Compile[{{vec, _Real, 1}}, With[{nrm = Norm[vec]},
If[nrm == 0, 0, Sqrt[Pk[nrm]]]],
CompilationOptions -> {"InlineExternalDefinitions" -> True}];
s2 = Quotient[size, 2];
fftIndgen = ArrayPad[Range[0, s2], {0, s2 - 1}, "ReflectedNegation"];
noise = Fourier[RandomVariate[NormalDistribution[], ConstantArray[size, dim]]];
amplitude = Outer[Pkn[{##}] &, Sequence @@ ConstantArray[N @ fftIndgen, dim]];
InverseFourier[noise * amplitude]]


## Attempt

Following @Öskå advice I computed the candidates vertices as follows

 cand = EdgeList[skl2, # <-> _] & /@
Flatten[(Position[VertexDegree[skl2], 3])];
cand2 = Flatten[cand /. UndirectedEdge[a_, b_] -> {a, b}] // Sort;
cand3 = First /@ Select[Tally[cand2], #[] > 3 &]


(* {6,7,8,20,21,29,30,31,51,56,85,93,97,102,106,107,108} *)

Indeed we can check they are correctly identified

  skl4 = HighlighVertexDegree[skl2, VertexDegree[skl2]];
skl4=Graph[skl4, VertexLabels -> "Name"] • For your last question, take a look at VertexInComponent[g, yourVertex, 1] – Dr. belisarius Oct 20 '14 at 13:50
• @chris, this is an interesting problem but can you extract a minimal example, eg with a single vertex cluster? – alancalvitti Dec 23 '14 at 15:41
• When I arrive your Dropbox,it warns me a error information. – yode Jul 9 '17 at 5:30
• @yode Dropbox changed its policy unfortunately – chris Jul 29 '17 at 16:15

You need to write function to set new coord and new edge shape function.

Here's one example to do such things:

mergeVertex[g_, set_List] :=
Block[{vcoord, ids, ncoord, ng, newv, nedge, endp, oedge, pind,
neshape},
vcoord = GraphEmbedding[g];
ids = {VertexIndex[g, #]} & /@ set;
ncoord = Join[Delete[vcoord, ids], {Mean[Extract[vcoord, ids]]}];

ng = VertexContract[g, set];
newv = Last[VertexList[ng]];
nedge = EdgeList[ng, newv <-> _];

neshape = Table[
endp = If[e[] == newv, e[], e[]];
oedge = First[EdgeList[g, endp <-> _?(MemberQ[set, #] &)]];
pind =
If[oedge[] == endp, VertexIndex[g, oedge[]],
VertexIndex[g, oedge[]]];
With[{v = vcoord[[pind]]},
e -> (BezierCurve[{#[], v, #[[-1]]}] &)]
,
{e, nedge}];
neshape =
Join[neshape,
EdgeShapeFunction /.
Options[g, EdgeShapeFunction] /. {Automatic -> {}}];

Graph[VertexList[ng], EdgeList[ng], EdgeShapeFunction -> neshape,
VertexCoordinates -> ncoord,
FilterRules[Options[g], {EdgeStyle, VertexSize}]]
]


## Example:

Compute candidates:

cand = Select[
ConnectedComponents[
Subgraph[skl2,
VertexList[skl2, x_ /; (VertexDegree[skl2, x] == 3)]]],
Length[#] > 1 &]


{{80, 81, 85, 86}, {45, 46, 57, 58}, {39, 40, 41}, {75, 76}}

original graph:

HighlightGraph[HighlighVertexDegree[skl2, VertexDegree[skl2]], cand,
VertexLabels -> "Name"] Merge vertices by group:

g = Fold[mergeVertex, skl2, cand];
HighlighVertexDegree[g, VertexDegree[g]] 