How to manipulate graphs without losing properties like EdgeWeight?

Question

Let's say I have a weighted graph,

ews = {2, 3, 9, 0, 7};
h = Graph[{1, 2, 3, 3, 5, 6}, {1 <-> 2, 3 <-> 2, 4 <-> 2, 5 <-> 2, 
   1 <-> 6}, EdgeWeight -> ews, VertexLabels -> "Name", 
  EdgeLabels -> "EdgeWeight"]

Which looks like

And I decide I want to delete vertex 1, but then connect the vertices it was connected to, 2 and 6, with an edge that has a weight with the sum of the edges that connected 1 to them (so, 2+7=9).

Getting rid of vertex 1 is easy:

j = VertexDelete[h,1]

And makes it look like:

But I'm actually already kind of running into a problem. The EdgeWeights for the new graph j don't update:

PropertyValue[h, EdgeWeight]
j = VertexDelete[h, 1];
PropertyValue[j, EdgeWeight]

{2, 3, 9, 0, 7}
{2, 3, 9, 0, 7}

Which is a little weird to me because if you try creating a graph with more EdgeWeights than edges, it won't evaluate:

Graph[{1, 2}, {1 <-> 2}, EdgeWeight -> {7, 6}]

Next I want to add an edge between vertices 2 and 6 but it gets even trickier because it resets all the weights of the graph for some reason:

k = EdgeAdd[j, 2 <-> 6]

Which gives:

So, it adds it, but also deletes the old EdgeWeights.

I've found a way to do it, but it's messy as hell, and I bet there's a niftier way.

Is there a clever way to do this? I'm surprised it's not already built into MMa.

It's long and nasty but here's my solution that works:

ReplaceMiddleVertex[g_, node0_] := (
  (*This replaces all nodes that are in between exactly two other \
nodes with an edge connecting those two nodes.*)
  gcopy = g;
  (*Find the two neighboring nodes.*)
  n1 = First@AdjacencyList[gcopy, node0];
  n2 = Last@AdjacencyList[gcopy, node0];
  (*Find their positions in the EdgeList.*)
  p1 = Position[EdgeList[gcopy], 1 <-> n1 | n1 <-> 1][[1, 1]];
  p2 = Position[EdgeList[gcopy], 1 <-> n2 | n2 <-> 1][[1, 1]];
  (*Get the old EWs, 
  which correspond in position to the Edges from EdgeList.*)
  oldEWs = PropertyValue[gcopy, EdgeWeight];
  (*Get those weights, sum them for the new weight.*)
  w1 = oldEWs[[p1]];
  w2 = oldEWs[[p2]];
  wnew = w1 + w2;
  (*Get rid of them, to get the remaining weights.*)
  remEWs = Delete[oldEWs, {{p1}, {p2}}];
  (*Delete the vertex, which also deletes the corresponding edges. 
  Now the remaining edges correspond to the weight list remEWs.*)
  gcopy = VertexDelete[gcopy, node0];
  (*Add the new edge (it will go at the end of the edge list), 
  add its weight to the weight list remEWs, 
  and set the EdgeWeight of this new graph to it.*)
  gcopy = EdgeAdd[gcopy, n1 <-> n2];
  PropertyValue[gcopy, EdgeWeight] = Append[remEWs, wnew];
  Return@gcopy;
)

Answer 1

ClearAll[vcontractF]
vcontractF = Module[{g = #, v = #2, vc = VertexContract@##, el = EdgeList@#,
     ew = PropertyValue[#, EdgeWeight], sel = IncidenceList@##, ew2},
  ew2 = Rule@@@ (DeleteCases[Transpose[{el, ew}],{Alternatives@@Rest[sel], _}]/. 
   {First@sel, _}:>{First@sel, Plus@@ew[[EdgeIndex[g, #]&/@sel]]});
  SetProperty[vc, EdgeWeight -> ew2]]&;

Examples:

ews = {2, 3, 9, 0, 7};
elst = {1 <-> 2, 3 <-> 2, 4 <-> 2, 5 <-> 2, 1 <-> 6};
h = Graph[elst, EdgeWeight -> ews, VertexLabels -> "Name", 
     EdgeLabels -> "EdgeWeight", EdgeLabelStyle->20, VertexLabelStyle->16];

Row[{h, vcontractF[h, {1, 6}], vcontractF[h, {1, 3, 6}]}]

Or

ClearAll[vcontractF2]
vcontractF2 = Module[{g = #, v = #2, vc = VertexContract@##, el = EdgeList@#,
     ew = PropertyValue[#, EdgeWeight], sel = IncidenceList@##, ew2},
  ew2 = Rule@@@(DeleteCases[Transpose[{el, ew}],{Alternatives@@Rest[sel], _}]/. 
   {First@sel,_}:>{First@sel, Plus@@ew[[EdgeIndex[g,#]&/@sel]]});
  Graph[VertexList[vc], EdgeList[vc], EdgeWeight->ew2,
    FilterRules[Options[g], Except[EdgeWeight]]]]&;

 Row[{vcontractF2[h, {1, 6}], vcontractF2[h, {1, 3, 6}]}]

Answer 2

I haven't found a "natural" way, but this is probably more compact and eliminates all "intermediate" nodes at once. To remove just one vertex you could modify the function below so that it receives your node0_ as the toRemove variable without calculating it.

wam = WeightedAdjacencyMatrix;

straight[h_] := Module[{toRemove, wgt, edgs, newWAM}, 
  If[(toRemove = Position[VertexDegree[h], 2, 1, 1] // Flatten) != {}, 
   {wgt, edgs} = {Tr@#, #["AdjacencyLists"]} &[wam[h][[First@toRemove]]];
   newWAM = SparseArray@Join[{edgs -> wgt, Reverse[edgs] -> wgt}, ArrayRules@wam[h]];
   WeightedAdjacencyGraph[Drop[Normal@newWAM, toRemove, toRemove] /. 0 :> Infinity, 
                          VertexLabels -> "Name", EdgeLabels -> "EdgeWeight"], 
   h]]

ews = {2, 3, 9, 1, 7};
h = Graph[Range@6, {1 <-> 2, 3 <-> 2, 4 <-> 2, 5 <-> 2, 1 <-> 6}, 
         EdgeWeight -> ews, VertexLabels -> "Name", EdgeLabels -> "EdgeWeight"]
FixedPoint[straight, h]

It doesn't support zero weight edges out of the box, but you may easily fix it