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

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

• how would you specify the edge c -> d if you do not include d in the vertex list?
– kglr
May 11, 2019 at 5:37
• 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-). May 11, 2019 at 5:42

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



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.

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