5
$\begingroup$

How to draw a triangulated sphere such as the one below in Mathematica, without being restricted to these colors, but with a more uniform color (possibly with some shaded area), and with the background frame removed?

triangulated sphere

$\endgroup$
  • $\begingroup$ Which version are you in? You can get this type of deal using the region functionality pretty easily. $\endgroup$ – b3m2a1 Mar 31 '17 at 4:27
  • $\begingroup$ Use Geodesate[] from the Polyhedron Operations package (Needs["PolyhedronOperations`"]), or use the region discretization functionality on a Sphere[]. $\endgroup$ – J. M. is away Mar 31 '17 at 4:36
  • $\begingroup$ @J.M. Problem with RegionDiscretize is the coloring. It's a bit of a pain to color each cell, last I remembered. I'm currently trying it with Lighting. $\endgroup$ – b3m2a1 Mar 31 '17 at 4:37
5
$\begingroup$

If you're a) on 10+ and b) don't need this cells to truly be colored, you can try this:

mesh = DiscretizeRegion@Sphere[];

MeshRegion[mesh,
 Lighting -> Sequence @@@ {
    ConstantArray[{"Point", Red, {0, 0, 75}}, 2],
    Map[{"Point", Yellow, Append[#, 0]} &,
     CirclePoints[3., 6]
     ],
    ConstantArray[{"Point", Blue, {0, 0, -75}}, 2]
    },
 MeshCellHighlight -> {{1, All} -> Black}

 ]

withmesh

This is just tricking you into thinking it's colored using Lighting. I was too lazy to highlight each cell. It's possible to write code to color an arbitrary discretized surface at the cell level. I've done it, but it's more code than I want to post here and isn't thoroughly proof-read. If you need that I can dig it up from wherever it's hiding, though.

Update

OP mentions in the comments that he's really interested in the triangulation. That's easily extracted as such:

triangulation =
  With[{cds = MeshCoordinates@mesh},
   MeshCells[mesh, 2] /. i_Integer :> cds[[i]]
   ];

And just to check that we pulled it out right:

triangulation // Graphics3D

triangulation

$\endgroup$
  • $\begingroup$ Thanks, but I hope to have the "triangulated" grid for the math purpose. (Not for the art purpose.) $\endgroup$ – wonderich Mar 31 '17 at 4:44
  • $\begingroup$ @wonderich Then your life is much easier. Use MeshCoordinates. I'll post an addendum. $\endgroup$ – b3m2a1 Mar 31 '17 at 4:45
  • $\begingroup$ @wonderich Added. $\endgroup$ – b3m2a1 Mar 31 '17 at 4:49
  • $\begingroup$ +1 for Lighting.BTY,MeshCellHighlight -> {{1, All} -> Black} is more similar with OP $\endgroup$ – yode Mar 31 '17 at 4:49
  • $\begingroup$ @MB1965 thanks for lesson on Lighting +1 :) $\endgroup$ – ubpdqn Mar 31 '17 at 4:50
7
$\begingroup$

Perhaps,

r = DiscretizeRegion[Sphere[]];
pg = MeshPrimitives[r, 2];
Graphics3D[
 pg /. Polygon[
    u___] :> {ColorData["Rainbow"][
     Rescale[Max[u[[All, 3]]], {-1, 1}]], Polygon[u]}, Axes -> True]

enter image description here:

Exploiting this answer

Manipulate[
 r = BoundaryDiscretizeRegion[Ball[], 
   MaxCellMeasure -> {"Length" -> lg}, PrecisionGoal -> 0.01];
 pg = MeshPrimitives[r, 2];
 Graphics3D[
  pg /. Polygon[
     u___] :> {ColorData["Rainbow"][
      Rescale[Max[u[[All, 3]]], {-1, 1}]], Polygon[u]}, 
  Axes -> True], {lg, {0.1, 0.5, 1, 3}}]

enter image description here

$\endgroup$
  • $\begingroup$ @ubpdqn Ahh. Of course. Going straight to the Graphics3D is much better. $\endgroup$ – b3m2a1 Mar 31 '17 at 4:51
4
$\begingroup$

Method One

mesh = DiscretizeRegion@Sphere[];
Graphics3D[Transpose[{ColorData["Rainbow"] /@ 
    Rescale[Last /@ PropertyValue[{mesh, 2}, MeshCellCentroid]], 
   MeshPrimitives[mesh, 2]}]]

Method two(Based on this comment)

mesh = DiscretizeRegion[Sphere[]];
SliceDensityPlot3D[z, mesh, {x, -1, 1}, {y, -1, 1}, {z, -1, 1}, 
  ColorFunction -> "Rainbow"] /. _EdgeForm -> EdgeForm[Black]

MB1965 tweaks to Method two:

mesh = DiscretizeRegion[Sphere[],
   MaxCellMeasure -> {"Length" -> .35},
   PrecisionGoal -> .01];
SliceDensityPlot3D[z,
  mesh, {x, -1, 1}, {y, -1, 1}, {z, -1, 1},
  ColorFunction -> "Rainbow",
  FaceGrids ->
   -IdentityMatrix[3],
  AxesEdge -> {
    {-1, 1},
    {1, -1},
    {1, -1}
    },
  Boxed -> False
  ] /. _EdgeForm -> EdgeForm[Black]

enter image description here

$\endgroup$
  • $\begingroup$ @MB1965 Perfect.Sorry cannot upvote. :) $\endgroup$ – yode Mar 31 '17 at 7:32
  • $\begingroup$ I just realized we have three different ways Mathematica can do coloring on this page. This way here clearly uses layered textures, because there are gradients in the cells. The Lighting way does colors in the rendering system. And the way @ubpqdn did it colors individual faces. Pretty cool for such a simple question. $\endgroup$ – b3m2a1 Mar 31 '17 at 7:35

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.