Transition between graphs

Question

I want to visually demonstrate the manipulations made to a graph. For instance, I have a graph g where using the command LayeredGraphPlot[g, Bottom, VertexLabeling -> True] I get this figure as the output:

After adding an edge and using the same command I get this one:

I want to show a smooth transition between the two figures so that the user can track the addition of the edge. Is there any easy/general way to do such an effect in Mathematica.

Answer 1

While David's answer is a nice one, it's not actually what I am looking for. As I commented on his answer, I am looking for an answer that:

1. Handles dynamic user inputs, so a fixed final graph does not do the job. You can consider a compelete graph as the final graph, but I don't think this is a good idea.

2. I need to use LayeredGraphPlot to place the vertices correctly.

Based on these requirements, I found this answer:

g1 = Graph[{1, 2, 3, 4, 5, 6, 7, 8}, {1 \[DirectedEdge] 2, 
    2 \[DirectedEdge] 3, 4 \[DirectedEdge] 6, 5 \[DirectedEdge] 6, 
    7 \[DirectedEdge] 6}];
g2 = Graph[{1, 2, 3, 4, 5, 6, 7, 8}, {1 \[DirectedEdge] 2, 
    2 \[DirectedEdge] 3, 4 \[DirectedEdge] 6, 5 \[DirectedEdge] 6, 
    7 \[DirectedEdge] 6, 8 \[DirectedEdge] 3}];

AnimateGraphs[g1_, g2_] := Module[
   {
    gr1 = LayeredGraphPlot[g1, Bottom, VertexLabeling -> True],
    gr2 = LayeredGraphPlot[g2, Bottom, VertexLabeling -> True],
    coord1, coord2, delta, fps = 30
    },
   coord1 = Last[Last[gr1[[1]]]];
   coord2 = Last[Last[gr2[[1]]]];
   delta = coord2 - coord1;
   Table[GraphPlot[g1, VertexLabeling -> True, 
      VertexCoordinateRules -> (coord1 + (i - 1)/fps delta)], {i, 1, 
      fps}]~Append~gr2
   ];
ListAnimate[AnimateGraphs[g1, g2], AppearanceElements -> None, 
 DefaultDuration -> 0.5, AnimationRepetitions -> 1]

It uses Last[Last[gr1[[1]]]] to find the vertex coordinates that I think is not a robust way. Please comment if you have a better solution. The rest is simple.

Answer 2

To get the vertex coordinates for graph g, defined below:

PropertyValue[{g, #}, VertexCoordinates] & /@ Range[7]

e.g.

{{2.32379, 0.}, {2.32379, 0.774597}, {1.54919, 1.54919}, {1.54919, 0.}, {0.774597, 0.}, {0.774597, 0.774597}, {0., 0.}}

---

To Animate, without moving vertices....

Here's a rough overview of how you might approach the problem using highlights. You don't need to move the vertices. You can simply fill in the graph step by step. We'll build the graph in three steps and then play it backwards. You can add the highlights and additional steps that suit you.

Begin by making the graph you want to end with:

edges = {DirectedEdge[7, 6], DirectedEdge[5, 6], DirectedEdge[4, 6], DirectedEdge[6, 3], DirectedEdge[2, 3], DirectedEdge[1, 2]};
g = Graph[edges, GraphStyle -> "VintageDiagram", GraphLayout -> "LayeredDrawing" ]

---

Next, make the next to final drawing of the graph:

g1 = Graph[edges, GraphStyle -> "VintageDiagram", GraphLayout -> "LayeredDrawing", 
GraphHighlight -> Join[{3, 6}, {DirectedEdge[6, 3]}], 
GraphHighlightStyle -> "DehighlightFade" ]

Now let's jump to the first step, where there are two connected components. They need to be in the proper place so they won't have to move later.

g2 = Graph[edges, GraphStyle -> "VintageDiagram", GraphLayout -> "LayeredDrawing", 
GraphHighlight -> Join[Range[7], Complement[edges, {DirectedEdge[6, 3]}]], 
GraphHighlightStyle -> "DehighlightHide" ]

Setting the GraphHighlightStyle to DehighlightHide allows you to hide parts of the graph (the edge from vertex 6 to vertex 3).

---

In the animation you will want to display them in reverse order:

---

Here's the ListAnimate code for showing the three frames we made:

ListAnimate[{g2, g1, g}]

---

With additional frames you could assemble the graph, vertex by vertex, edge by edge, using the highlights of your choosing.