Can I direct an edge to the midpoint of another edge in a graph?

Question

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:

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

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

Answer 1

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]

With a slightly more complicated example:

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

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

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

Answer 2

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

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

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

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