wolfram-mathematica - 更改 GraphPlot 中的边路由以避免二义性

Question

我有以下无向图

gr={1->2,1->3,1->6,1->7,2->4,3->4,4->5,5->6,5->7};

我希望用 GraphPlot 以“菱形”格式绘制。我按照概述执行此操作
下面(方法1)给出以下内容:



问题是这种表示具有欺骗性，因为顶点 4 和 1 或 1 和 5 之间没有边(边是从 4 到 5)。我希望更改边 {4,5} 的路线以获得如下所示的内容:



我通过包含另一个边 {5,4} 来做到这一点，现在我可以使用 MultiedgeStyle 来“移动”违规边，然后我通过定义 EdgeRenderingFunction 来摆脱添加的边，从而不显示违规行。 (方法 2，“解决方法”)。这很尴尬，至少可以这么说。有没有更好的办法？ (这是我的第一个问题!)

方法一

gr={1->2,1->3,1->6,1->7,2->4,3->4,4->5,5->6,5->7};

vcr={1-> {2,0},2-> {1,1},3-> {1,-1},4-> {0,0},5-> {4,0},6-> {3,1},7-> {3,-1}};

GraphPlot[gr,VertexLabeling-> True, 
             DirectedEdges-> False,
             VertexCoordinateRules-> vcr, 
             ImageSize-> 250]

方法二(变通方法)

erf= (If[MemberQ[{{5,4}},#2], 
         { },      
         {Blue,Line[#1]}
        ]&);

gp[1] = 
       GraphPlot[
                 Join[{5->4},gr], 
                        VertexLabeling->True, 
                        DirectedEdges->False, 
                        VertexCoordinateRules->vcr, 
                        EdgeRenderingFunction->erf, 
                        MultiedgeStyle->.8, 
                        ImageSize->250
                        ]

Answer 1

只是一个启动

下面检测是否有一条边“接触”了一个不是其端点之一的顶点。

它现在仅适用于直线边缘。

该计划将其用作第一步，然后按照问题中发布的方法 2 创建模拟边缘。

使用我发布的另一个答案 here.

Clear["Global`*"];
gr = {1 -> 2, 1 -> 3, 1 -> 6, 1 -> 7, 2 -> 4, 3 -> 4, 4 -> 5, 5 -> 6, 5 -> 7};
vcr = {1 -> {2, 0}, 2 -> {1, 1}, 3 -> {1, -1}, 4 -> {0, 0}, 
       5 -> {4, 0}, 6 -> {3, 1}, 7 -> {3, -1}};
a = InputForm@GraphPlot[gr, VertexLabeling -> True, DirectedEdges -> False, 
                       VertexCoordinateRules -> vcr, ImageSize -> 250] ;

distance[segmentEndPoints_, pt_] := Module[{c, d, param, start, end},
   start = segmentEndPoints[[1]];
   end = segmentEndPoints[[2]];
   param = ((pt - start).(end - start))/Norm[end - start]^2;
   Which[
    param < 0, EuclideanDistance[start, pt],
    param > 1, EuclideanDistance[end, pt],
    True, EuclideanDistance[pt, start + param (end - start)]
    ]
   ];

edgesSeq= Flatten[Cases[a//FullForm, Line[x_] -> x, Infinity], 1];

vertex=Flatten[
          Cases[a//FullForm,Rule[VertexCoordinateRules, x_] -> x,Infinity]
               ,1];

Off[General::pspec];
edgesPos = Replace[edgesSeq, {i_, j_} -> {vertex[[i]], vertex[[j]]}, 1];
On[General::pspec];

numberOfVertexInEdge = 
  Count[#, 0, 2] & /@ 
   Table[ Chop@distance[segments, vertices], {segments, edgesPos}, 
                                             {vertices, vertex}
        ];

If[Length@Select[numberOfVertexInEdge, # > 2 &] >  0, 
            "There are Edges crossing a Vertex", 
            "Graph OK"]