# Smooth 4D (3D + color) plot from discrete points

I have a file containing isosurface $\{x,y,z,F\}$ data (around 9000 points). My goal is to generate a smooth (NOT a discrete set of points!) colored surface using ListContourPlot3D, i.e., something like this:

More specifically, the surface I am trying to plot is closed.

This what I am getting if I plot x,y,z:

Now, I want to add color on top, i.e., I want different regions of the surface to be colored differently depending F.

I am using ListContourPlot3D, because according to the description this what I need:

ListContourPlot3D linearly interpolates values to give smooth contours

Any hints? So far all my attempts have been unsuccessful.

This is what I am getting with ListContourPlot3D[data]:

EDIT: attached the file.

file

I want to plot col. 1(x): col.2(y): col.3(z) col4(color)

• ListContourPlot3D and ListDensityPlot? – Apple Jun 10 '14 at 15:30
• You should post a minimum (non)working example describing the problems you are having. It is not a good practice to post links to files located in Nowhere, Kansas. Plus, there are tons of Qs on how to plot 4D data in Mathematica. Also look up ListInterpolation – Sektor Jun 10 '14 at 15:41
• Looks like you need ListPlot3D, not ListContourPlot3D. The one you show is not a contour plot or an isosurface plot. If you upload your data somewhere, someone will surely show you how to do it (including the colouring). – Szabolcs Jun 10 '14 at 18:12
• The file is uploaded (at the bottom) – molkee Jun 10 '14 at 18:16
• It would be good to change the title of this to asking about your actual problem instead of complaining that a a function not meant for the purpose you're trying to use it for "does NOT work". – Szabolcs Jun 10 '14 at 18:51

ListContourPlot3D does work as intended. Please check its documentation on what it is supposed to do. To make this kind of plot you need ListSurfacePlot3D.

data = Import["~/Downloads/furan-ks.sdat", "Table"];

nf = Nearest[data[[All, {1, 2, 3}]] -> Rescale[data[[All, 4]]]]

