Generating different GeoPaths for multiple equivalent segments

Here's one idea. Start with the geodesic, then walk an offset perpendicular to that path. The offset length should vary along the path.

multiGeoPath[spec_, n_Integer?Positive, offset_] :=
  Block[{pts, degs, len, offsets},
    pts = Reverse[GeoGraphics`GeoEvaluate[GeoPath[spec]][[1]], {2}];
    degs = Prepend[GeoDirection @@@ Partition[pts, 2, 1] - Quantity[90, "Degrees"], Quantity[0, "Degrees"]];

    len = Length[pts];
    offsets = offset Range[-Quotient[n-1, 2], Quotient[n, 2]];

    Line /@ Table[
      GeoDestination[
        GeoPosition[pts[[i]]], 
        GeoDisplacement[{1000k Sin[π(i - 1)/(len - 1)], degs[[i]]}]
      ],
      {k, offsets}, 
      {i, Length[pts]}
    ]
  ]

spec = {Entity["Country", "China"], Entity["Country", "Brazil"]};
GeoGraphics[{Red, multiGeoPath[spec, 2, 500]}, GeoRange -> "World"]

enter image description here

GeoGraphics[{Red, multiGeoPath[spec, 5, 500]}, GeoRange -> "World"]

enter image description here

gplot = GeoGraphics[MapIndexed[{ColorData[112][First[#2]], #1} &,
  multiGeoPath[spec, 18, 500]], GeoRange -> "World"]

enter image description here

These end up looking quite natural when lifted back up to 3D. Mimicking Jose's technique:

{loc1, loc2} = GeoPosition /@ spec;
midp = GeoDestination[loc1, {GeoDistance[loc1, loc2]/2, GeoDirection[loc1, loc2]}];

Show[gplot, GeoProjection -> {"Orthographic", "Centering" -> midp}, 
  GeoRange -> "World", GeoZoomLevel -> 3]

enter image description here


Let me propose an alternative, very similar in spirit to Chip's idea, but avoiding the use of the internal GeoGraphics`GeoEvaluate. I'll base the construction on a L-type displacement that moves a distance d in a given direction and then a distance t in the perpendicular at the final point:

GeoKnightDestination[loc_, a_, {d_, t_}] := Module[{p, pa},
   p = GeoDestination[loc, {d, a}];
   pa = GeoDirection[p, loc] + Quantity[90, "AngularDegrees"];
   GeoDestination[p, {t, pa}]
]

We will call the pair {d, t} a "knight". We need to create a grid of them:

loc1 = Entity["City", {"Petropolis", "RioDeJaneiro", "Brazil"}];
loc2 = Entity["City", {"Beijing", "Beijing", "China"}];

d = GeoDistance[loc1, loc2];
a = GeoDirection[loc1, loc2];
midp = GeoDestination[loc1, {d/2, a}];

npaths = 7;
npoints = 21;
dists = Subdivide[Quantity[0, "Miles"], d, npoints - 1];

These are the distances to the central path (controlling the mutual deviation):

perp = Subdivide[-d/4, d/4, npaths - 1];

This constructs the knights, with some parabolic distribution:

Dimensions[
    knights = Transpose[
        Thread /@ MapThread[List,
           {dists, TensorProduct[1 - Subdivide[-1, 1, npoints - 1]^2, perp]}
        ]
    ]
]
(* {7, 21, 2} *)

This constructs the grid of points:

GeoPosition[grid = Map[GeoKnightDestination[loc1, a, #] &, knights, {2}]]

And this is the result, with some styling. I add the yellow points to help understanding:

GeoGraphics[
   {Orange, GeoPath /@ grid, PointSize[Medium], Yellow, Point[grid]}, 
   GeoProjection -> {"Orthographic", "Centering" -> midp}, 
   GeoBackground -> "Satellite", Background -> Black,
   GeoRange -> "World", GeoZoomLevel -> 2, PlotRangePadding -> 0.1, 
   GeoGridLines -> Automatic
]

enter image description here


A completely different answer, this time ignoring Geo methods and focusing on Graph connectivity: just place the Graph object on the map.

Take your entity pairs:

ents = {
    {Entity["Country", "India"], Entity["Country", "China"]},
    {Entity["Country", "China"], Entity["Country", "Brazil"]},
    {Entity["Country", "Brazil"], Entity["Country", "Chile"]},
    {Entity["Country", "Chile"], Entity["Country", "Brazil"]},
    {Entity["Country", "Brazil"], Entity["Country", "China"]}
};

Draw a map with those entities. This time we use the Mollweide projection and a vector background:

map = GeoGraphics[ents, GeoProjection -> "Mollweide", GeoBackground -> "CountryBorders"];

Extract the actual projection used by GeoGraphics. Recall that GeoGraphics adds parameters to the projection to adapt it to the situation, unless those parameters are explicit:

proj = GeoProjection /. Options[map, GeoProjection]
(* {"Mollweide", "Centering" -> GeoPosition[{-1.07727, 29.5607}]} *)

Now, eliminate duplicate entities and find their respective projected coordinates:

uents = Union[Flatten[ents]]
(* {Entity["Country", "Brazil"], Entity["Country", "Chile"], 
    Entity["Country", "China"], Entity["Country", "India"]} *)

coords = GeoGridPosition[GeoPosition[uents], proj][[1]]
(* {{-1.31625, -0.19348}, {-1.44548, -0.571304},
    {1.04746, 0.66214}, {0.717329, 0.384687}} *)

Construct a Graph object using those coordinates:

graph = Graph[uents, UndirectedEdge @@@ ents, VertexCoordinates -> coords]

And finally show the map and the graph together (Show should be able to merge directly the GeoGraphics and Graph objects, but currently we need to extract the Graphics from GeoGraphics):

Show[map[[1]], graph]

enter image description here

Tags:

Geographics

Recent Posts