5
$\begingroup$

I would like to plot a Sphere with an arrow, in which the label obscures part of the arrow, as shown here:

Graphics3D[{Thickness[0.01],
  Arrow[{{0, 0, 0}, {-1/Sqrt[2], 0, 1/Sqrt[2]}}],
  Text[Style[Rotate["r", \[Pi]/4], 32, Background -> Yellow], 
  {-1/(2 Sqrt[2]), 0, 1/(2 Sqrt[2])}],
  Opacity[0.2], Yellow, Sphere[]},
 ViewPoint -> {0, 10, 0}]

Sphere with arrow

The problem is, of course, that the Background color for the letter is not correct, so the background rectangle of the letter is (inappropriately) visible. I could adjust this background color by hand to match as well as possible the color of the sphere. I've even tried specifying the background color itself with Opacity. Alternatively, I could create an arrow in two parts so there is no need for a background dropout for the letter. None of these approaches is particularly satisfactory in the general case (where the overlapping surface may have a gradient in color, or other problems).

Is there a way to plot what I seek?

$\endgroup$
3
$\begingroup$

Changing the last four lines in the graphics list to this:

Opacity[0.2],
Yellow,
Arrow[{{0, 0, 0}, {-1/Sqrt[2], 0, 1/Sqrt[2]}}, {0.35, 0.25}],
Sphere[]

Gives this:

Mathematica graphics

The idea is that the arrow shaft is a tube, a 3D graphics primitive, so it will be colored similarly to the sphere since it will be subject to the same lighting. One problem is that if you move the graphics, the black will come through. I would rather expect the black to show through since the tube has opacity, but for some reason, it doesn't on my copy of Mathematica 12, until we move the graphics.

This idea cannot be extended to gradient surfaces, unfortunately.

$\endgroup$
  • $\begingroup$ Bravo. Excellent solution ($\checkmark$). I will use this a lot. $\endgroup$ – David G. Stork May 23 at 19:41
3
$\begingroup$

Another possibility is to invent your own arrow primitive:

textarrow[{p_, q_}, text_, opts : OptionsPattern[]] := 
  With[{t = 0.4},
   {
    Line[{p, (1 - t) p + t q}],
    Arrow[{t p + (1 - t) q, q}],
    Inset[Graphics[Text[text, {0, 0}, opts]], (p + q)/2]
    }
   ];

Graphics3D[{
  Thickness[0.01],
  textarrow[{{0, 0, 0}, {-1/Sqrt[2], 0, 1/Sqrt[2]}}, 
   Style[Rotate["r", \[Pi]/4], 32]],
  Opacity[0.6],
  Yellow,
  Specularity[White, 30],
  Sphere[]
  },
 ViewPoint -> {0, 10, 0}
 ]

enter image description here

However, the gap in the arrow does not scale with the length of the text or its font size.

$\endgroup$

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.