# How can I replace bi-directional DirectedEdge pairs in a Graph with a single UndirectedEdge?

The Cayley graphs produced by Mathematica 8.0's CayleyGraph function represent actions that are their own inverses in an unconventional way: rather than using a single edge without arrows, it uses two edges, each represented by an arrow.

Is there a way to replace all (and only) pairs of such reflexive arrows in a Cayley diagram with a single undirected edge, while leaving any unpaired directed edges untouched?

For example is there a way to make edges in this

CayleyGraph[DihedralGroup[4]]


look like this

Note that I'm aware that one could generate the desired output "manually", using Graph (as was done to generate the example above), but the solution I'm seeking must work for far more complex graphs than the one illustrated here from the simple group specifications that can be provided to CayleyGraph.

-
I suspect that the correct approach involves some searching (I'm not sure where) for matching pairs of \[DirectedEdge], and then replacing (using EdgeDelete and EdgeAdd) those with a single \[UndirectedEdge] (somehow of the same color). But I have no idea how to do that. Alternately, in may be that a this requires a replacement for CayleyGraph that builds a graph from scratch (e.g., from some form of group specification or the output of GroupGenerators and GroupElements). –  raxacoricofallapatorius May 31 '12 at 18:41
I just tried that, but got a message Graph::supp: Mixed graphs and multigraphs are not supported. No idea what that means. I can't check the result right now (for running the front end over the internet I just don't have the necessary bandwidth, so I can only use the kernel right now). Anyway, here's my code: Module[{vl=VertexList[#], el=EdgeList[#]}, Graph[vl, el /. {x_ \[DirectedEdge] y_ /; el ~MemberQ~ (y \[DirectedEdge] x) :> If[Order[x, y]==1, x \[UndirectedEdge] y, Unevaluated@Sequence[]]}]]& –  celtschk May 31 '12 at 22:48

You can use custom EdgeShapeFunction as in

