Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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

share|improve this question
6  
For the record, here is the original answer from Mark McClure. I believe that it's great to give him credits. –  Öskå May 26 at 23:14
1  
related: 46671 –  Kuba May 27 at 6:21
2  
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. –  Rahul May 27 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 at 6:38
    
@Rahul Narain There is interest. Thanks for the idea/aproach anyway. –  VividD May 27 at 6:41

2 Answers 2

up vote 25 down vote accepted

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]
share|improve this answer
6  
Bravo! Standing ovation. +1 –  m_goldberg May 27 at 5:26
2  
@m_goldberg Thanks! You may want to sit down now. :) –  belisarius May 27 at 11:58
    
Congratulations for surpassing 50k! And you passed it in a superior way, with this beautiful answer! –  VividD May 27 at 21:25
    
@VividD Thanks. Glad you like it :) –  belisarius May 27 at 22:03
1  
Amazing. ${}{}$ –  Rahul May 30 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.

enter image description here

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]
share|improve this answer
1  
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 at 21:28
    
@VividD Vitaly's fondness for "the big picture" comes with age. It's proper name is Hyperopia –  belisarius May 27 at 22:05
1  
@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 at 22:17
    
@VitaliyKaurov :) Very nice pictures here, indeed! –  belisarius May 27 at 22:23
    
@VitaliyKaurov Stole some code from your notebook. Hope you don't mind :) –  belisarius May 30 at 13:14

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.