Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

As the title indicates, I want to delete some unwanted regions in a three-dimensional surface created using ContourPlot3D. Here is the corresponding code

Clear["Global`*"];

V = 1/2*(x^2 + y^2 + z^2) + (x^2*y^2 + x^2*z^2 + y^2*z^2 - x^2*y^2*z^2);

E0 = 7;

S0 = ContourPlot3D[V == E0, {x, -4, 4}, {y, -4, 4}, {z, -4, 4}, 
PlotPoints -> 70, PerformanceGoal -> "Speed", Mesh -> None, 
ContourStyle -> Directive[Green, Opacity[0.3], Specularity[White, 30]], 
ImageSize -> 550]

which produces this output:

enter image description here

I want somehow to keep the inside closed 3D surface (which looks like a 3D star) and delete the eight open parts which surround it. I tried several combinations using RegionPlot3D but the particular range of $x$, $y$ and $z$ prevent me from obtaining what I want. Any suggestions?

EDIT

If you increase the value of E0 then after a certain value the three-dimensional surface opens and eight channels of escapes (holes) appear. Using this code

Clear["Global`*"];

V = 1/2*(x^2 + y^2 + z^2) + (x^2*y^2 + x^2*z^2 + y^2*z^2 - x^2*y^2*z^2);

E0 = 8.5;
R0 = 6;

S0 = ContourPlot3D[V == E0, {x, -5, 5}, {y, -5, 5}, {z, -5, 5}, 
PlotPoints -> 100, PerformanceGoal -> "Speed", Mesh -> None, 
ContourStyle -> Directive[Green, Opacity[0.3], Specularity[White, 30]], 
ImageSize -> 550, RegionFunction -> Function[{x, y, z}, Sqrt@(x^2*y^2 + 
x^2*z^2 + y^2*z^2) <= R0]]

you get this output

enter image description here

OK, my question is the following: How can I draw the surface and manipulate the openings at the minimum width. Let me be more specific. Now, using the current code the size of the openings is controlled by the cutoff surface and the particular value of $R0$. If for example, I use $R0 = 2.5$ then I loose essential parts of the surface.

enter image description here

What I want is to define such a cutoff surface or find the specific value of $R0$ so that the external cutoff surface to abut exactly against the inner surface thus, drawing the openings at their minimum width.

Any suggestions?

share|improve this question

3 Answers 3

up vote 14 down vote accepted

Βαγγέλη, you can use an appropriate RegionFunction:

V = 1/2*(x^2 + y^2 + z^2) + (x^2*y^2 + x^2*z^2 + y^2*z^2 - 
     x^2*y^2*z^2);

E0 = 7;

S0 = ContourPlot3D[V == E0, {x, -4, 4}, {y, -4, 4}, {z, -4, 4}, 
  PlotPoints -> 70, PerformanceGoal -> "Speed", Mesh -> None, 
  ContourStyle -> 
   Directive[Green, Opacity[0.3], Specularity[White, 30]], 
  ImageSize -> 550, 
  RegionFunction -> 
   Function[{x, y, z}, 3 - Sqrt[x^2*y^2 + y^2 z^2] > 0]]

Mathematica graphics

---EDIT---

RegionFunction works like a cutoff. You need to find the equation of a curve that splits your wanted from your unwanted parts. Here

cutoff = 
 ContourPlot3D[
  Sqrt[x^2*y^2 + y^2 z^2] == 3, {x, -4, 4}, {y, -4, 4}, {z, -4, 4}];
Show[S0, cutoff]

Mathematica graphics

But how you'd guess it is a different issue. Normally manipulate your original surface. I.e. note that

cutoff2 = 
  ContourPlot3D[
   Sqrt@(x^2*y^2 + x^2*z^2 + y^2*z^2) == 4, {x, -4, 4}, {y, -4, 
    4}, {z, -4, 4}, ContourStyle -> Opacity[0.4], Mesh -> None];
Show[S0, cutoff2]

