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$
4
$\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$
  • $\begingroup$ Excellent. That nails the first part (my version is a mess!). Thoughts on the second part? $\endgroup$ – orome Mar 31 '15 at 20:39
  • $\begingroup$ @raxacoricofallapatorius There you go $\endgroup$ – Dr. belisarius Mar 31 '15 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, privacy policy and cookie policy

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