# Animating transition between all graph representations obtained from curated data

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/2}, {-1/2, -Sqrt/2}, {-1, 0},
{1/2, Sqrt/2}, {1, 0}, {0, 0}, {-1/2, Sqrt/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: • For the record, here is the original answer from Mark McClure. I believe that it's great to give him credits. – Öskå May 26 '14 at 23:14
• related: 46671 – Kuba May 27 '14 at 6:21
• I suggest a more sophisticated interpolation strategy: i.stack.imgur.com/Dk1WF.gif If there is interest I can try wrapping it up in a function for use in belisarius's answer. – user484 May 27 '14 at 6:37
• Yes, @Kuba, thanks for the link, it is truly related, and the aesthetics of those animations seem even more profound. – VividD May 27 '14 at 6:38
• @Rahul Narain There is interest. Thanks for the idea/aproach anyway. – VividD May 27 '14 at 6:41

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

• Bravo! Standing ovation. +1 – m_goldberg May 27 '14 at 5:26
• @m_goldberg Thanks! You may want to sit down now. :) – Dr. belisarius May 27 '14 at 11:58
• Congratulations for surpassing 50k! And you passed it in a superior way, with this beautiful answer! – VividD May 27 '14 at 21:25
• @VividD Thanks. Glad you like it :) – Dr. belisarius May 27 '14 at 22:03
• Amazing. ${}{}$ – user484 May 30 '14 at 2:22

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[

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",
{{k, 7, ""}, lofofr},

Initialization :> (logn = {"PappusGraph", "DodecahedralGraph",
"CoxeterGraph", "Foster048A", "TesseractGraph",
"IcosahedralGraph", "LeviGraph", "TruncatedDodecahedralGraph",
"Balaban10Cage", "Foster056A", "TruncatedIcosahedralGraph",
"DeltoidalHexecontahedralGraph",
"SmallRhombicosidodecahedralGraph"};
amvcgd =