1
$\begingroup$

This question follows my initial question that can be found here.

I created the following 4D plot (3 spacial coordinate + color) by interpolating points separately.

enter image description here

The full data (1.4Mb) can be imported via https://gist.githubusercontent.com/anonymous/327fed478fcf166c4403/raw/9f116770cf995f2232660061c202db7602b1836a/data.txt

The plot actually consists in the merge of 8 subplots, merged together with Show.

I still have a global color issue. Indeed the center part should actually be almost blue (low value) and the corner yellow (high value). Focusing on the lower half of the center part:

nf = Nearest[coo4[[All, {1, 2, 3}]] -> Rescale[coo4[[All, 4]]]];
colfun = ColorData[{"TemperatureMap", {minvalue, maxvalue}}]@
    First@nf[{#1, #2, #3}] &;
p2 = ListPlot3D[coo4[[All, 1 ;; 3]], 
  RegionFunction -> Function[{x, y, z}, RegionMember[reg, {x, y}]], 
  ColorFunction -> colfun, ColorFunctionScaling -> False, 
  MaxPlotPoints -> 100, BoxRatios -> Automatic, Mesh -> 10, 
  PlotLegends -> 
   BarLegend[{"TemperatureMap", {minvalue, maxvalue}}, 
    ColorFunctionScaling -> True]]

For that section of the plot below, the value should be around 8. I have specify that the range for the ColorData should be between minval (here equal 1 to maxval, here equal 9).

enter image description here

It seems it takes the minvalue. If I remove {minval,maxval}

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

It gives me

enter image description here

which is not good because its scaled and therefore the different plot do not add up correctly with correct color for the final plot.

Any idea?

Edit

The code used to split the data and produce the full picture is the following. I was not so keen as to share it as I'm sure its very ugly, inefficient and long. Bear in mind that I started using Mathematica 3 days ago... I'm very happy to improve though.

coo1 = data.txt
maxvalue = Max[coo1[[All, 4]]]*1000;
minvalue  = Min[coo1[[All, 4]]]*1000;
coo2 = {coo1[[1, 1 ;; 4]]};
Do[If[ coo1[[i, 4]] > 0.0 && coo1[[i, 4]] < 0.00165 , {
    AppendTo[coo2, coo1[[i, 1 ;; 4]]]
    },], {i, 1, Length[coo1[[All, 1]]]}];
coo2 = Delete[coo2, 1];
coo21 = Select[coo2, #[[3]] < Max[coo1[[All, 3]]]/2 &];
coo22 = Select[coo2, #[[3]] > Max[coo1[[All, 3]]]/2 &];
coo3 = {coo1[[1, 1 ;; 4]]};
Do[If[ coo1[[i, 4]] > 0.00175 && coo1[[i, 4]] < 0.005, {
    AppendTo[coo3, coo1[[i, 1 ;; 4]]]
    },], {i, 1, Length[coo1[[All, 1]]]}];
coo3 = Delete[coo3, 1];
coo4 = Select[coo3, #[[3]] < Max[coo1[[All, 3]]]/2 + 0.03 &];
coo5 = Select[coo3, #[[3]] >= Max[coo1[[All, 3]]]/2 - 0.05 &];
coo6 =  Select[coo1, #[[4]] > 0.0082 & ];
coo7 = Select[coo6, #[[4]] < 0.0085 & ];
coo8 = Select[coo7, #[[1]]  < 0.25  &];
coo9 = Select[coo8, #[[2]]  < 0.25  &];
coo10 = Select[coo7, #[[1]]  < 0.25  &];
coo11 = Select[coo10, #[[2]]  > 0.25  &];
coo12 = Select[coo7, #[[1]]  > 0.5 &];
coo13 = Select[coo12, #[[2]]  < 1.0  &];
coo14 = Select[coo7, #[[1]]  > 0.5 &];
coo15 = Select[coo14, #[[2]]  > 1.0  &];

alphaShapes2D[points_, crit_] := 
  Module[{alphacriteria, del = Quiet@DelaunayMesh@points, tetras, 
    tetcoords, tetradii, selectExternalFaces}, 
   alphacriteria[tetrahedra_, radii_, rmax_] := 
    Pick[tetrahedra, UnitStep@Subtract[rmax, radii], 1];
   selectExternalFaces[facets_] := MeshRegion[points, facets];
   If[Head[del] === EmptyRegion, del, tetras = MeshCells[del, 2];
    tetcoords = MeshPrimitives[del, 2][[All, 1]];
    tetradii = Quiet@Thread[Circumsphere[tetcoords]][[All, 2]];
    selectExternalFaces@alphacriteria[tetras, tetradii, crit]]];

reg = alphaShapes2D[DeleteDuplicates@coo21[[All, ;; 2]], .2]
nf = Nearest[coo21[[All, {1, 2, 3}]] -> Rescale[coo21[[All, 4]]]];
colfun = ColorData[{"TemperatureMap"]@
    First@nf[{#1, #2, #3}] &;
p1 = ListPlot3D[coo21[[All, 1 ;; 3]], 
  RegionFunction -> Function[{x, y, z}, RegionMember[reg, {x, y}]], 
  ColorFunction -> colfun, ColorFunctionScaling -> False, 
  MaxPlotPoints -> 100, BoxRatios -> Automatic, Mesh -> 10]
reg = alphaShapes2D[DeleteDuplicates@coo22[[All, ;; 2]], .2]
nf = Nearest[coo22[[All, {1, 2, 3}]] -> Rescale[coo22[[All, 4]]]];
colfun = ColorData["TemperatureMap"]@First@nf[{#1, #2, #3}] &;
p11 = ListPlot3D[coo22[[All, 1 ;; 3]], 
  RegionFunction -> Function[{x, y, z}, RegionMember[reg, {x, y}]], 
  ColorFunction -> colfun, ColorFunctionScaling -> False, 
  MaxPlotPoints -> 100, BoxRatios -> Automatic, Mesh -> 10]
reg = alphaShapes2D[DeleteDuplicates@coo4[[All, ;; 2]], .2]
nf = Nearest[coo4[[All, {1, 2, 3}]] -> Rescale[coo4[[All, 4]]]];
colfun = ColorData["TemperatureMap"]@First@nf[{#1, #2, #3}] &;
p2 = ListPlot3D[coo4[[All, 1 ;; 3]], 
  RegionFunction -> Function[{x, y, z}, RegionMember[reg, {x, y}]], 
  ColorFunction -> colfun, ColorFunctionScaling -> False, 
  MaxPlotPoints -> 100, BoxRatios -> Automatic, Mesh -> 10, 
    ColorFunctionScaling -> True]]
reg = alphaShapes2D[DeleteDuplicates@coo5[[All, ;; 2]], .15]
nf = Nearest[coo5[[All, {1, 2, 3}]] -> Rescale[coo5[[All, 4]]]];
colfun = ColorData["TemperatureMap"]@First@nf[{#1, #2, #3}] &;
p3 = ListPlot3D[coo5[[All, 1 ;; 3]], 
  RegionFunction -> Function[{x, y, z}, RegionMember[reg, {x, y}]], 
  ColorFunction -> colfun, ColorFunctionScaling -> False, 
  MaxPlotPoints -> 100, BoxRatios -> Automatic, Mesh -> 10]

nf = Nearest[coo7[[All, {1, 2, 3}]] -> Rescale[coo7[[All, 4]]]];
colfun = ColorData["TemperatureMap"]@
    First@nf[{#1, #2, #3}] &;
p4 = ListSurfacePlot3D[coo9[[All, 1 ;; 3]], ColorFunction -> colfun, 
   ColorFunctionScaling -> False, MaxPlotPoints -> 10, Mesh -> 5];
p5 = ListSurfacePlot3D[coo11[[All, 1 ;; 3]], ColorFunction -> colfun, 
   ColorFunctionScaling -> False, MaxPlotPoints -> 10, Mesh -> 5];
p6 = ListSurfacePlot3D[coo13[[All, 1 ;; 3]], ColorFunction -> colfun, 
   ColorFunctionScaling -> False, MaxPlotPoints -> 10, Mesh -> 5];
p7 = ListSurfacePlot3D[coo15[[All, 1 ;; 3]], ColorFunction -> colfun, 
   ColorFunctionScaling -> False, MaxPlotPoints -> 10, Mesh -> 5];
Show[{p1, p11, p2, p3, p4, p5, p6, p7}, PlotRange -> All]
$\endgroup$
  • $\begingroup$ How is the data split up into 8 regions? The linked data file has 29,764 elements. Which part of it is coo4? I'm interested to reproduce this image but I don't see how. $\endgroup$ – Jason B. Mar 15 '16 at 15:37
  • $\begingroup$ @JasonB, sure done. I was not so keen as to share it as I'm sure its very ugly, inefficient and long. $\endgroup$ – sponce Mar 15 '16 at 15:55
  • $\begingroup$ why do you use different color schemes for the different parts? I see SunsetColors, Rainbow, and TemperatureMap there. $\endgroup$ – Jason B. Mar 15 '16 at 16:14
  • $\begingroup$ Some trial and errors I forgot to remove. Should be "TemperatureMap" everywhere. I've updated the question. $\endgroup$ – sponce Mar 15 '16 at 16:18
  • $\begingroup$ no time right now to do it proper, so this includes only 4 of the regions, but what do you think of it as a starting point: reg = alphaShapes2D[DeleteDuplicates@coo21[[All, ;; 2]], .2]; rf = Function[{x, y, z}, RegionMember[reg, {x, y}]]; ListPlot3D[{coo21, coo22, coo4, coo5}[[All, All, ;; 3]], RegionFunction -> rf, ColorFunction -> "TemperatureMap", MaxPlotPoints -> 100, BoxRatios -> Automatic, Mesh -> 10] $\endgroup$ – Jason B. Mar 15 '16 at 16:45
1
$\begingroup$

So keeping all your code up until just after the definition for alphashapes2D,

minmax = MinMax@{coo9, coo11, coo13, coo15, coo21, coo22, coo4, 
     coo5}[[All, All, 4]];
tubePlot[data_] := Module[{nf, colfun, reg},
   reg = alphaShapes2D[data[[All, ;; 2]] // DeleteDuplicates, .2];
   nf = Nearest[
     data[[All, ;; 3]] -> Rescale[data[[All, 4]], minmax]];
   colfun = ColorData["TemperatureMap"]@First@nf[{#1, #2, #3}] &;
   ListPlot3D[data[[All, ;; 3]],
    ColorFunction -> colfun,
    ColorFunctionScaling -> False, 
    RegionFunction -> Function[{x, y, z}, RegionMember[reg, {x, y}]],
    MaxPlotPoints -> 100,
    Mesh -> 10
    ]
   ];
cornerPlot[data_] := Module[{nf, colfun},
   nf = Nearest[
     data[[All, ;; 3]] -> Rescale[data[[All, 4]], minmax]];
   colfun = ColorData["TemperatureMap"]@First@nf[{#1, #2, #3}] &;
   ListSurfacePlot3D[data[[All, ;; 3]],
    ColorFunction -> colfun,
    ColorFunctionScaling -> False,
    MaxPlotPoints -> 5,
    Mesh -> 5
    ]
   ];
plotrange = 
  MinMax /@ 
   Transpose[
    Join[coo9, coo11, coo13, coo15, coo21, coo22, coo4, 
      coo5][[All, ;; 3]]];
Show[tubePlot /@ {coo21, coo22, coo4, coo5},
 cornerPlot /@ {coo9, coo11, coo13, coo15},
 PlotRange -> plotrange,
 BoxRatios -> Automatic,
 ImageSize -> 600
 ]

enter image description here

Aside from the differences in how I wrote the plotting functions (I hate to write the same things over and over again, so I make functions to do it for me), the main difference is that when I rescale the fourth data points, I use the second argument to Rescale. Every data point is rescaled on the same scale for all the different plots.

$\endgroup$
  • $\begingroup$ Thank you ! The crucial bit was "Rescale[data[[All, 4]], minmax]];" Super ! $\endgroup$ – sponce Mar 16 '16 at 16:57

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.