# Plotting cities with Callout labels on a globe?

This question essentially amounts to implementing a very basic version of GeoGraphics3D:

data = CloudGet @ CloudObject["https://www.wolframcloud.com/objects/cb8f1216-74dd-463e-85a4-e976b6fd3fd4"]; pts = First/@data[[1]];
to3D[{lat_,lon_}] := {Cos[(lon+180) \[Degree]] Cos[lat \[Degree]],Sin[(lon+180) \[Degree]] Cos[lat \[Degree]],Sin[lat \[Degree]]};
depth = GeoListPlot[{},GeoBackground->"ReliefMap",GeoRange->"World",GeoZoomLevel->2];
earth3D = SphericalPlot3D[1, {u, 0, Pi}, {v, 0, 2 Pi}, PlotPoints -> 50, MaxRecursion -> 0, Mesh -> None, TextureCoordinateFunction -> ({#5, 1 - #4} &), PlotStyle -> Directive[Texture[depth], Specularity[White, 50]], Lighting -> "Neutral", Boxed -> False, Axes -> False, Background -> Black];
s = Show[earth3D, Graphics3D[{Opacity[.9], {Red, Sphere[to3D /@ pts, .02]}},
Boxed -> False, SphericalRegion -> True, ViewAngle -> .3,
Lighting -> "Neutral"], ImageSize -> Large]


Now here's where I get stuck:

c = Show[s,
ListPointPlot3D[
Callout[#1, #2, LeaderSize -> 50, FrameMargins -> 10] &, {to3D /@
pts, data[[2]]}], Boxed -> False, Axes -> None]];


The Callouts sort of work but get cut off randomly, any ideas on how to avoid this chopping?

• They look like they're going inside the globe. What you could do is normalize your positions in such a way as to force them to be on a sphere with radius larger than your globe. Or to keep the nice spacings you could add a necessary minimal amount to the radius. – b3m2a1 Apr 1 '19 at 20:23
• @b3m2a1 I was thinking the same thing, or maybe using Text directly – M.R. Apr 1 '19 at 21:03
• Text will layer the stuff behind the globe in front of it which is I think not what you want – b3m2a1 Apr 1 '19 at 21:04
• Right, I was considering filtering out things behind a plane, I think your idea is better. – M.R. Apr 1 '19 at 21:11
• Is it possible to use Epilog[] in your case? – MK. Apr 8 '19 at 15:29

Here are some of my attempts: (code for all versions can be found at the bottom of this answer)

First for comparison, your attempt (simplified to improve clarity):

### Labels further away

Moving the anchor points away from the sphere: (also suggested in the comments)

### Custom dynamic callouts

An attempt at custom callouts that try to position themselves "away" from the sphere. Below you'll find two versions of the code for this, a simpler using normal dynamic functionality and one that runs in the front-end only, for improved performance.

### Spreading of label anchor points

As noted in the comments, the methods above do not yield satisfactory results for the dataset given in the question. Below is one approach to deal with the closely packed points. Essentially, spreads the anchor points by treating the points as charges which repel each other.

## Code

This is a stripped down version of your code, with slightly different styling.

pts = RandomPoint[Sphere[], 20];
labels = RandomWord[20];

Show[
Graphics3D[
{
LightGray,
Sphere[],
Red,
{
Red,
Sphere[#, 0.05]
} &,
{pts, labels}
]
},
Lighting -> "Neutral",
RotationAction -> "Clip",
Boxed -> False
],
ListPointPlot3D[
Callout[
#,
#2,
Above,
CalloutStyle -> Black,
Appearance -> "Frame"
] &,
{pts, labels}
],
PlotStyle -> PointSize@0
]
]


### Labels further away

This one is straightforward - we simply scale the anchor points by a factor (here 1.2) and draw lines to the actual points.

Show[
Graphics3D[
{
LightGray,
Sphere[],
Red,
{
Red,
Sphere[#, 0.05],
Black,
AbsoluteThickness@1.5,
Line@{#, 1.2 #}
} &,
{pts, labels}
]
},
Lighting -> "Neutral",
RotationAction -> "Clip",
Boxed -> False
],
ListPointPlot3D[
Callout[
1.2 #,
#2,
Above,
CalloutStyle -> Black,
Appearance -> "Frame"
] &,
{pts, labels}
],
PlotStyle -> PointSize@0
]
]


### Custom dynamic callouts

The idea is to check whether the label is on the left or right half of the plot by looking at ViewVectorand ViewVertical. This is done by checking whether the position vector points in the same direction (dot product positive) as the cross product of ViewVector and ViewVertical (which gives us the plane separating the left from the right half of the image).

viewVec = {{7, 0, 0}, {0, 0, 0}};
viewVert = {1, 0, 0};
Graphics3D[
{
LightGray,
Sphere[],
Red,
{
Red,
Sphere[#, 0.05],
Black,
AbsoluteThickness@1.5,
Line@{#, 1.2 #},
Inset[
Framed[#2, FrameMargins -> 2, Background -> White],
1.2 #,
Dynamic@
If[Cross[viewVert, Subtract @@ viewVec].# > 0, Left, Right]
]
} &,
{pts, labels}
]
},
Lighting -> "Neutral",
RotationAction -> "Clip",
Boxed -> False,
ViewVertical -> Dynamic@viewVert,
ViewVector -> Dynamic@viewVec
]


### Front-end only

It's the same method as the previous one, but written with only front-end compatible stuff. This means no kernel is needed for the dynamic evaluation, which has better performance (you can verify this with the LinkSnooper kernel). We need expand the cross and dot product computation manually, since the front-end doesn't know them (this is feExpr). We also need to be careful not to insert the values for viewVec and viewVert too soon, which is why I'm setting them at the bottom (please let me know if someone has a nicer method).

DynamicModule[
{
viewVec,
viewVert
},
With[
{
feExpr =
Cross[
Table[
FEPrivatePart[viewVert, i],
{i, 3}
],
Table[
FEPrivatePart[viewVec, 1, i] -
FEPrivatePart[viewVec, 2, i],
{i, 3}
]
].Table[Indexed[#, i], {i, 3}]
},
Graphics3D[
{
LightGray,
Sphere[],
{
Red,
Sphere[#, 0.05],
Black,
AbsoluteThickness@1.5,
Line@{#, 1.2 #},
Inset[
Framed[#2, FrameMargins -> 2, Background -> White],
1.2 #,
FEPrivateIf[FEPrivateGreater[feExpr, 0], Left, Right]
]
} &,
{pts, labels}
]
},
ViewVertical -> (viewVert = {0, 0, 1}; Dynamic@viewVert),
ViewVector -> (viewVec = {{7, 0, 0}, {0, 0, 0}}; Dynamic@viewVec),
Lighting -> "Neutral",
RotationAction -> "Clip",
Boxed -> False
]
]
]


As noted above, we spread the points by treating them as charges. There are a few parameters that can be tweaked to change the spreading behavior to one's liking:

• spreadSteps: How often to repeat the spreading procedure (i.e. the number of time steps of the "simulation")
• repelStregth: How strongly points repel each other (i.e. the "charge" of the points)
• minDist: The minimal distance between two points to use for the "force" computation. This prevents very closely packed points from exploding away from each other.

Of course, this method can also be combined with any of the other methods to attach the labels to the anchor points.

data = CloudGet@
CloudObject[
"https://www.wolframcloud.com/objects/cb8f1216-74dd-463e-85a4-\
e976b6fd3fd4"];
to3D[{lat_, lon_}] := {Cos[(lon + 180) °] Cos[lat °],
Sin[(lon + 180) °] Cos[lat °], Sin[lat °]};
pts3D = to3D /@ data[[1,All,1]];

repelStrength = 0.0001;
minDist = 0.05;

Table[
Function[{pt, rest},
Normalize[
pt + repelStrength  Total[(pt - #)/
Clip[Norm[pt - #], {minDist, ∞}]^3 & /@ rest]]
] @@ {First@#, #2} & @@
TakeDrop[#, {i}],
{i, Length@#}
] &,
pts,
]

Show[
Graphics3D[
{
RGBColor[0.3, 0.5, 0.7],
Sphere[],
Red,
{
Red,
Sphere[#, 0.02],
White,
AbsoluteThickness@3,
Line@{#, 1.2 #2}
} &,
]
},
Lighting -> "Neutral",
RotationAction -> "Clip",
Boxed -> False
],
ListPointPlot3D[
Callout[
1.2 #,
#2,
Above,
`