How to make a Locator3D/LocatorSphere?

Question

On Making a LocatorSphere:

Okay so I'm trying to realize a Locator3D-esque functionality for Mathematica. Something like a LocatorSphere, possibly done in a way that the LocatorVector can be locked to certain regions/quadrants to ease confusion for the user and prevent egregious errors from occurring.

This will ultimately not be used on a sphere as seen here, so some aspect of customization should be possible (as you see how I have begun to add my own axes) and it needs to output coordinates that can readily be accessed in order to operate other functions, to be used as a locator. For simplicity's sake, it should stay normalized in length. I have something that I think I have taken as far as my skill level can take it. Also, apologies on not having a gif, feel free to add this or a better picture in an edit.

By modifying this answer:
Forcing a locator button to remain on the surface of a sphere

I have been able to do the following, which I think is quite a bit towards this goal, but can be taken further and/or optimized and simplified.

DynamicModule[{pt}, Manipulate[
  EventHandler[
   Style[
    Graphics3D[{
      {Opacity[0.5],
       First@
        ParametricPlot3D[{Cos[u] Sin[v], Sin[u] Sin[v], Cos[v]}, {v, 
          0, Pi}, {u, 0, 2 Pi}, 
         MaxRecursion -> ControlActive[1, Automatic], 
         PlotPoints -> ControlActive[Automatic, 50]]},

      {Thick, Arrowheads[Large, Appearance -> "Projected"], 
       Arrow[{{0., 0., 0.}, Dynamic@pp[[1]]}]},

      {Thick, Arrowheads[Large, Appearance -> "Projected"], 
       Arrow[{{0., 0., 0.}, {1.5, 0., 0.}}]},

      {Thick, Arrowheads[Large, Appearance -> "Projected"], 
       Arrow[{{0., 0., 0.}, {0., 1.5, 0.}}]},

      {Thick, Arrowheads[Large, Appearance -> "Projected"], 
       Arrow[{{0., 0., 0.}, {0., 0., 1.5}}]}},

     Boxed -> False, PlotRange -> 1.6,

     Epilog -> 
      Inset[Style[
        "\[Phi]=" <> ToString[#[[2]]] <> ", \[Theta]=" <> 
           ToString[#[[3]]] &@ToSphericalCoordinates[pp[[1]]], 
        FontColor -> 
         Dynamic@If[CurrentValue["ShiftKey"], Black, Gray], 
        18], {Left, Top}, {Left, Top}], ImageSize -> {Automatic, 400},
      RotationAction -> "Clip"], 
    Deployed -> Dynamic@CurrentValue["ShiftKey"]],

   "MouseMoved" :> 
    If[CurrentValue[
      "ShiftKey"], (pp[[First@
            Ordering[Function[pt, (pt - #).(pt - #)] /@ pp, 
             1]]] = #) &@
      Normalize@
       First@MousePosition[
         "Graphics3DBoxIntercepts", {{-1., -1., -1.}, {1., 1., 1.}}]]],
  {{pp, Normalize /@ {{1., 1., 1.}}}, None},
  {nf, None},
  AutorunSequencing -> {2}]]

Which gives something like this:

But there are a few things I cannot make my brain figure out:

1. How to have a Locator click-and-drag-the-end-of-the-arrow type functionality?

When you use Locator instead of None in the last argument for pp in manipulate, it ends up creating several errors namely due to the fact that Locator uses a 2-D field to deliver its coordinates rather than the implemented 3-D one given by holding shift and moving the mouse around.

2. How to make the located coordinates usable in/able to be passed to other functions?

I genuinely cannot figure out how to access these dynamic variables. Though I can get the proper manipulation of them to occur within the Manipulate, it would be great to purposefully leak them to use in other functions, like how a Locator is designed to work.

3. How to lock the LocatorVector to a specific region/quadrant or set of values to prevent the user from making errors based on location choice?

I think this has something to do with the "Graphics3DBoxIntercepts" but I could not get anything meaningful to occur through my experimentation with it.

4. How to alter the view angle so that the region the vector starts in is visible to the user without manually rotating the Graphics3D?

This should be an easy one, I think...

5. How to improve this implementation further?

I know this can be immensely improved, and I hope others find this useful, even in its current, rough-and-tumbled format.

Answer 1

Here's something to get you started with a new design.

First we make the function that actually makes a DynamicModule. It supports having more than just a sphere as a background, but I haven't really played with that. It also supports the Dynamic vocabulary appropriately.

I included a "PointNormalizer" in case you want to pass in a Region as the background and use NearestFunction to compute the nearest point on the region.

I also added in support for automatic ViewPoint changes on "MouseUp".

The only annoying thing is that giving a dynamic value for PassEventsDown means standard rotations of the scene can be slow...

iVectorLocator // Clear
Options[iVectorLocator] =
  {
   "PointNormalizer" -> Normalize,
   "RotateView" -> True
   };
iVectorLocator[
  Dynamic[pt_, {fstart_, f : Except[OptionsPattern[]], fend_}, 
    dops : OptionsPattern[]] |
   Dynamic[pt_, {f : Except[OptionsPattern[]], fend_}, 
    dops : OptionsPattern[]] |
   Dynamic[pt_, f : Except[OptionsPattern[]], dops : OptionsPattern[]] |
   Dynamic[pt_, dops : OptionsPattern[]],
  arrowFunction_: Automatic,
  background_: Automatic,
  ops : OptionsPattern[{iVectorLocator, Graphics3D}]
  ] :=
 DynamicModule[
  {
   active,
   getMousePoint,
   getViewPoint,
   bg,
   ar,
   during,
   pre,
   post,
   vpt,
   rv = OptionValue["RotateView"]
   },
  bg =
   Replace[background, 
    Automatic :>
     {
      {
       Opacity[0.5],
       First@
        ParametricPlot3D[
         {Cos[u] Sin[v], Sin[u] Sin[v], Cos[v]}, {v, 0, Pi}, {u, 0, 2 Pi}, 
         MaxRecursion -> ControlActive[1, Automatic], 
         PlotPoints -> ControlActive[Automatic, 50]]
       },
      {
       GrayLevel[.5],
       Dashed,
       {Thick,
        Arrowheads[Large, Appearance -> "Projected"], 
        Arrow[{{0., 0., 0.}, {1.5, 0., 0.}}]
        }, {Thick, Arrowheads[Large, Appearance -> "Projected"], 
        Arrow[{{0., 0., 0.}, {0., 1.5, 0.}}]},
       {
        Thick,
        Arrowheads[Large, Appearance -> "Projected"], 
        Arrow[{{0., 0., 0.}, {0., 0., 1.5}}]
        }
       }
      }
    ];
  ar =
   Replace[
    arrowFunction,
    Automatic :>
     Function[
      Null,
      {
       Thick,
       Arrowheads[Large, Appearance -> "Projected"],
       Arrow[{{0., 0., 0.}, Dynamic[#, #2]}]
       },
      HoldFirst
      ]
    ];
  Replace[
   ar[pt, Flatten@{dops}],
   e : With[{aar = ar}, Except[_aar]] :> Set[ar, e]
   ];
  EventHandler[
   Graphics3D[
    {bg, ar},
    FilterRules[
     {
      ops,
      Boxed -> False,
      PlotRange -> 1.6,
      ImageSize -> {Automatic, 400},
      RotationAction -> "Clip",
      If[TrueQ@rv,
       ViewPoint -> Dynamic[vpt],
       Nothing
       ]
      },
     Options[Graphics3D]
     ]
    ],
   {
    "MouseDown" :>
     If[CurrentValue["ShiftKey"],
      pre[pt, getMousePoint[]];
      active = True;
      ],
    "MouseUp" :>
     If[active,
      post[pt, getMousePoint[]];
      If[rv, vpt = getViewPoint[]];
      active = False
      ],
    "MouseDragged" :>
     If[active,
      during[pt, getMousePoint[]]
      ],
    PassEventsDown -> FEPrivate`Not[FrontEnd`CurrentValue["ShiftKey"]]
    }
   ],
  Initialization :> {
    If[! ValueQ[pt], pt = Normalize[{1., 1., 1.}]],
    If[rv, vpt = getViewPoint[], vpt = Automatic],
    during = Replace[{f}, {} | {Automatic} -> {Set}][[1]],
    pre = Replace[{fstart}, {} | {Automatic} -> {during}][[1]],
    post = Replace[{fend}, {} | {Automatic} -> {during}][[1]],
    With[{norm = OptionValue["PointNormalizer"]},
     getMousePoint[] :=
      norm@First@
        MousePosition[
         "Graphics3DBoxIntercepts", {{-1., -1., -1.}, {1., 1., 1.}}]
     ],
    getViewPoint[] :=
     pt*2
    }
  ]

Now we'll turn that into a Formatted form of a different object. This is how most FE things are built.

Options[VectorLocator] =
  {
   Appearance -> Automatic
   };
Format[
  v :
   VectorLocator[
    d : (
      Dynamic[pt_, {fstart_, f : Except[OptionsPattern[]], fend_}, 
        dops : OptionsPattern[]] |
       Dynamic[pt_, {f : Except[OptionsPattern[]], fend_}, 
        dops : OptionsPattern[]] |
       Dynamic[pt_, f : Except[OptionsPattern[]], dops : OptionsPattern[]] |
       Dynamic[pt_, dops : OptionsPattern[]]
      ),
    background : Except[OptionsPattern[]] : Automatic,
    ops : OptionsPattern[{VectorLocator, Graphics3D, iVectorLocator}]
    ],
  StandardForm
  ] :=
 Interpretation[
  iVectorLocator[d, 
   OptionValue[{VectorLocator, Graphics3D, iVectorLocator}, {ops}, 
    Appearance], 
   background,
   FilterRules[
    {ops},
    Join[Options[iVectorLocator], Options[Graphics3D]]
    ]
   ],
  v
  ]

Now you can use it in the normal way like:

VectorLocator[Dynamic[vec], Background -> LightBlue]

or if you want it to spit out the end position:

VectorLocator[Dynamic[vec, {Automatic, Echo[#] &}], Background -> LightBlue]

or if you want a different shape as the background:

VectorLocator[Dynamic[pt], 
 GeometricTransformation[Sphere[], ScalingTransform[{1, .5, .5}]],
 Axes -> True,
 AxesOrigin -> {0, 0, 0}
 ]

And as you might guess from the fact that we pass a Dynamic as the first argument, if two of these things share the same variable and update to one will affect the other, which can be interesting to watch.

I think I actually hit the first four of your requests in doing this, even if by accident, too.