2
$\begingroup$

I am trying to graphically represent cycles in various permutations of the alphabet, and have a question in two parts.

I have

cycles[r_] := Identity @@ PermutationCycles@
   (FirstPosition[CharacterRange["A", "Z"], #][[1]] & /@ Characters[r])

cyclesGraph[r_] := 
 Graph[#, VertexLabels -> "Name", EdgeShapeFunction -> (Arrow[#, 0.1] &)] & /@ 
   Map[letter[#[[1]]] \[DirectedEdge] letter[#[[2]]] &, #, {2}] & @
      Map[Partition[#, 2, 1, {1, 1}] &, cycles[r], {1}]

so that

cyclesGraph["AJDKSIRUXBLHWTMCQGZNPYFVOE"]

produces

Which is fine as far as as it goes but:

  1. I have a lot of Maps and applications that seem messy to me and wonder whether there isn't a better idiom for processing my list of characters into cycles and from there into the list of edges expected by Graph.

  2. While I need both of these functions, I also need an additional one that combines all the graphs into a single one, with the letters of the alphabet arranged evenly in sequence around the circumference, and each the edges for each cycle indicated in a different style (e.g color).

How can I do a better job of getting from a list of characters representing a permutation to cycle graphics, especially one that combines and distinguishes all cycles in a single figure?

$\endgroup$
2
  • $\begingroup$ letter is undefined $\endgroup$
    – Mr.Wizard
    Mar 31, 2015 at 21:15
  • 1
    $\begingroup$ @Mr.Wizard found it! $\endgroup$ Mar 31, 2015 at 21:28

3 Answers 3

5
$\begingroup$

Not going to win a beauty contest, but you might get some ideas:

string = "AJDKSIRUXBLHWTMCQGZNPYFVOE";    
rules[cycle_] := Thread[DirectedEdge[cycle, RotateLeft[cycle]]];
edges = MapIndexed[Style[#1, Thick, ColorData[2][#2[[1]]]] &, 
   rules /@ PermutationCycles[LetterNumber /@ Characters[string], Identity], {2}];
verts = PermutationCycles[LetterNumber /@ Characters[string], 
   Identity];
styles = Flatten@MapIndexed[# -> ColorData[2][#2[[1]]] &, verts, {2}];
coords = ({Cos[2 \[Pi]/26 #], Sin[2 \[Pi]/26 #]} & /@ Flatten@verts);

Graph[Flatten@edges, VertexCoordinates -> coords, 
 VertexLabels -> Thread[Range[26] -> CharacterRange["A", "Z"]], 
 VertexStyle -> styles, Background -> Gray,ImageSize -> Large]

enter image description here

Of course one can get a bit "fancier" using EdgeShapeFunction:

drawLines[points_List] :=
 If[points[[1]] != points[[-1]], {Arrowheads[{0, .025, 0.025, .05}], 
   Arrow[BSplineCurve[{points[[1]], {0, 0}, points[[-1]]}, 
     SplineWeights -> {2, 3, 2}]]}, Opacity[0]]

Graph[Flatten@edges, VertexCoordinates -> coords, 
 VertexLabels -> Thread[Range[26] -> CharacterRange["A", "Z"]], 
 VertexStyle -> styles, EdgeShapeFunction -> (drawLines[#1] &), 
 ImageSize -> Large, Background -> Gray]

enter image description here

$\endgroup$
5
$\begingroup$
s = "AJDKSIRUXBLHWTMCQGZNPYFVOE";
pc = PermutationCycles[ToCharacterCode@s - 64] // First;
Graph[Flatten[Thread[# -> RotateRight@#] & /@ pc], 
      VertexLabels -> Table[i -> FromCharacterCode[i + 64], {i, Flatten@pc}], 
      ImagePadding -> 12]

Mathematica graphics

Perhaps better:

pc = (PermutationCycles[ToCharacterCode@s - 64] // First) /. 
                                         x_?NumericQ :> FromCharacterCode[x + 64]
Graph[CharacterRange["A", "Z"], Flatten[Thread[# -> RotateRight@#] & /@ pc],
      VertexLabels -> "Name", ImagePadding -> 12, 
      VertexCoordinates -> ({Cos@#, Sin@#} & /@ Range[0, 2 Pi - 1/26, 2 Pi/26])]

Mathematica graphics

$\endgroup$
2
  • $\begingroup$ Excellent. That nails the first part (my version is a mess!). Thoughts on the second part? $\endgroup$
    – orome
    Mar 31, 2015 at 20:39
  • $\begingroup$ @raxacoricofallapatorius There you go $\endgroup$ Mar 31, 2015 at 21:22
5
$\begingroup$
ClearAll[cyclesF, edgesF]
cyclesF = Map[FromCharacterCode,
            64 + PermutationCycles[ToCharacterCode@# - 64][[1]], {-1}] &;
edgesF = Developer`PartitionMap[DirectedEdge @@ # &, #, 2, 1, {1, 1}] & /@
           cyclesF[#] &;

str = "AJDKSIRUXBLHWTMCQGZNPYFVOE";
colors = {Red, Green, Blue, Orange, Cyan, Yellow};
vl = cyclesF@str;
el = edgesF@str;
e = Join @@ (el);
v = DeleteDuplicates[Join @@ vl];
vc = GraphEmbedding[CompleteGraph[Length@v]];
estyle = Join @@ (Thread /@ Thread[el -> colors]);
vstyle = Join @@ (Thread /@ Thread[vl -> colors]);

Graph[e, VertexSize -> .5, VertexLabels -> Placed["Name", Center],
 EdgeStyle -> estyle, VertexStyle -> vstyle, VertexCoordinates -> Thread[v -> vc]]

enter image description here

Or, use HighlightGraph:

g1 = Graph[e, VertexSize -> .5, VertexLabels -> Placed["Name", Center], 
          VertexCoordinates -> Thread[v -> vc]];

HighlightGraph[g1, 
 Flatten@{Thread[Style[##]] & @@@ Thread[vl -> colors], 
          Thread[Style[##]] & @@@ Thread[{el , colors}]}]
(* same picture *)
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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