11
$\begingroup$

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]

enter image description here

Now here's where I get stuck:

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

enter image description here

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

$\endgroup$
  • 1
    $\begingroup$ 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. $\endgroup$ – b3m2a1 Apr 1 at 20:23
  • $\begingroup$ @b3m2a1 I was thinking the same thing, or maybe using Text directly $\endgroup$ – M.R. Apr 1 at 21:03
  • $\begingroup$ Text will layer the stuff behind the globe in front of it which is I think not what you want $\endgroup$ – b3m2a1 Apr 1 at 21:04
  • $\begingroup$ Right, I was considering filtering out things behind a plane, I think your idea is better. $\endgroup$ – M.R. Apr 1 at 21:11
  • $\begingroup$ Is it possible to use Epilog[] in your case? $\endgroup$ – MK. Apr 8 at 15:29
11
+100
$\begingroup$

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

Your attempt

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

enter image description here

Labels further away

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

enter image description here

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.

enter image description here

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.

enter image description here

Code

Your attempt

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,
   MapThread[
    {
      Red,
      Sphere[#, 0.05]
      } &,
    {pts, labels}
    ]
   },
  Lighting -> "Neutral",
  RotationAction -> "Clip",
  Boxed -> False
  ],
 ListPointPlot3D[
  MapThread[
   Callout[
     #,
     #2,
     Above,
     LeaderSize -> {Automatic, Automatic, 0},
     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,
   MapThread[
    {
      Red,
      Sphere[#, 0.05],
      Black,
      AbsoluteThickness@1.5,
      Line@{#, 1.2 #}
      } &,
    {pts, labels}
    ]
   },
  Lighting -> "Neutral",
  RotationAction -> "Clip",
  Boxed -> False
  ],
 ListPointPlot3D[
  MapThread[
   Callout[
     1.2 #,
     #2,
     Above,
     LeaderSize -> {Automatic, Automatic, 0},
     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,
  MapThread[
   {
     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[
       FEPrivate`Part[viewVert, i],
       {i, 3}
       ],
      Table[
       FEPrivate`Part[viewVec, 1, i] -
        FEPrivate`Part[viewVec, 2, i],
       {i, 3}
       ]
      ].Table[Indexed[#, i], {i, 3}]
   },
  Graphics3D[
   {
    LightGray,
    Sphere[],
    MapThread[
     {
       Red,
       Sphere[#, 0.05],
       Black,
       AbsoluteThickness@1.5,
       Line@{#, 1.2 #},
       Inset[
        Framed[#2, FrameMargins -> 2, Background -> White],
        1.2 #,
        FEPrivate`If[FEPrivate`Greater[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
   ]
  ]
 ]

Spreading anchor points

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;
spreadSteps = 20;
minDist = 0.05;

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

Show[
 Graphics3D[
  {
   RGBColor[0.3, 0.5, 0.7],
   Sphere[],
   Red,
   MapThread[
    {
      Red,
      Sphere[#, 0.02],
      White,
      AbsoluteThickness@3,
      Line@{#, 1.2 #2}
      } &,
    {pts3D, spreadPts[pts3D], data[[2]]}
    ]
   },
  Lighting -> "Neutral",
  RotationAction -> "Clip",
  Boxed -> False
  ],
 ListPointPlot3D[
  MapThread[
   Callout[
     1.2 #,
     #2,
     Above,
     LeaderSize -> {Automatic, Automatic, 0},
     CalloutStyle -> Directive[White, FontColor -> Black],
     Appearance -> "Frame"
     ] &,
   {spreadPts[pts3D], data[[2]]}
   ],
  PlotStyle -> PointSize@0
  ],
 Background -> Black
 ]
$\endgroup$
  • $\begingroup$ These answers are nice, but if you use my original pts and labels, it looks pretty bad with all the label collisions and overlaps $\endgroup$ – M.R. Apr 10 at 18:03
  • 1
    $\begingroup$ You're right, with your dataset it's not really readable. I've updated the answer with an point spreading method that should address these issues (this time tested with the original dataset) $\endgroup$ – Lukas Lang Apr 10 at 21:44

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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