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

Question

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.

Answer 1

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]