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?
$\begingroup$
$\endgroup$
3
3 Answers
$\begingroup$
$\endgroup$
16
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}
]
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
-
$\begingroup$ Thanks, but I hope to have the "triangulated" grid for the math purpose. (Not for the art purpose.) $\endgroup$ Commented Mar 31, 2017 at 4:44
-
$\begingroup$ @wonderich Then your life is much easier. Use
MeshCoordinates. I'll post an addendum. $\endgroup$– b3m2a1Commented Mar 31, 2017 at 4:45 -
-
$\begingroup$ +1 for
Lighting.BTY,MeshCellHighlight -> {{1, All} -> Black}is more similar with OP $\endgroup$– yodeCommented Mar 31, 2017 at 4:49 -
$\begingroup$ @MB1965 thanks for lesson on
Lighting+1 :) $\endgroup$– ubpdqnCommented Mar 31, 2017 at 4:50
$\begingroup$
$\endgroup$
1
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]
:
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}}]
-
$\begingroup$ @ubpdqn Ahh. Of course. Going straight to the
Graphics3Dis much better. $\endgroup$– b3m2a1Commented Mar 31, 2017 at 4:51
$\begingroup$
$\endgroup$
2
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]
-
$\begingroup$ @MB1965 Perfect.Sorry cannot upvote. :) $\endgroup$– yodeCommented Mar 31, 2017 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
Lightingway does colors in the rendering system. And the way @ubpqdn did it colors individual faces. Pretty cool for such a simple question. $\endgroup$– b3m2a1Commented Mar 31, 2017 at 7:35
Geodesate[]from the Polyhedron Operations package (Needs["PolyhedronOperations`"]), or use the region discretization functionality on aSphere[]. $\endgroup$RegionDiscretizeis the coloring. It's a bit of a pain to color each cell, last I remembered. I'm currently trying it withLighting. $\endgroup$