Related
I would very much appreciate your help on my problem.
I would like to use the same color function that applies to the plot of data1 when plotting data2.
For example:
data1 = {{1, 0, 0}, {0, 1, 0}, {0, 0, 1}};
ListPointPlot3D[data1, PlotStyle -> PointSize[0.02],
ColorFunction -> Function[{x, y, z}, RGBColor[x, y, z]]]
and next I wish to plot another data (of same dimensions) using the previous colors in the same exact order (there is an unknown function transforming data1 to data2):
data2 = {{1, 1, 0}, {1, 0, 1}, {0, 1, 1}};
ListPointPlot3D[data2, PlotStyle -> PointSize[0.02],
ColorFunction -> Function[{x, y, z}, fun[x, y, z]]]
but for example a straightforward trial as follows will not work (although fun[] as such does work):
fun[r_, g_, b_] :=Table[RGBColor[data1[[i]]], {i,
Length[data1]}][[Position[data2, {r, g, b}][[1, 1]]]]
The gotcha in this is that ListPointPlot3D takes your integer data and converts to floats which it passes to your ColorFunction, so if you define your color function for discrete integers it fails to match the floats. Try this.. (Your approach may work as well if you work with real data )
data1 = N#{{1, 0, 0}, {0, 1, 0}, {0, 0, 1}};
cfun1[x_, y_, z_] := RGBColor[x, y, z]
ListPointPlot3D[data1, PlotStyle -> PointSize[0.02],
ColorFunction -> cfun1]
data2 = N#{{1, 1, 0}, {1, 0, 1}, {0, 1, 1}};
MapThread[ (cfun2[#2[[1]], #2[[2]], #2[[3]]] = cfun1 ## #1) & ,
{data1, data2}]
ListPointPlot3D[data2, PlotStyle -> PointSize[0.02],
ColorFunction -> cfun2]
A bit of an aside, but you likely would be better off working with graphics primitives, which would look something like this:
colors = cfun1 /# data1;
Graphics3D#MapThread[ {#1, Point##2} & , {colors, data1} ]
Graphics3D#MapThread[ {#1, Point##2} & , {colors, data2} ]
Use the colours from data1 in the PlotStyle option of the data2 plot. The list of directives in the PlotStyle refer to each data series so you have to make each point its own data series. I also take it that the values may not be between zero and one so rescale them for data2's use of RGBColor.
ListPointPlot3D[data1, PlotStyle -> PointSize[0.02],
ColorFunction -> Function[{x, y, z}, RGBColor[x, y, z]]]
rs = MinMax /# Transpose#data1;
ListPointPlot3D[List /# data2,
PlotStyle -> ({PointSize[0.02], RGBColor[Quiet#Thread[Rescale[#, rs]]]} & /# data1)]
Hope this helps.
Suppose I want a string, say "123", to fill a given rectangle, like so:
Show[Plot[x, {x, 0, 1}],
Graphics[{EdgeForm[Thick], Yellow, Rectangle[{.1, .5}, {.4, .9}]}],
Graphics[Text[Style["123", Red, Bold, 67], {.1, .5}, {-1, -1}]]]
But I hand-tuned the font size there (67) so that it would fill up the rectangle.
How would you make an arbitrary string fill up an arbitrary rectangle?
I believe that this is a known difficult problem. The best answer I could find is from John Fultz.
TextRect[text_, {{left_, bottom_}, {right_, top_}}] :=
Inset[
Pane[text, {Scaled[1], Scaled[1]},
ImageSizeAction -> "ResizeToFit", Alignment -> Center],
{left, bottom}, {Left, Bottom}, {right - left, top - bottom}]
Show[
Plot[x, {x, 0, 1}],
Graphics[{
{EdgeForm[Thick], Yellow, Rectangle[{.1, .5}, {.4, .9}]},
TextRect[Style["123", Red, Bold], {{.1, .5}, {.4, .9}}]
}]
]
Here's an alternate approach that converts the text to a texture that gets mapped to a polygon. This has the feature of stretching the text to fit the region (since it's not really text anymore.)
Show[Plot[x, {x, 0, 1}],
Graphics[{EdgeForm[Thick], Yellow, Rectangle[{.1, .5}, {.4, .9}]}],
Graphics[{Texture[ImageData[
Rasterize[Style["123", Red, Bold], "Image", RasterSize -> 300,
Background -> None]]],
Polygon[{{0.1, 0.5}, {0.4, 0.5}, {0.4, 0.9}, {0.1, 0.9}},
VertexTextureCoordinates -> {{0, 0}, {1, 0}, {1, 1}, {0, 1}}]}]]
As a function for easier comparison:
(* Render string/style s to fill a rectangle with left/bottom corner {l,b} and
right/top corner {r,t}. *)
textrect[s_, {{l_,b_},{r_,t_}}] := Graphics[{
Texture[ImageData[Rasterize[s, "Image", RasterSize->300, Background->None]]],
Polygon[{{l,b}, {r,b}, {r,t}, {l,t}},
VertexTextureCoordinates->{{0,0},{1,0},{1,1},{0,1}}]}]
The suggested solution didn't work when the Plot wasn't there, I used the PlotRange option to solve it. I wrapped it in a function; Opacity, text color, etc; should be made into options;
textBox[text_, color_, position_: {0, 0}, width_: 2, height_: 1] :=
Graphics[{
{
color, Opacity[.1],
Rectangle[position, position + {width, height},
RoundingRadius -> 0.1]
}
,
Inset[
Pane[text, {Scaled[1], Scaled[1]},
ImageSizeAction -> "ResizeToFit", Alignment -> Center],
position, {Left, Bottom}, {width, height}]
}, PlotRange ->
Transpose[{position, position + {width, height}}]];
Here is a set of structured 3D points. Now we can form a BSpline using these points as knots.
dat=Import["3DFoil.mat", "Data"]
fu=BSplineFunction[dat]
Here we can do a ParametricPlot3D with these points.
pic=ParametricPlot3D[fu[u,v],{u, 0, 1}, {v, 0, 1}, Mesh -> All, AspectRatio ->
Automatic,PlotPoints->10,Boxed-> False,Axes-> False]
Question
If we carefully look at the 3D geometry coming out of the spline we can see that it is a hollow structure. This hole appears in both side of the symmetric profile. How can we perfectly (not visually!) fill up this hole and create a unified Graphics3D object where holes in both sides are patched.
What I am able to get so far is the following. Holes are not fully patched.
I am asking too many questions recently and I am sorry for that. But if any of you get interested I hope you will help.
Update
Here is the problem with belisarius method.
It generates triangles with almost negligible areas.
dat = Import[NotebookDirectory[] <> "/3DFoil.mat", "Data"];
(*With your points in "dat"*)
fd = First#Dimensions#dat;
check = ParametricPlot3D[{BSplineFunction[dat][u, v],
BSplineFunction[{dat[[1]], Reverse#dat[[1]]}][u, v],
BSplineFunction[{dat[[fd]], Reverse#dat[[fd]]}][u, v]}, {u, 0,
1}, {v, 0, 1}, Mesh -> All, AspectRatio -> Automatic,
PlotPoints -> 10, Boxed -> False, Axes -> False]
output is here
Export[NotebookDirectory[]<>"myres.obj",check];
cd=Import[NotebookDirectory[]<>"myres.obj"];
middle=
check[[1]][[2]][[1]][[1(* Here are the numbers of different Graphics group*)]][[2,1,1,1]];
sidePatch1=check[[1]][[2]][[1]][[2]][[2,1,1,1]];
sidePatch2=check[[1]][[2]][[1]][[3]][[2,1,1,1]];
There are three Graphics groups rest are empty. Now lets see the area of the triangles in those groups.
polygonArea[pts_List?
(Length[#]==3&)]:=Norm[Cross[pts[[2]]-pts[[1]],pts[[3]]-pts[[1]]]]/2
TriangleMaker[{a_,b_,c_}]:={vertices[[a]],vertices[[b]],vertices[[c]]}
tring=Map[polygonArea[TriangleMaker[#]]&,middle];
tring//Min
For the middle large group output is
0.000228007
This is therefore a permissible triangulation. But for the side patches we get zero areas.
Map[polygonArea[TriangleMaker[#]] &, sidePatch1] // Min
Map[polygonArea[TriangleMaker[#]] &, sidePatch2] // Min
Any way out here belisarius ?
My partial solution
First download the package for simplifying complex polygon from Wolfram archive.
fu = BSplineFunction[dat];
pic =(*ParametricPlot3D[fu[u,v],{u,0,1},{v,0,1},Mesh->None,
AspectRatio->Automatic,PlotPoints->25,Boxed->False,Axes->False,
BoundaryStyle->Red]*)
ParametricPlot3D[fu[u, v], {u, 0, 1}, {v, 0, 1}, Mesh -> None,
AspectRatio -> Automatic, PlotPoints -> 10, Boxed -> False,
Axes -> False, BoundaryStyle -> Black];
bound = First#Cases[Normal[pic], Line[pts_] :> pts, Infinity];
corners = Flatten[Table[fu[u, v], {u, 0, 1}, {v, 0, 1}], 1];
nf = Nearest[bound -> Automatic]; {a1, a2} =
Union#Flatten#(nf /# corners);
sets = {bound[[2 ;; a1]], bound[[a1 ;; a2]],bound[[a2 ;; a2 + a1]]};
CorrectOneNodeNumber = Polygon[sets[[{1, 3}]]][[1]][[1]] // Length;
CorrectOneNodes1 =
Polygon[sets[[{1, 3}]]][[1]][[1]]; CorrectOneNodes2 =
Take[Polygon[sets[[{1, 3}]]][[1]][[2]], CorrectOneNodeNumber];
<< PolygonTriangulation`SimplePolygonTriangulation`
ver1 = CorrectOneNodes1;
ver2 = CorrectOneNodes2;
triang1 = SimplePolygonTriangulation3D[ver1];
triang2 = SimplePolygonTriangulation3D[ver2];
Show[Graphics3D[{PointSize[Large], Point[CorrectOneNodes1]},Boxed -> False,
BoxRatios -> 1], Graphics3D[{PointSize[Large], Point[CorrectOneNodes2]},
Boxed -> False, BoxRatios -> 1],
Graphics3D[GraphicsComplex[ver1, Polygon[triang1]], Boxed -> False,
BoxRatios -> 1],
Graphics3D[GraphicsComplex[ver2, Polygon[triang2]], Boxed -> False,
BoxRatios -> 1]]
We get nice triangles here.
picfin=ParametricPlot3D[fu[u,v],{u,0,1}, {v,0,1},Mesh->All,AspectRatio->Automatic,PlotPoints->10,Boxed->False,Axes->False,BoundaryStyle->None];pic3D=Show[Graphics3D[GraphicsComplex[ver1,Polygon[triang1]]],picfin,Graphics3D[GraphicsComplex[ver2,Polygon[triang2]]],Boxed->False,Axes->False]
Now this has just one problem. Here irrespective of the PlotPoints there are four triangles always appearing that just shares only one edge with any other neighboring triangle. But we expect all of the triangles to share at least two edges with other trangles. That happens if we use belisarius method. But it creates too small triangles that my panel solver rejects as tingles with zero area.
One can check here the problem of my method. Here we will use the method from the solution by Sjoerd.
Export[NotebookDirectory[]<>"myres.obj",pic3D];
cd=Import[NotebookDirectory[]<>"myres.obj"];
polygons=(cd[[1]][[2]]/.GraphicsComplex-> List)[[2]][[1]][[1,1]];
pt=(cd[[1]][[2]]/.GraphicsComplex-> List)[[1]];
vertices=pt;
(*Split every triangle in 3 edges,with nodes in each edge sorted*)
triangleEdges=(Sort/#Subsets[#,{2}])&/#polygons;
(*Generate a list of edges*)
singleEdges=Union[Flatten[triangleEdges,1]];
(*Define a function which,given an edge (node number list),returns the bordering*)
(*triangle numbers.It's done by working through each of the triangles' edges*)
ClearAll[edgesNeighbors]
edgesNeighbors[_]={};
MapIndexed[(edgesNeighbors[#1[[1]]]=Flatten[{edgesNeighbors[#1[[1]]],#2[[1]]}];
edgesNeighbors[#1[[2]]]=Flatten[{edgesNeighbors[#1[[2]]],#2[[1]]}];
edgesNeighbors[#1[[3]]]=Flatten[{edgesNeighbors[#1[[3]]],#2[[1]]}];)&,triangleEdges];
(*Build a triangle relation table.Each'1' indicates a triangle relation*)
relations=ConstantArray[0,{triangleEdges//Length,triangleEdges//Length}];
Scan[(n=edgesNeighbors[##];
If[Length[n]==2,{n1,n2}=n;
relations[[n1,n2]]=1;relations[[n2,n1]]=1];)&,singleEdges]
(*Build a neighborhood list*)
triangleNeigbours=Table[Flatten[Position[relations[[i]],1]],{i,triangleEdges//Length}];
trires=Table[Flatten[{polygons[[i]],triangleNeigbours[[i]]}],{i,1,Length#polygons}];
Cases[Cases[trires,x_:>Length[x]],4]
Output shows always there are four triangles that shares only one edges with others.
{4,4,4,4}
In case of belisarius method we don't see this happening but there we get triangles with numerically zero areas.
BR
Import the data and construct the BSpline function as before:
dat = Import["Downloads/3DFoil.mat", "Data"];
fu = BSplineFunction[dat]
Generate the surface, making sure to include (only) the boundary line, which will follow the edge of the surface. Make sure to set Mesh to either All or None.
pic = ParametricPlot3D[fu[u, v], {u, 0, 1}, {v, 0, 1}, Mesh -> None,
AspectRatio -> Automatic, PlotPoints -> 10, Boxed -> False,
Axes -> False, BoundaryStyle -> Red]
Extract the points from the boundary line:
bound = First#Cases[Normal[pic], Line[pts_] :> pts, Infinity]
Find the "corners", based on your parameter space:
corners = Flatten[Table[fu[u, v], {u, 0, 1}, {v, 0, 1}], 1]
Find the edge points best corresponding to the corners, keeping in mind that ParametricPlot3D doesn't use the limits exactly, so we can't just use Position:
nf = Nearest[bound -> Automatic];
nf /# corners
Figure our which range of points on the boundary correspond to the areas you need to fill up. This step involved some manual inspection.
sets = {bound[[2 ;; 22]], bound[[22 ;; 52]], bound[[52 ;; 72]],
bound[[72 ;;]]}
Construct new polygons corresponding to the holes:
Graphics3D[Polygon[sets[[{1, 3}]]], Boxed -> False, BoxRatios -> 1]
Show[pic, Graphics3D[Polygon[sets[[{1, 3}]]]]]
Note that there is probably still a hole that can't be seen where the edge runs between the holes you mentioned, and I haven't tried to fill it in, but you should have enough information to do that if needed.
Your data set looks like this:
Graphics3D[Point#Flatten[dat, 1]]
It consists of 22 sections of 50 points.
Adding a mid-line in each end section (which is actually the end section flattened):
dat2 = Append[Prepend[dat,
Table[(dat[[1, i]] + dat[[1, -i]])/2, {i, Length[dat[[1]]]}]
],
Table[(dat[[-1, i]] + dat[[-1, -i]])/2, {i, Length[dat[[-1]]]}]
];
Graphics3D[{Point#Flatten[dat, 1], Red, Point#dat2[[1]], Green, Point#dat2[[-1]]}]
Now add some weights to the wingtip rim:
sw = Table[1, {24}, {50}];
sw[[2]] = 1000 sw[[1]];
sw[[-2]] = 1000 sw[[1]];
fu = BSplineFunction[dat2, SplineWeights -> sw];
Show[
ParametricPlot3D[fu[u, v], {u, 0, 1}, {v, 0, 1}, Mesh -> All,
AspectRatio -> Automatic, PlotPoints -> 20, Boxed -> False,
Axes -> False, Lighting -> "Neutral"
],
Graphics3D[{PointSize -> 0.025, Green, Point#dat2[[-1]], Red,Point#dat2[[-2]]}]
]
Note that I increased the PlotPoints value to 20.
(*With your points in "dat"*)
fu = BSplineFunction[dat[[1 ;; 2]]];
Show[{ParametricPlot3D[fu[u, v], {u, 0, 1}, {v, 0, 1},
Mesh -> All, AspectRatio -> Automatic, PlotPoints -> 30],
ListPlot3D[dat[[1]]]}]
And with
InputForm[%]
you get the "unified" graphics object.
Edit
Another way, probably better:
(*With your points in "dat"*)
fu = BSplineFunction[dat];
Show[
{ ParametricPlot3D[fu[u, v], {u, 0, 1}, {v, 0, 1},
Mesh -> All, AspectRatio -> Automatic,
PlotPoints -> 10, Boxed -> False, Axes -> False],
ParametricPlot3D[
BSplineFunction[{First#dat, Reverse#First#dat}][u, v], {u, 0, 1}, {v, 0, 1},
Mesh -> None, PlotStyle -> Yellow],
ParametricPlot3D[
BSplineFunction[{dat[[First#Dimensions#dat]],
Reverse#dat[[First#Dimensions#dat]]}]
[u, v], {u, 0, 1}, {v, 0, 1}]}]
In just one structure:
(*With your points in "dat"*)
fd = First#Dimensions#dat;
ParametricPlot3D[
{BSplineFunction[dat][u, v],
BSplineFunction[{dat[[1]], Reverse#dat[[1]]}] [u, v],
BSplineFunction[{dat[[fd]], Reverse#dat[[fd]]}][u, v]},
{u, 0, 1}, {v, 0, 1},
Mesh -> All, AspectRatio -> Automatic,
PlotPoints -> 10, Boxed -> False, Axes -> False]
Edit
You can check that there are small triangles, but they are triangles indeed and not zero area polygons:
fu = BSplineFunction[dat];
check = ParametricPlot3D[{BSplineFunction[{First#dat, Reverse#dat[[1]]}][u, v]},
{u, 0, 1}, {v, 0, 1}, Mesh -> All,
PlotStyle -> Yellow, Mesh -> All, AspectRatio -> Automatic,
PlotPoints -> 10, Boxed -> False, Axes -> False];
pts = check /. Graphics3D[GraphicsComplex[a_, b__], ___] -> a;
m = check[[1]][[2]][[1]][[1]] /. {___, GraphicsGroup[{Polygon[a_]}]} -> a;
t = Replace[m, {a_, b_, c_} -> {pts[[a]], pts[[b]], pts[[c]]}, {1}];
polygonArea[pts_List?(Length[#] == 3 &)] :=
Norm[Cross[pts[[2]] - pts[[1]], pts[[3]] - pts[[1]]]]/2;
t[[Position[Ordering[polygonArea /# t], 1][[1]]]]
(*
->{{{-4.93236, 0.0989696, -2.91748},
{-4.92674, 0.0990546, -2.91748},
{-4.93456, 0.100181, -2.91748}}}
*)
Considering
dacount = {{0, 69}, {1, 122}, {2, 98}, {3, 122}, {4, 69}}
ListPlot[dacount, AxesOrigin -> {-1, 0},
PlotMarkers ->Automatic
PlotStyle-> Lighter[Red, #] & /# Range[0.5, 1, 0.1],
Filling -> Axis, FillingStyle -> Opacity[0.8],
PlotRange -> {{-1, 4.5}, {0, 192}}]
My hope there was for each point to take a different shade of red.
But I can`t understand how to have a style for point which I tried to set as different list.
In your original code, the PlotStyle option won't affect the marker symbols, so you can leave it out. Instead, change your PlotMarkers option to the following:
PlotMarkers -> With[{markerSize = 0.04},
{Graphics[{Lighter[Red, #], Disk[]}], markerSize} & /# Range[0.5, 1, 0.1]]
This will not yet have the desired effect until you replace the list dacount by:
Map[List, dacount]
By increasing the depth of the point list in this way, each point is assigned a marker style of its own from the list in PlotMarkers. So the final code is:
ListPlot[Map[List, dacount], AxesOrigin -> {-1, 0},
PlotMarkers ->
With[{markerSize =
0.04}, {Graphics[{Lighter[Red, #], Disk[]}], markerSize} & /#
Range[0.5, 1, 0.1]], Filling -> Axis,
FillingStyle -> Opacity[0.8], PlotRange -> {{-1, 4.5}, {0, 192}}]
You can also do it the following way:
xMax = Max#dacount[[All, 1]];
Show#(ListPlot[{#}, AxesOrigin -> {-1, 0}, PlotMarkers -> Automatic,
PlotStyle -> (RGBColor[{(#[[1]] + 5)/(xMax + 5), 0, 0}]),
Filling -> Axis, FillingStyle -> Opacity[0.8],
PlotRange -> {{-1, 4.5}, {0, 192}}] & /# dacount)
This plots each point in dacount individually and assigns it a shade of red depending on the x value. The plots are then combined with Show.
I've arbitrarily chosen a scaling and offset for the different shades. You can choose whatever you want, as long as you ensure that the max value is 1.
I have a graphical object which is moving along a trajectory. How can I make the camera follow the object?
Let's draw a planet and its satellite, with the camera following the moon from a view directed toward the Earth. For example:
a = {-3.5, 3.5};
Animate[
Show[
Graphics3D[
Sphere[3 {Cos#t, Sin#t, 0}, .5],
ViewPoint -> 3.5 {Cos#t, Sin#t, 0},
SphericalRegion -> True,
PlotRange -> {a, a, a}, Axes -> False, Boxed -> False],
myEarth],
{t, 0, 2 Pi}]
Where myEarth is another 3D Graphics (for reference).
Static vertical view:
a = {-3.5, 3.5};
Animate[
Show[
Graphics3D[
Sphere[3 {Cos#t, Sin#t, 0}, .5],
ViewPoint -> 3.5 {0,0,1},
SphericalRegion -> True,
PlotRange -> {a, a, a}, Axes -> False, Boxed -> False],
myEarth],
{t, 0, 2 Pi}]
The trick is SphericalRegion -> True, without it the image perspective "moves" from frame to frame.
Edit
With two static objects:
Since the question asks about 2D, here's how you can emulate a camera in 2D Graphics.
First, let's get the stackoverflow favicon.ico:
so = First#Import["http://sstatic.net/stackoverflow/img/favicon.ico"]
Well put this on top of some overlapping circles and make the "camera" follow the icon around by adjusting the PlotRange
Manipulate[Graphics[{
Table[Circle[{j, 0}, i], {i, 0, 1, .1}, {j, {-.5, .5}}],
Inset[so, pos, {0, 0}, .2]},
PlotRange -> {{-.5, .5}, {-.5, .5}} + pos],
{{pos, {0, 0}, ""}, {-1.4, -1}, {1.4, 1}, ControlPlacement -> Left}]
To show how it works (with out putting the above into Mathematica), we need to animate it.
Originally I chose a variable step random walk drunk = Accumulate[RandomReal[{-.1, .1}, {200, 2}]] but it was a unpredictable! So instead, we'll make the icon follow the ABC logo
drunk = Table[{1.5 Sin[t], Cos[3 t]}, {t, 0, 2 Pi, .1}];
Animate[Graphics[{
Table[Circle[{j, 0}, i], {i, 0, 1, .1}, {j, {-.5, .5}}],
Inset[so, drunk[[pos]], {0, 0}, .2]},
PlotRange -> {{-.5, .5}, {-.5, .5}} + drunk[[pos]]],
{pos, 1, Length[drunk], 1}]