5
$\begingroup$

I want to generate a smooth coloured surface from a discrete set of points of the form {x,y,z,F} using the ListSurfacePlot3D. My data set is quite non uniform; the density of points varies across the surface. This creates wiggles, bumps and holes in the resulting surface.

Below is my code.

data set

bulk = Import[
"/path/to/file", "Table"];
xyz = bulk[[All, {1, 2, 3}]];
ALEE = Nearest[bulk[[All, {1, 2, 3}]] -> Rescale[bulk[[All, 4]]]];
cfALEE = ColorData["Rainbow"]@First@ALEE[{#1, #2, #3}] &;

plot = ListSurfacePlot3D[bulk[[All, {1, 2, 3}]], 
BoxRatios -> Automatic, 
ColorFunction -> cfALEE, 
ColorFunctionScaling -> False, 
Boxed -> False, 
Axes -> False, 
Mesh -> None, 
MaxPlotPoints -> 35, 
ImageSize -> 500];
Show[plot]

This produces the following output:

surface

What I have tried so far:

  1. playing with InterpolationOrder in ListPlot3D. Even worse results.

  2. BSplineSurface. This function requires a control mesh (a matrix of points) on input, and I have no idea how to make it.

In my understanding, I need to come with some sort of interpolation function that smoothens the surface. Any ideas on how I can create a nice smooth dogbone-shaped surface? Any input would be appreciated.

$\endgroup$
  • $\begingroup$ Perhaps you could convert the data into spherical coordinates, perform interpolation of $r$ as a function of $(\theta, \phi)$, and use SphericalPlot3D. (Or analogously: cylindrical coordinates, $r$ from $(z,\theta)$, RevolutionPlot3D.) $\endgroup$ – Rahul Mar 17 '16 at 21:41
8
$\begingroup$

In the following code you may want to experiment with alternatives to MovingAverage (like GaussianFilter, MovingMedian, etc) to get the smoothness degree that fits you:

bulk    = Import["c:\\test.txt", "Table"];
b       = bulk[[All, 1 ;; 3]];
bc      = Quiet@CoordinateTransform[{"Cartesian" -> "Cylindrical", 3}, b];
bc1     = Select[bc, FreeQ[#, Indeterminate] &];

cusps   = Select[bc, ! FreeQ[#, Indeterminate] &][[{1, 3}, {1, 3}]]; 
pts0    = Sort[Reverse /@ Join[cusps, bc1[[All, {1, 3}]]]];
pts     = Transpose[MovingAverage[#, 30] & /@ Transpose@pts0];
pts1    = DeleteDuplicates[Sort@Join[pts, Reverse /@ cusps], #1[[1]] == #2[[1]] &];
f       = Interpolation[pts1];

Show[RevolutionPlot3D[{f[t] Cos@u, f[t] Sin@u, t}, {t, 
                     Min[pts1[[All, 1]]], Max[pts1[[All, 1]]]}, {u, 0, 2 Pi}, 
                     PlotStyle -> {Orange, Specularity[White, 10]}, Mesh -> None], 
     ListPointPlot3D@b]

Mathematica graphics

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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