# interpolating a smooth closed surface to a non-uniform data set (ListSurfacePlot3D)

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: 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.

• 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.) – user484 Mar 17 '16 at 21:41

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[] == #2[] &];
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] 