Placing a ContourPlot under a Plot3D

Question

I would like to combine a 3-dimensional graph of a function with its 2-dimensional contour-plot underneath it in a professional way. But I have no idea how to start.

I have a three of these I would like to make, so I don't need a fully automated function that does this. A giant block of code would be just fine.

The two plots I would like to have combined are:

potential1 = 
  Plot3D[-3600. h^2 + 0.02974 h^4 - 5391.90 s^2 + 0.275 h^2 s^2 + 0.125 s^4, 
    {h, -400, 400}, {s, -300, 300}, PlotRange -> {-1.4*10^8, 2*10^7}, 
    ClippingStyle -> None, MeshFunctions -> {#3 &}, Mesh -> 10,
    MeshStyle -> {AbsoluteThickness[1], Blue}, Lighting -> "Neutral",
    MeshShading -> {{Opacity[.4], Blue}, {Opacity[.2], Blue}}, Boxed -> False,
    Axes -> False]

and

contourPotentialPlot1 = 
  ContourPlot[-3600. h^2 + 0.02974 h^4 - 5391.90 s^2 + 0.275 h^2 s^2 + 0.125 s^4, 
   {h, -400, 400}, {s, -300, 300}, PlotRange -> {-1.4*10^8, 2*10^7},
   Contours -> 10, ContourStyle -> {{AbsoluteThickness[1], Blue}}, Axes -> False, 
   PlotPoints -> 30]

These two plots look like:

I would also love it if I could get 'grids' on the sides of the box like in http://en.wikipedia.org/wiki/File:GammaAbsSmallPlot.png

---

Update The new plotting routine SliceContourPlot3D was introduced in version 10.2. If this function can be used to achieve the task above, how can it be done?

Answer 1

Strategy is simple texture map 2D plot on a rectangle under your 3D surface. I took a liberty with some styling that I like - you can always come back to yours.

contourPotentialPlot1 = ContourPlot[-3600. h^2 + 0.02974 h^4 - 5391.90 s^2 + 
   0.275 h^2 s^2 + 0.125 s^4, {h, -400, 400}, {s, -300, 300}, 
 PlotRange -> {-1.4*10^8, 2*10^7}, Contours -> 15, Axes -> False, 
 PlotPoints -> 30, PlotRangePadding -> 0, Frame -> False, ColorFunction -> "DarkRainbow"];

potential1 = Plot3D[-3600. h^2 + 0.02974 h^4 - 5391.90 s^2 + 0.275 h^2 s^2 + 
    0.125 s^4, {h, -400, 400}, {s, -300, 300}, 
   PlotRange -> {-1.4*10^8, 2*10^7}, ClippingStyle -> None, 
   MeshFunctions -> {#3 &}, Mesh -> 15, MeshStyle -> Opacity[.5], 
   MeshShading -> {{Opacity[.3], Blue}, {Opacity[.8], Orange}}, Lighting -> "Neutral"];

level = -1.2 10^8; gr = Graphics3D[{Texture[contourPotentialPlot1], EdgeForm[], 
Polygon[{{-400, -300, level}, {400, -300, level}, {400, 300, level}, {-400, 300, level}}, 
VertexTextureCoordinates -> {{0, 0}, {1, 0}, {1, 1}, {0, 1}}]}, Lighting -> "Neutral"];

Show[potential1, gr, PlotRange -> All, BoxRatios -> {1, 1, .6}, FaceGrids -> {Back, Left}]

You can see I used PlotRangePadding -> 0 option in ContourPlot. It is to remove white space around the graphics to make texture mapping more precise. If you need utmost precision you can take another path. Extract graphics primitives from ContourPlot and make them 3D graphics primitives. If you need to color the bare contours - you could replace Line by Polygon and do some tricks with FaceForm based on a contour location.

level = -1.2 10^8;
pts = Append[#, level] & /@ contourPotentialPlot1[[1, 1]];
cts = Cases[contourPotentialPlot1, Line[l_], Infinity];
cts3D = Graphics3D[GraphicsComplex[pts, {Opacity[.5], cts}]];

Show[potential1, cts3D, PlotRange -> All, BoxRatios -> {1, 1, .6}, 
 FaceGrids -> {Bottom, Back, Left}]

Answer 2

A simpler version but not as nice as Vitally's is this:

potential1 /. 
 Graphics3D[gr_, opts___] :> 
  Graphics3D[{gr, Scale[gr, {1, 1, 1/100}, {0, 0, -2 10^8}]}, 
   PlotRange -> All, opts]

This can also be "projected" onto the other sides.

potential1 /. 
 Graphics3D[gr_, opts___] :> 
  Graphics3D[{gr, Scale[gr, {1, 1, 1/100}, {0, 0, -2 10^8}], 
    Scale[gr, {1/100, 1, 1}, {-400, 0, 0}]}, PlotRange -> All, opts]

Answer 3

Here's one using SliceContourPlot3D (introduced in 10.2) and Vitaliy's stylings.

f = -3600. h^2 + 0.02974 h^4 - 5391.90 s^2 + 0.275 h^2 s^2 + 0.125 s^4;

min = -1.4*10^8;
max = 2*10^7;

potential1 = Plot3D[f, {h, -400, 400}, {s, -300, 300}, 
  PlotRange -> {min, max}, ClippingStyle -> None, MeshFunctions -> {#3 &}, 
  Mesh -> 15, MeshStyle -> Opacity[.5], 
  MeshShading -> {{Opacity[.3], Blue}, {Opacity[.8], Orange}}, 
  Lighting -> "Neutral"
]

slice = SliceContourPlot3D[f, z == min, 
  {h, -400, 400}, {s, -300, 300}, {z, min - 1, min + 1}, 
  PlotRange -> {min, max}, Contours -> 15, Axes -> False, 
  PlotPoints -> 50, PlotRangePadding -> 0, ColorFunction -> "DarkRainbow"
]

Show[potential1, slice, PlotRange -> All, BoxRatios -> {1, 1, .6}, FaceGrids -> {Back, Left}]

Answer 4

So late to the party but here is my take:

f[h_, s_] := -3600. h^2 + 0.02974 h^4 - 5391.90 s^2 + 0.275 h^2 s^2 + 0.125 s^4; 
min = -1.4*10^8; max = 2*10^7;

contour = 
 ContourPlot[f[x, y], {x, -400, 400}, {y, -300, 300}, 
  PlotRange -> {min, max}, Axes -> False, Contours -> 15, 
  PlotPoints -> 50, PlotRangePadding -> 0, 
  ColorFunction -> "DarkRainbow"]

potential1 = 
 Plot3D[f[h, s], {h, -400, 400}, {s, -300, 300}, 
  PlotRange -> {min, max}, ClippingStyle -> None, 
  MeshFunctions -> {#3 &}, Mesh -> 15, MeshStyle -> Opacity[.5], 
  MeshShading -> {{Opacity[.3], Blue}, {Opacity[.8], Orange}}, 
  PlotRange -> {Automatic, Automatic, {min, 2}}, 
  Lighting -> "Neutral"]

Finally, both combined:

Show[potential1, 
Graphics3D[contour[[1]] /. {x_Real, y_Real} :> {x, y, min}], 
 BoxRatios -> {1, 1, 0.6}, FaceGrids -> {Back, Left}]