Mathematica graphics

also works (in fact is a more obvious choice).

---2nd EDIT---

If you want to qualitatively see whether the containment of the surface is satisfactory, leave your R0 variable and wrap a low-res version within a manipulate to see which value you like.

Manipulate[
 TableForm@{ContourPlot3D[
    V == E0, {x, -5, 5}, {y, -5, 5}, {z, -5, 5},
    PerformanceGoal -> "Speed",
    Mesh -> None,
    PlotPoints -> 40, 
    ContourStyle -> 
     Directive[Green, Opacity[0.3], Specularity[White, 30]], 
    ImageSize -> 550, 
    RegionFunction -> 
     Function[{x, y, z}, Sqrt@(x^2*y^2 + x^2*z^2 + y^2*z^2) <= R0]], 
   R0}, {R0, 2, 6, 0.1}]

Mathematica graphics

If you want to find the actual minimum, you'd have to find an expression for the intersection of the two surfaces, parametrise it, and minimize its length.

share|improve this answer
    
Great! Could you explain a little bit how this particular RegionFunction come from? I mean which theory is behind it. –  Vaggelis_Z Mar 27 '13 at 8:45
    
When $V$ has another mathematical expression then the appropriate RegionFunction changes. However, I cannot understand how the function $3 - \sqrt{x^2 y^2 + y^2 z^2} > 0$ come from. It is essential to me to know how to obtain this function every time. So, please enlighten me a little bit! –  Vaggelis_Z Mar 27 '13 at 9:05
    
@Vaggelis_Z If you have a surface like yours that is a generalised "sphere" in that you can permute any two cartesian coordinates and get the same expression, you need to define your cutoff as something with larger radius or slightly deformed. Does that help? –  gpap Mar 27 '13 at 9:34
    
Yes indeed, now everything is very clear. Thank you very much! –  Vaggelis_Z Mar 27 '13 at 9:38
    
Any ideas about my EDIT? Many thanks in advance! –  Vaggelis_Z Mar 28 '13 at 10:34

By looking at the hyperbolic behavior of the branches, you may try a simple RegionFunction[]:

ContourPlot3D[V == E0, {x, -4, 4}, {y, -4, 4}, {z, -4, 4}, 
  PlotPoints -> 70, PerformanceGoal -> "Speed", Mesh -> None, 
  ContourStyle -> Directive[Green, Opacity[0.3], Specularity[White, 30]], ImageSize -> 550, 
  RegionFunction -> (Abs[#1 #2 #3] < 3 &)]

Mathematica graphics

Edit

Just checking the whole solid is included

Show[ContourPlot3D[V == E0, {x, -4, 4}, {y, -4, 4}, {z, -4, 4}, 
  PlotPoints -> 70, PerformanceGoal -> "Speed", Mesh -> None, 
  ContourStyle -> Directive[Green, Opacity[0.3], Specularity[White, 30]], 
  ImageSize -> 550, RegionFunction -> (Abs[Times[#1 #2 #3]] < 3 &)], 
 ParametricPlot3D[{x, y, Abs[3/(x y)]}, {x, 0, 4}, {y, -4, 4}, 
  PlotPoints -> 70, PerformanceGoal -> "Speed", Mesh -> None, 
  PlotRange -> {-5, 5}]]

Mathematica graphics

share|improve this answer

For giggles, here's a variation of belisarius's answer:

ContourPlot3D[V == E0, {x, -4, 4}, {y, -4, 4}, {z, -4, 4}, 
              ContourStyle -> Directive[Opacity[0.3, Green], Specularity[1, 30]], 
              Mesh -> None, PerformanceGoal -> "Speed", PlotPoints -> 70, 
              RegionFunction -> Function[{x, y, z}, Evaluate[
   PolyhedronData["Octahedron", "RegionFunction"][Sqrt[2] x/9, Sqrt[2] y/9, Sqrt[2] z/9]]]]
share|improve this answer

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.