3
$\begingroup$

I've been trying to make graphs in which I can direct an edge to the midpoint of another edge, as in the following figure:

enter image description here

So far, what I've tried, (far from ideal, especially with bigger networks), is to create an additional node, and give coordinates to the vertex:

G = Graph[{a -> b, c -> d}, 
 VertexCoordinates -> {{1, 0}, {2, 0}, {1.5, 0.5}, {1.5, 0}}, 
 VertexLabels -> "Name"]

enter image description here

So, I would like to avoid specifying an extra set of nodes and their coordinates, and instead be able to join "edge to edge". Is this possible?

Thanks!

Pedro

$\endgroup$
2
  • 2
    $\begingroup$ how would you specify the edge c -> d if you do not include d in the vertex list? $\endgroup$
    – kglr
    May 11, 2019 at 5:37
  • $\begingroup$ That's the question. I think your answer below is a possible solution, but would still require specifying the coordinates of the vertex set. Maybe I can have two "types" of vertex, and just make those "midpoint" vertex all disappear. However, this would distort the edges that I care most about (for instance, the edge from a to b would not be "Straight" but probably will have the intermediate "kink" -if coordinates are unspecified-). $\endgroup$ May 11, 2019 at 5:42

2 Answers 2

2
$\begingroup$

I'm not sure you can get around adding invisible nodes, but here is a solution that doesn't require manually specifying any coordinates.

The function edgeToMidpoint takes as arguments a graph, a source vertex, which may or may not be an existing vertex in the graph, and a target edge.

edgeToMidpoint[graph_, sourcevert_, targetedge_] := 
  Module[{g = graph, coords, coord1, coord2, midpoint, mid, 
    newc, newcoords, vertshape, m, x, b, y},
   coords = AbsoluteOptions[g, VertexCoordinates][[1, 2]];
   coord1 = coords[[Position[VertexList[g], targetedge[[1]]][[1, 1]]]];
   coord2 = coords[[Position[VertexList[g], targetedge[[2]]][[1, 1]]]];
   midpoint = {Mean[{coord1[[1]], coord2[[1]]}], 
     Mean[{coord1[[2]], coord2[[2]]}]};

   If[FreeQ[VertexList[graph], sourcevert],
    {
     slope = -1/FindFit[{coord1, coord2}, m x + b, {m, b}, x][[1, 2]];
     int = midpoint[[2]] - slope midpoint[[1]];
     newc = Nearest[
        {x, y} /. Reverse[Solve[{EuclideanDistance[{x, y}, midpoint] == 0.5, y == slope x + int}, {x, y}]],
        Mean[coords],
        DistanceFunction -> (-Norm[#1 - #2] &)][[1]];
     newcoords = {newc, midpoint}
     },
    newcoords = {midpoint}];

   vertshape = 
    If[Length[AbsoluteOptions[graph, VertexShapeFunction][[1, 2]]] == 0,
     {_ -> Automatic, mid -> None},
     Append[AbsoluteOptions[graph, VertexShapeFunction][[1, 2]], mid -> None]];

   Graph[
     Join[EdgeList[graph], {sourcevert \[DirectedEdge] mid}],
     VertexCoordinates -> Join[coords, newcoords],
     VertexLabels -> 
      Append[AbsoluteOptions[graph, VertexLabels][[1, 2]], mid -> None],
     VertexShapeFunction -> vertshape,
     ImagePadding -> 10]
   ];

The example from the OP:

g = Graph[{a \[DirectedEdge] b}, VertexLabels -> "Name"];
edgeToMidpoint[g, c, a \[DirectedEdge] b]

enter image description here

With a slightly more complicated example:

g = Graph[{a -> b, d -> b, b -> c, c -> d}, VertexLabels -> "Name", 
  VertexShapeFunction -> Automatic, ImagePadding -> 10]

enter image description here

Calling edgeToMidpoint iteratively to add multiple new vertices-to-edges:

modlist = {{w, d \[DirectedEdge] b}, {x, c \[DirectedEdge] d}, {z, a \[DirectedEdge] b}, {c, d \[DirectedEdge] b}};
h = g;
Do[h = edgeToMidpoint[h, mod[[1]], mod[[2]]], {mod, modlist}]
h

enter image description here

The placement of new vertices is probably not super robust, but it works for these simple examples.

$\endgroup$
3
$\begingroup$

You can make the extra vertices invisible using VertexLabels -> None and VertexShapeFunction -> None:

Graph[{a -> b, c -> d}, 
  VertexCoordinates -> {{1, 0}, {2, 0}, {1.5, 0.5}, {1.5, 0}}, 
  VertexLabels -> {_ -> "Name", d -> None}, 
  VertexShapeFunction -> {_ -> Automatic, d -> None}]

enter image description here

You get the same result using

Graph[{a, b, c, Property[d, {VertexLabels -> None, VertexShapeFunction -> None}]}, 
  {a -> b, c -> d}, 
  VertexCoordinates -> {{1, 0}, {2, 0}, {1.5, 0.5}, {1.5, 0}}, 
  VertexLabels ->  "Name"]

same picture

You can avoid specifying the coordinates of the invisible vertex d using RegionNearest:

 Graph[{a -> b, c -> d}, 
  VertexCoordinates -> {{1, 0}, {2, .25}, {1.5, 0.5}, 
   RegionNearest[Line[{{1, 0}, {2, .25}}], {1.5, .5}]}, 
  VertexLabels -> {_ -> "Name", d -> None}, 
  VertexShapeFunction -> {_ -> Automatic, d -> None}]

enter image description here

With random coordinates for the first three vertices:

SeedRandom[777]
vc = RotateRight @ SortBy[First] @ RandomReal[1, {3, 2}];
Graph[{a -> b, c -> d}, 
 VertexCoordinates -> Append[vc, RegionNearest[Line[vc[[;;2]]], vc[[3]]]], 
 VertexLabels -> {_ -> "Name", d -> None},
 VertexShapeFunction -> {_ -> Automatic, d -> None}]

enter image description here

Update: Using the option EdgeShapeFunction to redirect the edge c -> a to the nearest point on the edge a -> b:

g1 = Graph[{a -> b, c -> a},  GraphLayout -> "CircularEmbedding", 
   VertexLabels -> "Name", ImageSize -> 300];
g2 = SetProperty[{g1, c \[DirectedEdge] a},
  EdgeShapeFunction -> (Arrow[{#[[1]], 
    RegionNearest[Line[PropertyValue[{g1, #}, VertexCoordinates]&/@ {a, b}], #[[1]]]}] &)];

Row[{g1, g2}, Spacer[10]]

enter image description here

$\endgroup$
0

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

Not the answer you're looking for? Browse other questions tagged or ask your own question.