Skip to main content

graphics - 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]]

enter image description here


look like this


enter image description here



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.



Answer



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}]]}}]

enter image description here


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]], 
         {Arrowheads[{{OptionValue["arrowSize"], 1}}], Arrow[#1, OptionValue["setBack"]]}, 
     {If[OptionValue["biDirectionalEdges"] =!= "line", 
        Arrowheads[{-OptionValue["arrowSize"], OptionValue["arrowSize"]}],
        Arrowheads[{{0., 1}}]], Arrow[#1, OptionValue["setBack"]]}] &)];

(* 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];

enter image description here


Additional examples:


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}]

enter image description here


Comments

Post a Comment

Popular posts from this blog

functions - Get leading series expansion term?

Given a function f[x] , I would like to have a function leadingSeries that returns just the leading term in the series around x=0 . For example: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x)] x and leadingSeries[(1/x + 2 + (1 - 1/x^3)/4)/(4 + x)] -(1/(16 x^3)) Is there such a function in Mathematica? Or maybe one can implement it efficiently? EDIT I finally went with the following implementation, based on Carl Woll 's answer: lds[ex_,x_]:=( (ex/.x->(x+O[x]^2))/.SeriesData[U_,Z_,L_List,Mi_,Ma_,De_]:>SeriesData[U,Z,{L[[1]]},Mi,Mi+1,De]//Quiet//Normal) The advantage is, that this one also properly works with functions whose leading term is a constant: lds[Exp[x],x] 1 Answer Update 1 Updated to eliminate SeriesData and to not return additional terms Perhaps you could use: leadingSeries[expr_, x_] := Normal[expr /. x->(x+O[x]^2) /. a_List :> Take[a, 1]] Then for your examples: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x), x] leadingSeries[Exp[x], x] leadingSeries[(1/x + 2 + (1 - 1/x...
Post a Comment
Read more

mathematical optimization - Minimizing using indices, error: Part::pkspec1: The expression cannot be used as a part specification

I want to use Minimize where the variables to minimize are indices pointing into an array. Here a MWE that hopefully shows what my problem is. vars = u@# & /@ Range[3]; cons = Flatten@ { Table[(u[j] != #) & /@ vars[[j + 1 ;; -1]], {j, 1, 3 - 1}], 1 vec1 = {1, 2, 3}; vec2 = {1, 2, 3}; Minimize[{Total@((vec1[[#]] - vec2[[u[#]]])^2 & /@ Range[1, 3]), cons}, vars, Integers] The error I get: Part::pkspec1: The expression u[1] cannot be used as a part specification. >> Answer Ok, it seems that one can get around Mathematica trying to evaluate vec2[[u[1]]] too early by using the function Indexed[vec2,u[1]] . The working MWE would then look like the following: vars = u@# & /@ Range[3]; cons = Flatten@{ Table[(u[j] != #) & /@ vars[[j + 1 ;; -1]], {j, 1, 3 - 1}], 1 vec1 = {1, 2, 3}; vec2 = {1, 2, 3}; NMinimize[ {Total@((vec1[[#]] - Indexed[vec2, u[#]])^2 & /@ R...
Post a Comment
Read more

What is and isn't a valid variable specification for Manipulate?

I have an expression whose terms have arguments (representing subscripts), like this: myExpr = A[0] + V[1,T] I would like to put it inside a Manipulate to see its value as I move around the parameters. (The goal is eventually to plot it wrt one of the variables inside.) However, Mathematica complains when I set V[1,T] as a manipulated variable: Manipulate[Evaluate[myExpr], {A[0], 0, 1}, {V[1, T], 0, 1}] (*Manipulate::vsform: Manipulate argument {V[1,T],0,1} does not have the correct form for a variable specification. >> *) As a workaround, if I get rid of the symbol T inside the argument, it works fine: Manipulate[ Evaluate[myExpr /. T -> 15], {A[0], 0, 1}, {V[1, 15], 0, 1}] Why this behavior? Can anyone point me to the documentation that says what counts as a valid variable? And is there a way to get Manpiulate to accept an expression with a symbolic argument as a variable? Investigations I've done so far: I tried using variableQ from this answer , but it says V[1...
Post a Comment
Read more