Wolfram mathematica 更改GraphPlot中的边路由以避免歧义

我有下面的无向图

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，“变通办法”）。至少可以说，这很尴尬。有更好的办法吗？（这是我的第一个问题！）

方法1

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]

方法2（变通办法）

---

这里有一个更棘手的解决办法：

Graphics[Annotation[GraphicsComplex[{{2., 0.}, {1., 1.}, 
          {1., -1.}, {3., 1.}, {3., -1.}, {0., 0.}, {4., 0.}, {0., 
     2.}, {4., 2.}}, 
        {{RGBColor[0.5, 0., 0.], Line[{{1, 2}, {1, 3}, {1, 4}, {1, 5}, 
                {2, 6}, {3, 6},  {7, 4}, {7, 5}, {6, 8}, {8, 9}, {9, 
        7}}]}, 
          {Text[Framed[1, {Background -> RGBColor[1, 1, 0.8], 
                  FrameStyle -> RGBColor[0.94, 0.85, 0.36], 
        FrameMargins -> 
                    Automatic}], 1], Text[Framed[2, 
                {Background -> RGBColor[1, 1, 0.8], FrameStyle -> 
                    RGBColor[0.94, 0.85, 0.36], 
        FrameMargins -> Automatic}], 2], 
            Text[Framed[3, {Background -> RGBColor[1, 1, 0.8], 
                  FrameStyle -> RGBColor[0.94, 0.85, 0.36], 
        FrameMargins -> 
                    Automatic}], 3], Text[Framed[6, 
                {Background -> RGBColor[1, 1, 0.8], FrameStyle -> 
                    RGBColor[0.94, 0.85, 0.36], 
        FrameMargins -> Automatic}], 4], 
            Text[Framed[7, {Background -> RGBColor[1, 1, 0.8], 
                  FrameStyle -> RGBColor[0.94, 0.85, 0.36], 
        FrameMargins -> 
                    Automatic}], 5], Text[Framed[4, 
                {Background -> RGBColor[1, 1, 0.8], FrameStyle -> 
                    RGBColor[0.94, 0.85, 0.36], 
        FrameMargins -> Automatic}], 6], 
            Text[Framed[5, {Background -> RGBColor[1, 1, 0.8], 
                  FrameStyle -> RGBColor[0.94, 0.85, 0.36], 
        FrameMargins -> 
                    Automatic}], 7]}}, {}], VertexCoordinateRules -> 
        {{2., 0.}, {1., 1.}, {1., -1.}, {3., 1.}, {3., -1.}, {0., 0.}, 
          {4., 0.}}], FrameTicks -> None, PlotRange -> All, 
    PlotRangePadding -> Scaled[0.1], AspectRatio -> Automatic, 
    ImageSize -> 250]

当然，我所做的是获取图形的

完整形式

，并对其进行编辑。我在

GraphicsComplex

（即

{0,2.}

和

{4,2.}

）中添加了几个点，在线条中添加了一些新的分支（即

{6,8}，{8,9}，{9,7}

），并删除了在顶点4和5之间绘制线条的分支

我并不是真的将此作为“解决方案”提供，但如果有人花了比我更多的时间来处理此问题，他应该能够编写一个函数，将GraphicsComplex操作成所需的形式。

只是一个kickstart

下面将检测是否存在“接触”不是其端点之一的顶点的边

它现在只适用于直线边

