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:

enter image description here

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:

enter image description here

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:

enter image description here

Also, BrouwerHaemersGraph:

enter image description here

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
I suggest a more sophisticated interpolation strategy: http://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. — , May 27 '14 at 06: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 06:38
@Rahul Narain There is interest. Thanks for the idea/aproach anyway. — VividD, May 27 '14 at 06:41
I also have an idea of applying different interpolation strategy, called "progressive disclosure", on top of belisarius' solution. If results are fine, I am going to publish here an answer tomorrow, or maybe later. — VividD, May 27 '14 at 21:23

score 26 · Accepted Answer · edited Apr 13 '17 at 12:55

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]

enter image description here

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]

Congratulations for surpassing 50k! And you passed it in a superior way, with this beautiful answer! — VividD, May 27 '14 at 21:25
@RahulNarain Thanks! I'm really very pleased with the aesthetics of the resulting animation. And I never thought it was (kind of) easy to get the "minimal displacement problem" solved. It's the main reason why I like Mma: it lets me solve problems that could take me a month in less than a day. — Dr. belisarius, May 30 '14 at 02:44
@RahulNarain what happened to your answer? I think it is important to address interpolation issue... Bring your answer back! I also plan to propose a related improvement... — VividD, May 30 '14 at 12:27

score 14 · Answer 2 · answered May 27 '14 at 16:30

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.

enter image description here

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]

I hadn't seen your course, and now that I saw it... it is amazing! I like your focus on big picture, as opposed to technical details! — VividD, May 27 '14 at 21:28
@VividD Vitaly's fondness for "the big picture" comes with age. It's proper name is Hyperopia — Dr. belisarius, May 27 '14 at 22:05
@belisarius this time you really cracked me up... and i thought it's the children for whom the trees are taller. — Vitaliy Kaurov, May 27 '14 at 22:17
@VitaliyKaurov Stole some code from your notebook. Hope you don't mind :) — Dr. belisarius, May 30 '14 at 13:14

Animating transition between all graph representations obtained from curated data

2 Answers2