Изменение граничного маршрута в 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, «Обходной путь»). Это неловко, если не сказать больше. Есть ли способ лучше? (Это мой первый вопрос!)

Метод 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 (обходной путь)

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, опубликованном в вопросе.

Использует другой ответ, который я разместил здесь.

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

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

Конечно, я взял FullForm графического изображения графика и отредактировал его. Я добавил пару точек к GraphicsComplex (то есть {0., 2.} и {4., 2.}), поместил несколько новых ветвей в линию (т.е. {6, 8}, {8, 9}, {9, 7}) и удалил ногу, которая нарисовала линию между вершинами 4 и 5.

На самом деле я не предлагаю это как «решение», но кто-то, у кого больше времени, чем мне нужно, должен написать функцию для манипулирования GraphicsComplex в желаемой форме.