colfun = ColorData["Rainbow"]@First@nf[{#1,#2,#3}]&

ListSurfacePlot3D[
data[[All, {1, 2, 3}]],
BoxRatios -> Automatic,
ColorFunction -> colfun,
ColorFunctionScaling -> False
]


You can experiment with the MaxPlotPoints option (e.g. set it to 20) to get the optimal surface fitting to your points. A too tight fit will be noisy, a too loose one will look chunky.

The tricky bit here was converting the colour data into a format usable with ListSurfacePlot3D. This is a non-trivial step. I used Nearest to create a function (named nf) that takes a 3D coordinate and returns the colour value of the closest point from the dataset. Then I converted this value to an actual colour (i.e. an RGBColor object) using the function colfun.

• I think you missed the bit where you get from nf to colfun – Simon Woods Jun 10 '14 at 18:56
• @Simon Thanks, fixed! – Szabolcs Jun 10 '14 at 18:59
• @Szabolcs - what does colfun actually color? Height? A kind of curvature ? Density of sampling points ? – eldo Jun 10 '14 at 19:24
• @eldo The original dataset has 4 relevant columns. The first 3 are x,y,z coordinates of a point and the 4th is a number that we use for colouring this point. Because of how Mathematica's ColorFunctions work, the colour function needs to be able to assign a colour to any point in 3D, not just the points in the dataset. The function nf takes any 3D point, and finds the point in the dataset that is closest to it. Then it returns the number (4th column) corresponding to this point. What colfun does is just convert this number to an RGBColor object, nothing more. – Szabolcs Jun 10 '14 at 19:58
• @eldo So the value used for colouring comes from the dataset directly. – Szabolcs Jun 10 '14 at 19:58

Using @Szabolcs's colfun with ListContourPlot3D and ListSurfacePlot3D give similar images:

opts = {BoxRatios -> Automatic, ColorFunction -> colfun,
Lighting -> "Neutral", ColorFunctionScaling -> False,   ImageSize -> 400};

Row[{ListContourPlot3D[data[[All, {1, 2, 3}]], opts, Contours -> {0}],
ListSurfacePlot3D[data[[All, {1, 2, 3}]], opts]}]


• how do I add a colorbar for a plot generated with any of these methods? Setting PlotLegends to Automatic does not help – molkee Jun 11 '14 at 19:01
• @molkee, does PlotLegends -> BarLegend[{"Rainbow", {0, 1}}] give what you expect? – kglr Jun 11 '14 at 21:06
• yes, it does. thanks! – molkee Jun 11 '14 at 21:09

ListContourPlot3D has a VERY nasty default option; it joins the points creating a surface, not discrete 3D points and this feature cannot be removed. In order to deal with this we have to come up with a radical solution like the following:

First of all, let's read the data file

data = ReadList["data.out", Number, RecordLists -> True];


I suppose that the fourth column corresponds to the value of an index so, let's find out the minimum and the maximum values of that index in our sample data file

datat = Table[data[[i, 4]], {i, 1, Length[data]}];
min = Min[datat];
max = Max[datat];
Print["min = ", min]
Print["max = ", max]


Now let's paint the 3D points with colors according to the values of the index

valrange = {min, max};
data[[All, 4]] = Rescale[data[[All, 4]], valrange];
colfunc[x_, cf_] := ColorData[cf][1 - x[[4]]];


and then plot them

S0 = Graphics3D[{PointSize[0.004], Point[#[[1 ;; 3]], VertexColors -> colfunc[#, "Rainbow"]] & /@ data}]


If we like we can also create a custom-made colorbar

Clear[colorbar]
colorbar[{min_, max_}, colorFunction_: Automatic, divs_: 150] :=
DensityPlot[y, {x, 0, 0.1}, {y, min, max}, AspectRatio -> 10,
PlotRangePadding -> 0, PlotPoints -> {2, divs}, MaxRecursion -> 0,
Frame -> True, FrameLabel -> {{None, "index"}, {None, None}},
LabelStyle -> Directive[FontFamily -> "Helvetica", 17],
FrameTicks -> {{None, All}, {None, None}},
FrameTicksStyle -> Directive[FontFamily -> "Helvetica", 15, Plain],
ColorFunction -> colorFunction]


and combine the colorbar with the previous 3D plot

With[{opts = {ImageSize -> {Automatic, 600}}, cf = "Rainbow"},
Row[{Show[{S0}, Axes -> True,
AxesStyle -> Directive[FontSize -> 18, FontFamily -> "Helvetica"],
AxesLabel -> {"x", "y", "z"}, BoxRatios -> {1, 1, 1}, opts],
Show[colorbar[valrange, ColorData[cf][1 - #] &],
ImagePadding -> {{20, 60}, {55, 25}}, opts]}]]


• Thanks for the help. But how do I turn the last graph into smooth UNIFORM (no discrete 3D points) colored surface? Is it possible? – molkee Jun 10 '14 at 18:43
• @molkee I can't think of anything right now. My approach works very good when you want to visualize 3D points with colors. Now join them (why you want to do that?!) is another story. My opinion is that if there is a way to join them creating a colored surface the output will not be as smooth and uniform you expect; you should expect a lot of rough edges. – Vaggelis_Z Jun 10 '14 at 18:49
• Thanks for the help anyways. I appreciate it. I guess simple increase in the point mark size will do the job. you are right, the surface wouldn't be perfect, but there must be some tricks of how to smoothen it using interpolation. A number of points is enough to get a nice surface – molkee Jun 10 '14 at 18:52
• @molkee If you really think my answer was useful to you, don't forget to vote it! – Vaggelis_Z Jun 10 '14 at 20:59
• It was! by the way, is there a simpler way of how add a color bar to a 3D plot (say, ListContourPlot3D or ListSurfacePlot)? This cannot be done using PlotLegends – molkee Jun 11 '14 at 20:56