Animating transition between all graph representations obtained from curated data

Question

Pappus graph is one of many graphs whose various data is contained within Mathematica. Mathematica typically keeps several ways of representing such graphs:

GraphData["PappusGraph", "AllImages"]

will give its several representations:

I found these images pretty amazing - they look very different!

How to create an animation that will gradually go through all representations of Papus graph?

For example, to clarify the question, this is an animation made by Mark McClure created by transitioning from one to another "hardcoded" plot of the same graph:

vc1 = # - {1, 1} & /@ {{0, 2}, {1, 2}, {2, 2}, {1, 1}, 
  {0, 0}, {1, 0}, {2, 0}};
vc2 = {{1/2, -Sqrt[3]/2}, {-1/2, -Sqrt[3]/2}, {-1, 0}, 
  {1/2, Sqrt[3]/2}, {1, 0}, {0, 0}, {-1/2, Sqrt[3]/2}};
vc[t_] := t*vc2 + (1 - t) vc1;
Animate[
  Graph[{1, 2, 3, 4, 5, 6, 7},
    UndirectedEdge@@@{{1, 2}, {2, 3}, {3, 7}, {7, 6}, {6, 5}, {5, 1}, 
     {1, 6}, {4, 5}, {4, 7}},
    PlotRange -> 1.1, VertexCoordinates -> vc[t]],
  {t, 0, 1}, AnimationDirection -> ForwardBackward]

How to do it for any graph that is available in Mathematica currated data, for representatios given by GraphData[<graph name>, "AllImages"]?

---

EDIT: (after reading answers) This is part of the animation obtained with DyckGraph, using belisarius' solution:

Also, BrouwerHaemersGraph:

Answer 1

The following is a little involved, but it calculates the "minimum displacement" evolution by choosing the least total displacement alternatives from the permutations generated by the "AutomorphismGroup" of the graph:

{n, edges, coords1, perms} = GraphData["PappusGraph", {"VertexCount", "EdgeList", 
                                       "AllVertexCoordinates", "AutomorphismGroup"}];
coords = Transpose[Rescale /@ Transpose@#] & /@ coords1;
validPerms = GroupElements@perms;
calcPerm[1] = 1;
calcPerm[i_] := First@Ordering[ Tr /@ (EuclideanDistance @@@ Transpose@{perm[i - 1], #} & /@
                                      (Permute[coords[[i]], #] & /@ validPerms))]
perm[i_] := perm[i] = Permute[coords[[i]], validPerms[[calcPerm@i]]]
f[x_] := Sin[FractionalPart@x Pi/2]^2
Animate[
 j = Min[IntegerPart@i, Length@coords - 1];
 Graph[edges,  VertexCoordinates -> Thread[Range@n -> f@t perm[j + 1] + (1 - f@t) perm[j]], 
       PlotRange -> {{-.2, 1.2}, {-0.2, 1.2}}],
 {t, 1, Length@coords, .005},
 {i, 1, Length@coords, .005},
 DisplayAllSteps -> True, AnimationDirection -> ForwardBackward]

The following (and more elegant) code for performing the same was done by shamelessly stealing some parts from @Vitaliy's code (from the notebook he linked in his answer)for using BSplineFunction[] as the evolution path instead of my previous linear interpolation.

{n, adj, coords1, perms} = GraphData["PappusGraph", {"VertexCount", "AdjacencyMatrix", 
                                   "AllVertexCoordinates", "AutomorphismGroup"}];
coords = Transpose[Rescale /@ Transpose@#] & /@ coords1;
validPerms = GroupElements@perms;
calcPerm[1] = 1;
calcPerm[i_] := First@Ordering[Tr /@ (EuclideanDistance @@@ Transpose@{perm[i - 1], #} & /@
                              (Permute[coords[[i]], #] & /@ validPerms))]
perm[i_] := perm[i] = Permute[coords[[i]], validPerms[[calcPerm@i]]]
Manipulate[
 AdjacencyGraph[adj, VertexCoordinates -> (#[t] & /@ (BSplineFunction[#, SplineDegree -> 1, 
                    SplineClosed -> True] & /@ Transpose[perm /@ Range@Length@coords])),
  PlotRange -> {{-.2, 1.2}, {-0.2, 1.2}}],
 {t, 0, 1, Animator, AnimationRunning -> False, AnimationRate -> .02, ImageSize -> Small}]

Previous (simpler) Answer using the default paths instead of the minimal one. Run it to see the difference

edges = GraphData["PappusGraph", "EdgeList"];
coords1 = GraphData["PappusGraph", "AllVertexCoordinates"];
coords = Transpose[Rescale /@ Transpose@#] & /@ coords1;
f[x_] := Sin[FractionalPart@x Pi/2]^2
Animate[
 j = Min[IntegerPart@i, Length@coords - 1];
 Graph[edges, VertexCoordinates -> Thread[Rule[Range@Length@First@coords, 
                                          f@t coords[[j + 1]] + (1 - f@t) coords[[j]]]], 
       PlotRange -> {{-.2, 1.2}, {-0.2, 1.2}}],
{t, 0, Length@coords - 1, .005},
{i, 1, Length@coords, .005},
DisplayAllSteps -> True, 
AnimationDirection -> ForwardBackward]

Answer 2

Have you seen my course:

Mastering Dynamic Visualizations with Mathematica

• notebook can be found HERE - look at the slide 5 and in the video about at 10 minutes from start.

I did something similar there but with ability to browse the data and adjust graph layouts manually and bookmark them and animate through it.

Simple 1st image code is below. Code for 2nd image please find in linked notebook - it has in-code images - hard to paste here.

Manipulate[

 AdjacencyGraph[amvcgd[[k, 1]],
  VertexCoordinates -> (#[
       t] & /@ (BSplineFunction[#, SplineDegree -> 1, 
         SplineClosed -> True] & /@ 
       Transpose[
        Transpose /@ 
         Map[Rescale, Transpose /@ N[amvcgd[[k, 2]]], {2}]])),
  ImageSize -> {400, 400}, GraphStyle -> gs]

 , {t, 0, 1, Animator, AnimationRunning -> False, 
  AnimationRate -> .02, ImageSize -> Small},
 {gs, {"BackgroundBlack", "ThickEdge", "BasicBlack", "Prototype", 
   "SimpleLink", "LargeNetwork", "SmallNetwork"}},
 {{k, 7, ""}, lofofr},

 Initialization :> (logn = {"PappusGraph", "DodecahedralGraph", 
     "CoxeterGraph", "Foster048A", "TesseractGraph", 
     "IcosahedralGraph", "LeviGraph", "TruncatedDodecahedralGraph", 
     "Balaban10Cage", "Foster056A", "TruncatedIcosahedralGraph", 
     "DeltoidalHexecontahedralGraph", 
     "SmallRhombicosidodecahedralGraph"}; 
   amvcgd = 
    GraphData[#, {"AdjacencyMatrix", "AllVertexCoordinates"}] & /@ 
     logn; lofofr = MapThread[Rule, {Range[13], logn}]),

 SynchronousUpdating -> False, FrameMargins -> 0]