该计划将其作为第一步，然后创建模拟边缘，如问题中发布的方法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}};
a=InputForm@GraphPlot[gr，VertexLabeling->True，DirectedEdge->False，
顶点坐标->vcr，图像大小->250]；
距离[segmentEndPoints，pt]：=模块[{c，d，param，start，end}，
开始=段端点[[1]]；
端点=段端点[[2]]；
param=（（pt-start）。（end-start））/Norm[end-start]^2；
哪个[
参数<0，欧几里德距离[起始点，pt]，
参数>1，欧几里德距离[结束，pt]，
真，欧几里德距离[pt，start+param（end-start）]
]
];
edgeseq=Flatten[Cases[a//FullForm，Line[x_z]>x，无穷大，1]；
顶点=展平[
案例[a//FullForm，Rule[vertexcoordinalerules，x_uz]->x，无穷大]
,1];
关闭[通用：pspec]；
edgesPos=Replace[Edgeseq，{i_，j}->{vertex[[i]]，vertex[[j]}，1]；
关于[General:：pspec]；
numberOfVertexInEdge=
计数[#，0，2]&/@
表[Chop@distance[段，顶点]，{segments，edgesPos}，
{顶点，顶点}
];
如果[Length@Select[numberOfVertexInEdge，#>2&]>0，
“存在与顶点相交的边”，
“图形正常”]

@TomD我建议通过标题中的“边缘布线”更改“箭头方向”，以获得更具描述性的方向。谢谢！这是一个很好的建议，我做了相应的编辑。（我还稍微修改了“方法2”的代码。@TomD：我设计的另一个解决方法是使用GraphPlot3D并旋转图形，直到它看起来“令人满意”。但它看起来不像你的孪生钻石。这一个触发了一个更难的问题：如何检测一条边是否通过顶点布线。这种情况经常发生，我有几次，我试图找出动态生成的图形的错误，结果却发现这是一个边路由问题。@belisarius当这个Q第一次发布时，我编写了函数

IntersectQ

（）它可以传递给EdgeRenderingFunction来测试路由问题。但是它太慢了，无法用于原始问题的合理解决方案。我试图概括这个问题，但有太多的陷阱。有人知道Mathematica是否有布线算法吗？

Graphics[Annotation[GraphicsComplex[{{2., 0.}, {1., 1.}, 
          {1., -1.}, {3., 1.}, {3., -1.}, {0., 0.}, {4., 0.}, {0., 
     2.}, {4., 2.}}, 
        {{RGBColor[0.5, 0., 0.], Line[{{1, 2}, {1, 3}, {1, 4}, {1, 5}, 
                {2, 6}, {3, 6},  {7, 4}, {7, 5}, {6, 8}, {8, 9}, {9, 
        7}}]}, 
          {Text[Framed[1, {Background -> RGBColor[1, 1, 0.8], 
                  FrameStyle -> RGBColor[0.94, 0.85, 0.36], 
        FrameMargins -> 
                    Automatic}], 1], Text[Framed[2, 
                {Background -> RGBColor[1, 1, 0.8], FrameStyle -> 
                    RGBColor[0.94, 0.85, 0.36], 
        FrameMargins -> Automatic}], 2], 
            Text[Framed[3, {Background -> RGBColor[1, 1, 0.8], 
                  FrameStyle -> RGBColor[0.94, 0.85, 0.36], 
        FrameMargins -> 
                    Automatic}], 3], Text[Framed[6, 
                {Background -> RGBColor[1, 1, 0.8], FrameStyle -> 
                    RGBColor[0.94, 0.85, 0.36], 
        FrameMargins -> Automatic}], 4], 
            Text[Framed[7, {Background -> RGBColor[1, 1, 0.8], 
                  FrameStyle -> RGBColor[0.94, 0.85, 0.36], 
        FrameMargins -> 
                    Automatic}], 5], Text[Framed[4, 
                {Background -> RGBColor[1, 1, 0.8], FrameStyle -> 
                    RGBColor[0.94, 0.85, 0.36], 
        FrameMargins -> Automatic}], 6], 
            Text[Framed[5, {Background -> RGBColor[1, 1, 0.8], 
                  FrameStyle -> RGBColor[0.94, 0.85, 0.36], 
        FrameMargins -> 
                    Automatic}], 7]}}, {}], VertexCoordinateRules -> 
        {{2., 0.}, {1., 1.}, {1., -1.}, {3., 1.}, {3., -1.}, {0., 0.}, 
          {4., 0.}}], FrameTicks -> None, PlotRange -> All, 
    PlotRangePadding -> Scaled[0.1], AspectRatio -> Automatic, 
    ImageSize -> 250]

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