Re: Coloring a ListSurfacePlot3D with a n x 4 matrix
- To: mathgroup at smc.vnet.net
- Subject: [mg118317] Re: Coloring a ListSurfacePlot3D with a n x 4 matrix
- From: Heike Gramberg <heike.gramberg at gmail.com>
- Date: Thu, 21 Apr 2011 03:12:28 -0400 (EDT)
Hi David,
You could increase MaxPlotPoints to get rid of the holes, but that still produces a plot with jagged edges for some reason:
Points = Flatten[
Table[{x, y, 1 - x - y, (x - 1/2)^2 + (y - 1/2)^2}, {x, 0, 1,
0.02}, {y, 0, 1, 0.02}], 1];
interpf =
Interpolation[
Transpose[{Points[[All, {1, 2}]], Points[[All, 4]]}]];
ListSurfacePlot3D[Points[[All, {1, 2, 3}]], MaxPlotPoints -> 60,
ColorFunction ->
Function[{x, y}, ColorData["GreenBrownTerrain"][interpf[x, y]]] ]
In this particular example it's probably better to use ListPlot3D instead:
ListPlot3D[Points[[All, {1, 2, 3}]],
ColorFunction ->
Function[{x, y}, ColorData["GreenBrownTerrain"][interpf[x, y]]] ]
Heike
On 20 Apr 2011, at 00:25, David Kahle wrote:
> Hi Heike, Daniel -
>
> Thanks for the reply.
>
> Both of your methods work in the examples attached; they seem to work in mine too save one problem - ListSurfacePlot3D itself now seems unstable. For example, refining the mesh tears holes in the surface (and what it does to the surface I am using you can see in the attached, it's like Mathematica's mocking me :).
>
> Thanks again.
> david.
>
> <Picture 2.png>
>
>
> On Apr 19, 2011, at 8:58 AM, Daniel Lichtblau wrote:
>
>> David Kahle wrote:
>>> Hi Bob!
>>> Thanks for the reply.
>>> Unfortunately, since I only have the points in the matrix I don't know what the underlying function is. I tried to get around the problem with Interpolation, but Interpolation (for some reason) wasn't able to make a function that I could then pass to ListSurfacePlot3D. So I tried with BSplineFunction, but that didn't work either but for a different reason (mis-specification problem?).
>>> Ideas? Code below.
>>> Thanks again
>>> david.
>>> points = Flatten[
>>> Table[{x, y, 1 - x - y, (x - 1/2)^2 + (y - 1/2)^2 + RandomReal[]}, {x, 0,
>>> 1, 1/4}, {y, 0, 1, 1/4}], 1];
>>> knots = Most /@ points;
>>> values = Last /@ points;
>>> list4interpolation = Table[{knots[[k]], values[[k]]}, {k, Length[knots]}];
>>> intF = Interpolation[list4interpolation] (* fails *)
>>> f = BSplineFunction[points];
>>> colorF = Function[{x, y, z}, ColorData["GreenBrownTerrain"]@f[x, y, z]];
>>> ListSurfacePlot3D[knots, ColorFunction -> colorF]
>>> On Apr 18, 2011, at 5:37 AM, Bob Hanlon wrote:
>>>> The ColorFunction must be defined for all values of {x,y,z} not just discrete values.
>>>>
>>>> points = Flatten[Table[
>>>> {x, y, 1 - x - y, (x - 1/2)^2 + (y - 1/2)^2},
>>>> {x, 0, 1, 1/4}, {y, 0, 1, 1/4}], 1];
>>>>
>>>> knots = Most /@ points;
>>>>
>>>> colorF = Function[{x, y, z},
>>>> ColorData["GreenBrownTerrain"][
>>>> (x - 1/2)^2 + (y - 1/2)^2]];
>>>>
>>>> ListSurfacePlot3D[knots, ColorFunction -> colorF]
>>>>
>>>>
>>>> Bob Hanlon
>>>>
>>>> ---- David Kahle <david.kahle at gmail.com> wrote:
>>>>
>>>> ==========================
>>>> Hi all -
>>>>
>>>> I have a matrix whose rows, 4 dimensional vectors, represent (x, y, z)
>>>> values as well as a measurement f which I would like to use to create
>>>> an interpolated surface colored according to the value of f.
>>>> ListSurfacePlot3D gives me the appropriate surface (when I strain out
>>>> the x, y, z values), but I'm having a hard time coloring it. I've
>>>> tried basic stuff with ColorFunction to no avail, but I'm sure this is
>>>> a simple task. Ideas? Small example below.
>>>>
>>>>
>>>> Points = Flatten[
>>>> Table[{x, y, 1 - x - y, (x - 1/2)^2 + (y - 1/2)^2}, {x, 0, 1,
>>>> 1/4}, {y, 0,
>>>> 1, 1/4}], 1];
>>>> N[Points[[1 ;; 5]]]
>>>>
>>>> Knots = Map[Take[#, {1, 3}] &, Points];
>>>> N[Knots[[1 ;; 5]]]
>>>>
>>>> ListSurfacePlot3D[Knots] (* Works fine, how to I color the surface? *)
>>>>
>>>> Colorf = Function[{x, y, z}, ColorData["GreenBrownTerrain"][
>>>> Points[[ Position[Knots, {x, y, z}][[1]] ]][[1]][[4]]
>>>> ]];
>>>> ListSurfacePlot3D[Knots, ColorFunction -> Colorf]
>>>>
>>>>
>>>> Many thanks
>>>> david.
>>>>
>>>> ----------------------------------
>>>> ----------------------------------
>>>> David Kahle
>>>> Rice University
>>>> Rm. 1041 Duncan Hall
>>>> Department of Statistics, MS 138
>>>> 6100 Main St.
>>>> Houston, TX 77005
>>>> http://sites.google.com/site/davidkahle
>>
>> Could make a NearestFunction and use that to map to colors.
>>
>> points = Flatten[
>> Table[{x, y,
>> 1 - x - y, (x - 1/2)^2 + (y - 1/2)^2 + RandomReal[]}, {x, 0, 1,
>> 1/4}, {y, 0, 1, 1/4}], 1];
>> knots = Most /@ points;
>> values = Last /@ points;
>>
>> nf = Nearest[knots];
>> Do[eval[knots[[k]]] = values[[k]], {k, Length[points]}];
>> colorF = Function[{x, y, z},
>> ColorData["GreenBrownTerrain"][eval[First[nf[{x, y, z}]]]]];
>>
>> ListSurfacePlot3D[knots, ColorFunction -> colorF]
>>
>> Daniel Lichtblau
>> Wolfram Research
>