In general how can we create a figure like this?
$\begingroup$
$\endgroup$
2
-
$\begingroup$ It's the example shown here: mathematica.stackexchange.com/a/19343/4999 $\endgroup$– Michael E2May 5, 2017 at 10:18
-
$\begingroup$ Wagon has a detailed discussion of this example in his book. $\endgroup$– J. M.'s lack of A.I. ♦May 11, 2017 at 13:28
Add a comment
|
3 Answers
$\begingroup$
$\endgroup$
2
Unfortunately, I don't know how to completely fix that plotting artifact at "z" axis.
z = (2 x^2 y)/(x^4 + y^2);
Plot3D[z, {x, 0, 1}, {y, 0, 1},
PerformanceGoal -> "Quality",
PlotPoints -> 100,
MaxRecursion -> 4,
Boxed -> False,
AxesLabel -> {"x", "y", "z"},
AspectRatio -> 1,
Ticks -> None,
AxesEdge -> {{-1, -1}, {-1, -1}, {-1, -1}},
AxesStyle -> Thick,
LabelStyle -> 16,
PlotRange -> {{0, 1.2}, {0, 1.2}, {0, 1.2}},
ViewPoint -> 10 {0.5, 1, 0.25},
MeshFunctions -> {Norm[{#1, #2}] &, #3 &},
Epilog -> Inset[Style[HoldForm[z] == z, 16], {Right, Top}, {Right, Top}],
ImageSize -> 400
]
-
$\begingroup$ Can you please explain how " MeshFunctions -> {Norm[{#1, #2}] &, #3 &}" works? What does that mean? $\endgroup$– David RMay 5, 2017 at 19:59
-
$\begingroup$ It means we have two sets of mesh divisions.
Norm[{#1, #2}] &means a line at equal distance from the origin (could be also written asSqrt[#1^2 + #2^2] &) and looking along the "z" axis you can see it creates circles. Other set defined by#3 &means mesh lines at equal "z" coordinate. Numbered slots #1, #2, and #3 correspond to "x", "y" and "z" coordinate (inPlot3D). $\endgroup$– PintiMay 8, 2017 at 7:44
$\begingroup$
$\endgroup$
Update: Better mesh grid
This code, while using the parametrization in my original answer that removes the glitch at the z-axis, better reproduces the mesh in the OP's figure. One problem all the other solutions (so far) suffer from is that the linear elements (mesh lines) and surfaces elements do not interact well in rendering: You can see mesh lines poke through near the singularity. One way to fix this is to use Tube instead of Line. The undocumented use of MeshStyle does this, but the color is White (see this answer).
MeshStyle -> {{Black, Tube[0.002]}, {Black, Tube[0.005]}, {Black, Tube[0.002]}}
However, BoundaryStyle does not work this way, but it's not really a problem. So either leave it as a Line or post-process as shown below.
Below I show the plot over the unit quarter-disk, with the default PlotPoints. Increase it for a slightly smoother mesh. I also solved for the z-values of the mesh in terms of the parameter t. This makes the mesh naturally smoother than the method above (for the same number of plot points).
With[{x = r Cos[t], y = r^2 Sin[t]},
plot = ParametricPlot3D[{x, y, (2 x^2 y)/(x^4 + y^2)},
{r, 0, 1}, {t, 0, Pi/2},
MeshFunctions -> {#5 &, #5 &, Sqrt[#1^2 + #2^2] &},
Mesh -> {
Flatten@Table[t /. NSolve[(2 x^2 y)/(x^4 + y^2) == z/10 && 0 < t < Pi/2, t], {z, 9}],
Flatten[t /. NSolve[(2 x^2 y)/(x^4 + y^2) == 1 && 0 < t < Pi/2, t]],
9},
MeshStyle -> {{Black, Tube[0.002]}, {Black, Tube[0.005]}, {Black, Tube[0.002]}},
Boxed -> False, AxesLabel -> {"x", "y", "z"}, AspectRatio -> 1,
Ticks -> None, AxesEdge -> {{-1, -1}, {-1, -1}, {-1, -1}},
AxesStyle -> Thick, BoundaryStyle -> Thick, LabelStyle -> 16,
PlotRangePadding -> 0.07 {{0, 1}, {0, 1}, {0, 1}}]]
Post-processing can be done with replacement rules like either of these
plot /. {dir___ /; ! FreeQ[{dir}, Thickness[Large]], Line[p_]} :>
{Black, dir, Tube[p, 0.005]},
plot /. {Line[p_] :> {Black, Tube[p, 0.005]}} (* less restrictive *)
Original:
This example has been stuck in my mind since I took multivariable calculus. Ten years later, when I first taught multivariable calculus with Mathematica in 1992, I worked out this parametrization to get around the difficulties of meshing the surface near the singularity at the z-axis. As one can see, the graph approaches the axis:
With[{x = r Cos[t], y = r^2 Sin[t]},
{x, y, (2 x^2 y)/(x^4 + y^2)} // Simplify]
(* {r Cos[t], r^2 Sin[t], (16 Cos[t]^2 Sin[t])/(7 + Cos[4 t])} *)
Here is an updated version taking advantage of the recent ClipPanes. One could also clip via PlotRange. I originally plotted it over {r, 0, 1} without clipping, which plots the surface over the unit disk similar to the above. With this parametrization, the default meshing (PlotPoints/MaxRecursion) is sufficient for a pretty good image, but raising PlotPoints to 25 makes smoother mesh lines.
With[{x = r Cos[t], y = r^2 Sin[t]},
ParametricPlot3D[{x, y, (2 x^2 y)/(x^4 + y^2)},
{r, 0, 1.3}, {t, 0, Pi/2},
PlotPoints -> 25,
MeshFunctions -> {#3 &, Sqrt[#1^2 + #2^2] &},
Boxed -> False, AxesLabel -> {"x", "y", "z"}, AspectRatio -> 1, Ticks -> None,
AxesEdge -> {{-1, -1}, {-1, -1}, {-1, -1}}, AxesStyle -> Thick, LabelStyle -> 16,
ClipPlanes -> {{-1, 0, 0, 1}, {0, -1, 0, 1}},
PlotRange -> {{0, 1}, {0, 1}, {0, 1}},
PlotRangePadding -> 0.07 {{0, 1}, {0, 1}, {0, 1}}]
]
answered May 5, 2017 at 12:58
$\begingroup$
$\endgroup$
This is just an addendum to Pinti's excellent answer to show how some fairly minor modification of his code can make the plot look more like the OP's figure. I have also removed some unnecessary options.
z[x_, y_] := 2 x^2 y/(x^4 + y^2)
Show[
Plot3D[z[x, y], {x, 0, 1}, {y, 0, 1},
PlotPoints -> 100,
MaxRecursion -> 4,
Boxed -> False,
Axes -> False,
BoxRatios -> {1, 1, .8},
LabelStyle -> 16,
PlotRange -> {{0, 1.2}, {0, 1.2}, {0, 1.2}},
ViewPoint -> 10 {0.5, 1, 0.3}, {* tweaked *)
MeshFunctions -> {Norm[{#1, #2}] &, #3 &},
Epilog ->
Inset[Style["z" == z[x, y], 16], {Right, Top}, {Right, Top}],
ImageSize -> 400],
Graphics3D[
{Thick, Arrow[{{0, 0, 0}, {1.2, 0, 0}}],
Arrow[{{0, 0, 0}, {0, 1.2, 0}}],
Arrow[{{0, 0, 0}, {.075, .075, 1.2}}],
MapThread[
Text[Style[#1, "TBI", 16], #2] &,
{{x, y, z}, {{1.23, 0, 0}, {0, 1.23, 0}, {.075, .075, 1.24}}}]}]]
Note: I have slanted the z-axis arrow inward a little to close the the small but annoying gap, because to me, a slightly slanted arrow looks better than an accurate one. A purely esthetic decision on my part.
answered May 5, 2017 at 8:58