ClearAll[fromDirectedToMixedGraph];
fromDirectedToMixedGraph[g_Graph] :=
Module[{edges = (EdgeList[g]) //  DeleteDuplicates[#, Sort@#1 == Sort@#2 &] &,
vertices = VertexList[g], vcoords = AbsoluteOptions[g, VertexCoordinates],
esf = EdgeShapeFunction -> (If[MemberQ[(Pick[
EdgeList[g], (Count[EdgeList[g], # | Reverse[#]] > 1) & /@
EdgeList[g], False]), #2 | Reverse[#2]], Arrow[#1], Line[#1]] &), options},
options = {First@# -> Select[Last@#, (MemberQ[edges, First@#] &)]} & /@ (Options[g]);
Graph[vertices, edges, vcoords, esf, options]]


Example:

Grid@Table[{g, fromDirectedToMixedGraph[g]}, {g, {CayleyGraph[DihedralGroup[4]],
CayleyGraph[AbelianGroup[{2, 2, 2, 2, 2}]]}}]


EDIT: The following variant adds two options to control the rendering of multiple edges (as lines or bi-directional arrows). It also allows inheriting the options from the input graph and using any Graph option.

ClearAll[mixedEdgeGraph];
Options[mixedEdgeGraph] = Join[Options[Graph],
{"arrowSize" -> .03, "setBack" -> .1, "biDirectionalEdges" -> "line"}];

mixedEdgeGraph[g_Graph, opts : OptionsPattern[mixedEdgeGraph]] :=
Module[{doubleEdges, singleEdges, vcoords, esf, options,
edges = DeleteDuplicates[EdgeList[g], Sort@#1 == Sort@#2 &],vertices = VertexList[g]},
{doubleEdges, singleEdges} =  DeleteDuplicates[#, Sort@#1 == Sort@#2 &] & /@
(Pick[EdgeList[g], (MemberQ[EdgeList[g], Reverse[#]]) & /@
EdgeList[g], #] & /@ {True, False});

(* remove from Options[g] properties and option values that belong to deleted edges *)
options = Sequence @@ DeleteCases[
Options[g], (e_ -> __) /;  MemberQ[Complement[EdgeList[g], edges], e], {1, Infinity}];

(* default EdgeShapeFunction to render multi-edges as lines or bidirectional arrows*)
esf = If[FilterRules[{opts}, EdgeShapeFunction] =!= {},
FilterRules[{opts}, EdgeShapeFunction],
EdgeShapeFunction -> (If[MemberQ[singleEdges, #2 |Reverse[#2]],
{If[OptionValue["biDirectionalEdges"] =!= "line",

(* use vertex coordinates of g unless VertexCooordinates or GraphLayout is specified *)
vcoords =  If[FilterRules[{opts}, {GraphLayout}] =!= {},
VertexCoordinates -> Automatic, AbsoluteOptions[g, VertexCoordinates]];

(* explictly provided Graph options override the default options inherited from g *)
Graph[vertices, edges, FilterRules[{opts}, Options[Graph]], vcoords, esf, options]]


Examples:

optns = Sequence @@ {VertexLabels -> Placed["Name", Center],
VertexSize -> 0.4, ImageSize -> 300};
g1 = CayleyGraph[AbelianGroup[{2, 2, 2, 2}], optns];
g2 = CayleyGraph[AbelianGroup[{2, 2, 2}], optns];
g3 = CayleyGraph[SymmetricGroup[4], optns];
g4 = CayleyGraph[PermutationGroup[{Cycles[{{1, 5, 4}}], Cycles[{{3, 4}}]}], optns];


g5 = RandomGraph[BernoulliGraphDistribution[7, 0.6], DirectedEdges -> True,
VertexLabels -> Placed["Name", Center], VertexSize -> 0.2, ImageSize -> 300];
g6 = AdjacencyGraph[{{0, 1, 1, 1, 1}, {1, 0, 1, 0, 1}, {0, 1, 0, 1, 1},
{0, 1, 1, 0, 1}, {0, 0, 1, 1, 0}},
DirectedEdges -> True,  VertexLabels -> Placed["Name", Center],
VertexSize -> 0.2,    ImageSize -> 300];
(PropertyValue[{g5, #}, EdgeStyle] = Hue[RandomReal[]]) & /@  EdgeList[g5];
(PropertyValue[{g6, #}, EdgeStyle] = Hue[RandomReal[]]) & /@  EdgeList[g6];
Grid[{#, mixedEdgeGraph[#],
mixedEdgeGraph[#, GraphLayout -> "SpringElectricalEmbedding",
"biDirectionalEdges" -> "doublearrows"]} & /@ {g5, g6}]


-
Thanks! I'd also like to be able substitute colors, but I'm bot sure how to modify the code above to do that. For example, I'd like to make all blue edges, say, magenta. I'd also like to rep ace the arrowhead style with something more like the one shown here. –  raxacoricofallapatorius Jun 7 '12 at 19:43
@raxa ... Two ways to do that without changing the code: you can use something like: Define, (say, for the example graph g2) newedgstyl = Options[g2, EdgeStyle] /. Hue[0.666666666666666] -> Hue[0.8], and then use it as mixedEdgeGraph[SetProperty[g2, EdgeStyle -> newedgstyl[[1, 2]]]]. Or, you can use it as SetProperty[mixedEdgeGraph[g2], EdgeStyle -> newedgstyl[[1, 2]]]. –  kguler Jun 7 '12 at 20:35
Thanks! That fixes the colors. –  raxacoricofallapatorius Jun 7 '12 at 21:12

The previous answers are wonderful. But at the risk of being repetitive, here is another answer. I believe what you really desire is to replace multi-directed edges with bi-directed edges as well as identifying group elements via tooltips and distinguishing unity. For example:

CG[PermutationGroup[{Cycles[{{1, 5, 4}}], Cycles[{{3, 4}}]}], 3]


CG[PermutationGroup[{Cycles[{{1, 5, 4}}], Cycles[{{3, 4}}]}], 2]


In this fashion distractions are minimized. Here is the code:

mc[n : {___Integer}, func_List, list_List] :=
Map[Fold[MapAt[#2[[1]], #1, List /@ #2[[2]]] &, #,
Transpose[{func, n}]] &, list];
mc[n : {___Integer}, func_, list_List] :=
Map[MapAt[func, #, List /@ n] &, list];
mc[n_Integer, func_, list_List] := Map[MapAt[func, #, n] &, list];

formatCycles[c_Cycles] :=
Row[Riffle[Row[Flatten@{"(", Riffle[#, " "], ")"}] & /@ c[[1]],
" "]];
formatCycles[c_] :=
Row[Flatten[({"(", If[Length[#] > 1, Riffle[#, " "], #], ") "}) & /@
c[[1]]]];
formatCycles[c_] := "" /; Sort[c] == c;
formatCycles[{}] := Style["(identity)", Gray];
formatCycles[Cycles[{}]] := Style["(identity)", Gray];
formatCycles[Cycles[{{}}]] := Style["(identity)", Gray];
$imageSize = 300; CG[group_, dim_] := Module[{v, e, edgeStyle, edgeColor, tools, eTool, vTool, ef, vf, len,$CG, tooltips}, $CG = CayleyGraph[group]; tooltips = AbsoluteOptions[$CG, Properties][[1, 2]];
v = VertexList[$CG]; len = Length[v]; e = Rule @@@ EdgeList[$CG];
edgeStyle = PropertyValue[$CG, {EdgeStyle}][[1, 2]]; tools = SplitBy[Sort[AbsoluteOptions[$CG, Properties][[1, 2]]],
Length[First[#]] &];
(edgeColor[List @@ #1] = Lighter@#2[[1]]) & @@@
mc[1, Rule @@ # &, edgeStyle];
(vTool[First[#]] = formatCycles@Last[#][[1, 2]]) & /@ tools[[1]];
(eTool[List @@ First[#]] = formatCycles@Last[#][[1, 2]]) & /@
tools[[2]];
If[len > 30,
If[dim == 2,
ef = ({edgeColor[#2], Arrowheads -> Medium,
Tooltip[Arrow[#1, 0.01], eTool[#2]]} &);
vf = ({Lighting -> "Neutral", EdgeForm[Black],
RGBColor[0.696078431372549, 0.7588235294117647,
0.845098039215686],
Tooltip[If[
len < 60, {Disk[#, .1], Black, Text[#2, #1]}, {Black,
Point[#]}], vTool[#2]]} &);
GraphPlot[e, EdgeRenderingFunction -> ef,
VertexRenderingFunction -> vf, ImageSize -> $imageSize, ImageMargins -> 0, PlotRangePadding -> 0, ImagePadding -> None, MultiedgeStyle -> 0.001], ef = ({edgeColor[#2], Arrowheads -> Small, Tooltip[Arrow[#1], eTool[#2]]} &); vf = ({Lighting -> "Neutral", Specularity[Brown, 3], Brown, Tooltip[If[ len < 60, {Sphere[#, 0.05], Black, Text[#2, #1]}, {Sphere[#, .1]}], vTool[#2]]} &); GraphPlot3D[e, EdgeRenderingFunction -> ef, ViewAngle -> All, PlotRangePadding -> 0, ImageSize ->$imageSize, Boxed -> False,
MultiedgeStyle -> 0.001]],
If[dim == 2,
ef = ({edgeColor[#2], Arrowheads -> Medium,
Tooltip[Arrow[#1, 0.12], eTool[#2]]} &);
vf = ({EdgeForm[{Black}],
If[#2 == 1, Blue, RGBColor[0.639216, 0.705882, 0.8]],
Tooltip[{Disk[#, 0.05]}, vTool[#2]]} &);
GraphPlot[e, EdgeRenderingFunction -> ef,
VertexRenderingFunction -> vf, ImageSize -> $imageSize, ImageMargins -> 0, PlotRangePadding -> 0, ImagePadding -> 10, MultiedgeStyle -> 0.001], ef = ({edgeColor[#2], Arrowheads -> Medium, Tooltip[Arrow[#1], eTool[#2]]} &); vf = ({Lighting -> "Neutral", Specularity[Brown, 3], If[#2 == 1, Hue[0.6], Gray], Tooltip[If[len < 60, {Sphere[#, 0.1]}, {Point[#]}], vTool[#2]]} &); GraphPlot3D[e, EdgeRenderingFunction -> ef, VertexRenderingFunction -> vf, ImageSize ->$imageSize,
Boxed -> True, PlotRangePadding -> 0, ImageMargins -> 0,
ImagePadding -> 0, MultiedgeStyle -> 0.001]]]]

-

Here is a complex Cayley graph:

g = CayleyGraph[AbelianGroup[{2, 2, 2, 2, 2}]]


And here is its beautiful none-directed edge counterpart:

AdjacencyGraph[
AbsoluteOptions[g,VertexCoordinates],
EdgeStyle->((EdgeStyle/.AbsoluteOptions[g,EdgeStyle])/.(x_\[DirectedEdge]y_)->
(x\[UndirectedEdge]y)),
DirectedEdges -> False]


-
Can I get this to work for a graph in which some of the edges are directed (in which case I'd like to leave them alone)? E.g g = CayleyGraph[DihedralGroup[4]]? –  raxacoricofallapatorius May 31 '12 at 19:32
The error I get for DihedralGroup[4] (or anything with single arrows between nodes) is "VertexCoordinates->{...} at position 2 is not a non-empty square matrix". I get that error even if I substitute the coordinates for AbelianGroup[{2, 2, 2}] (which works on its own) when tying to use the code above for DihedralGroup[4] –  raxacoricofallapatorius May 31 '12 at 20:07
@raxacoricofallapatorius AFAIK, you can't mix UE and DE in a Graph object... –  rm -rf May 31 '12 at 20:23
@R.M: If that's so, is there way a to create what I'm looking for by superposing two graphs: one where all paired DE have been replaced with a UE while unpaired DE are made invisible, and another where the paired DE are made invisible, while the unpaired DE are left alone? (If that's the only way to accomplish what I'm looking for.) –  raxacoricofallapatorius May 31 '12 at 20:31
@raxacoricofallapatorius I updated the code with DirectedEdges -> False option so your problem is fixed now. –  Vitaliy Kaurov May 31 '12 at 21:12

You cannot use both undirected and directed edges (i.e., mixed graph) in a Graph object. However, you can control the edge style and shapes for the multi-edge case separately and get what you want. Here's an example:

g = CayleyGraph[DihedralGroup[4]];

(* Separate the two sets of edges *)
edges1 = EdgeList@(g1 = EdgeDelete[g, DirectedEdge[a_, b_] /; EdgeQ[g, DirectedEdge[b, a]]]);
edges2 = DeleteDuplicates[EdgeList[GraphDifference[g, g1]], #1 === Reverse[#2] &];

(* Style the two graphs and put them together *)
Graph[edges1~Join~edges2,
VertexStyle -> Black
]


-
you can also do the stylings and shape in one go with a more detailed edge shape function. Note that the graph is still a directed one... DirectedGraphQ[finalgraph] will give True –  rm -rf May 31 '12 at 22:49
This works great except for groups without DE (e.g. AbelianGroup[{2, 2}]), where it gives weird results. –  raxacoricofallapatorius May 31 '12 at 23:10
It gives the correct result, but the orientation is wonky, because Graph uses an automatic layout that's dependent on the order in which edges are input. You can force it to be something that's useful with GraphLayout -> "SpringEmbedding", or anything else you like. The alternate is to explicitly provide VertexCoordinates... –  rm -rf Jun 1 '12 at 0:09

Version 10 supports graphs with mixed directed and undirected edges.

g = CayleyGraph[DihedralGroup[4]]

newEdges = Flatten[
GatherBy[EdgeList[g], Sort] /. {{a_  \[DirectedEdge] b_, _} :> {a <-> b}}
]