Glue a series of images as textures on various points of a sphere

Question

Using the techniques outlined in the answers to this and this questions, it's possible to map images as textures on the surface of a sphere or other object.

These questions, however, consider the case in which one wants to map a single image over the whole surface of a sphere. I am instead trying to plot different images at various points of the sphere.

A first attempt to do this is the following:

testImage[theta_, phi_] := 
  Rasterize[
   Framed@Text[
     "\[Theta]=" <> StringTake[ToString@N@theta, UpTo@3] "\n\[Phi]=" <>
        StringTake[ToString@N@phi, UpTo@3]], RasterSize -> {60, 60}];
Show[
 Graphics3D[{
   Sphere[{0, 0, 0}, 19.9]
   }, Axes -> True],
 Table[
  SphericalPlot3D[
   20, {u, theta - 0.1, theta + 0.1}, {v, phi - 0.1, phi + 0.1}, 
   Mesh -> None,
   TextureCoordinateFunction -> ({#5, 1 - #4} &),
   PlotStyle -> Directive[Texture[testImage[theta, phi]]],
   Lighting -> "Neutral"
   ],
  {theta, Subdivide[0., Pi, 10]},
  {phi, Subdivide[0., 2 Pi, 8]}
  ]
 ]

which produces

This is sort of what I am trying to achieve. However, there is the problem that the spherical coordinates distort the images the more they approach the poles.

I want instead to plot the images without any distortion around any given angle $(\theta,\phi)$. Clearly, if the list of images were the same as in this example we would get overlapping images, but that is not really a concern for my actual use case. I am also not concerned about the orientation of any single image, so one can assume that the images have rotational symmetry around their centres.

How can I do this?

score 2 · Answer 1 · answered May 02 '19 at 21:37

Lazy approach is to create a properly shaped polygon with a texture and then rotate it wherever you want with that or replaced texture:

image = First @ SphericalPlot3D[ 1, {t, Pi/2 - .2, Pi/2 + .2}, {f, -.2, .2}, 
   PlotStyle -> Texture@ExampleData[{"TestImage", "Lena"}], 
   TextureCoordinateFunction -> ({#5, -#4} &), PlotPoints -> 2, Mesh -> None
]

Graphics3D[
 { Sphere[{0, 0, 0}, .99],
   image,
   GeometricTransformation[ image, RotationTransform[{{1, 0, 0}, {1, 1, 1}}]],
   GeometricTransformation[ 
     image /. _Texture -> Texture[ExampleData[{"TestImage", "Airplane"}]],
     RotationTransform[{{1, 0, 0}, {1, -1, 1}}]
   ]
 }
 ]

Glue a series of images as textures on various points of a sphere

1 Answers1