4
$\begingroup$

I'm trying to display two highly zoomed-in spheres with the following code:

src = {-49.276947, -7.02026463, 8334.27539};
R = 6371000;
Ha = 50000;
Graphics3D[{Point[src], Opacity[0.1], Green, Sphere[{0, 0, -R}, R], 
  Lighter@Blue, Sphere[{0, 0, -R}, R + Ha]}, 
 PlotRange -> (src + {{-R/10, R/10}, {-R/10, R/10}, {-2 Ha, 2 Ha}})]

output

As you can see in the output, the sphere mesh is quite coarse. How can I make it finer, so that the image I get really looked like containing spheres, not some connected triangles?

$\endgroup$
2
  • $\begingroup$ Try also Method -> {"SpherePoints" -> 85} $\endgroup$
    – b3m2a1
    Aug 8 '18 at 21:06
  • 1
    $\begingroup$ @b3m2a1 You beat me to it. :) $\endgroup$
    – Michael E2
    Aug 8 '18 at 21:08
7
$\begingroup$

There's Method -> {"SpherePoints" -> n}:

src = {-49.276947, -7.02026463, 8334.27539};
R = 6371000;
Ha = 50000;
Graphics3D[{Point[src], Opacity[0.1], Green, Sphere[{0, 0, -R}, R], 
  Lighter@Blue, Sphere[{0, 0, -R}, R + Ha]}, 
 Method -> {"SpherePoints" -> 100}, 
 PlotRange -> (src + {{-R/10, R/10}, {-R/10, R/10}, {-2 Ha, 2 Ha}}), 
 ViewPoint -> Front]

Mathematica graphics

$\endgroup$
2
  • $\begingroup$ Huh, that's neat! I've never got the idea to inspect the Method option of Graphics3D. $\endgroup$ Aug 8 '18 at 21:19
  • 1
    $\begingroup$ @HenrikSchumacher Look around the site. There are other ones, too (cylinder, tube, maybe more). $\endgroup$
    – Michael E2
    Aug 8 '18 at 21:46
5
$\begingroup$

You can obtain a piece of the sphere in customizable discretization with

DiscretizeRegion[
 RegionIntersection[
  Cuboid @@ 
   Transpose[src + {{-R/10, R/10}, {-R/10, R/10}, {-2 Ha, 2 Ha}}],
  Sphere[{0, 0, -R}, R]
  ],
 MaxCellMeasure -> {1 -> R/600}
 ]

You can get the underlying GraphicsComplex with

GraphicsComplex[
 MeshCoordinates[S],
 {EdgeForm[], MeshCells[S, 2, "Multicells" -> True]}
 ]
$\endgroup$
2
  • $\begingroup$ This seems to work, but for some reason appears to not respect the color specifications (Green and Lighter@Blue in the OP). Any remedy for this? $\endgroup$
    – Ruslan
    Aug 8 '18 at 20:43
  • $\begingroup$ Yes; I added a way to get a "undecorated" GraphicsComplex. $\endgroup$ Aug 8 '18 at 21:09
3
$\begingroup$

You can make a smoother sphere with NURBS.

ClearAll@nurbsSphere;
nurbsSphere[c : {_?NumberQ, _, _}, r_: 1] :=
 Module[{
   base = r {
       {{0,0,-1}, {0,0,-1}, {0,0,-1}, {0,0,-1}, {0,0,-1}, {0,0,-1}, {0,0,-1}},
       {{0,-1,-1}, {1,-1,-1}, {1,1,-1}, {0,1,-1}, {-1,1,-1}, {-1,-1,-1}, {0,-1,-1}},
       {{0,-1,1}, {1,-1,1}, {1,1,1}, {0,1,1}, {-1,1,1}, {-1,-1,1}, {0,-1,1}},
       {{0,0,1}, {0,0,1}, {0,0,1}, {0,0,1}, {0,0,1}, {0,0,1}, {0,0,1}}
       } /. p : {_?NumberQ, _, _} :> p + c,
   weights = {1, 0.5, 0.5, 1, 0.5, 0.5, 1},
   knots = {0, 0, 0, 1/4, 1/2, 1/2, 3/4, 1, 1, 1}
   },
  BSplineSurface[base, SplineDegree -> 2, 
   SplineKnots -> {Automatic, knots}, 
   SplineWeights -> {weights, 0.5 weights, 0.5 weights, weights}, 
   SplineClosed -> {False, True}]
  ]

Use it just like a normal Sphere:

Graphics3D@nurbsSphere@{0, 0, 0}

1

Graphics3D[{Point[src], Opacity[0.1], Green, 
  nurbsSphere[{0, 0, -R}, R], Lighter@Blue, 
  nurbsSphere[{0, 0, -R}, R + Ha]}, 
 PlotRange -> (src + {{-R/10, R/10}, {-R/10, R/10}, {-2 Ha, 2 Ha}})]

2

Although you end up right on the balloon knot.

$\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.