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.
In the accepted answer of question " Mathematica and MouseListener - developing interactive graphics with Mma " Sjoerd C de Vries demonstrates that it is possible to select an object in a 3D graphic and change its color.
I would like to know if it is possible (in a similar fashion as above) in a Graphics3D with two or more objects (e.g. two cuboids) to select one and change its coordinates (by moving or otherwise)?
I'm partly reusing Sjoerd's code here, but maybe something like this
DynamicModule[{pos10, pos11 = {0, 0, 0},
pos12 = {0, 0, 0}, pos20, pos21 = {0, 0, 0}, pos22 = {0, 0, 0}},
Graphics3D[{EventHandler[
Dynamic[{Translate[Cuboid[], pos11]}, ImageSize -> Tiny],
{"MouseDown" :> (pos10 = Mean#MousePosition["Graphics3DBoxIntercepts"]),
"MouseDragged" :> (pos11 =
pos12 + Mean#MousePosition["Graphics3DBoxIntercepts"] - pos10),
"MouseUp" :> (pos12 = pos11)}],
EventHandler[
Dynamic[{Translate[Cuboid[{1, 1, 1}], pos21]}, ImageSize -> Tiny],
{"MouseDown" :> (pos20 = Mean#MousePosition["Graphics3DBoxIntercepts"]),
"MouseDragged" :> (pos21 =
pos22 + Mean#MousePosition["Graphics3DBoxIntercepts"] - pos20),
"MouseUp" :> (pos22 = pos21)}]},
PlotRange -> {{-3, 3}, {-3, 3}, {-3, 3}}]]
Note that this just moves the cuboids in a plane so you would have to rotate the bounding box to move them perpendicular to that plane, but it shouldn't be too hard to introduce a third dimensions by adding modifier keys.
Edit
Thanks for the comments. Here's an updated version of the code above. In this version the cubes jump back to within the bounding box if they happen to move outside so that should solve the problem of the disappearing cubes.
DynamicModule[{init, cube, bb, restrict, generate},
init = {{0, 0, 0}, {2, 1, 0}};
bb = {{-3, 3}, {-3, 3}, {-3, 3}};
cube[pt_, scale_] :=
Translate[Scale[Cuboid[{-1/2, -1/2, -1/2}, {1/2, 1/2, 1/2}], scale], pt];
restrict[pt_] := MapThread[Min[Max[#1[[1]], #2], #1[[2]]] &, {bb, pt}];
generate[pos_, scale_] := Module[{mp, pos0, pos1, pos2},
mp := MousePosition["Graphics3DBoxIntercepts"];
pos1 = pos;
EventHandler[
Dynamic[{cube[pos1, scale]}, ImageSize -> Tiny],
{"MouseDown" :> (pos0 = LeastSquares[Transpose[mp], pos1].mp),
"MouseDragged" :>
((pos1 = #[[2]] + Projection[pos0 - #[[2]], #[[1]] - #[[2]]]) &#mp),
"MouseUp" :> (pos1 = restrict[pos1])}]];
Graphics3D[generate[#, 1] & /# init, PlotRange -> bb, PlotRangePadding -> .5]
]
I'm trying to combine 3 functions graphed on a Plot[] and 1 function graphed on a ParametricPlot[]. My equations are as follows:
plota = Plot[{-2 x, -2 Sqrt[x], -2 x^(3/5)}, {x, 0, 1}, PlotLegend -> {"-2 x", "-2 \!\(\*SqrtBox[\(x\)]\)", "-2 \!\(\*SuperscriptBox[\(x\), \(3/5\)]\)"}]
plotb = ParametricPlot[{2.4056 (u - Sin[u]), 2.4056 (Cos[u] - 1)}, {u,0, 1.40138}, PlotLegend -> {"Problem 3"}]
Show[plota, plotb]
This is the image it gives:
As yoda said, PlotLegends is terrible. However, if you don't mind setting the plot styles manually and repeating them lateron, ShowLegend can help.
plota = Plot[{-2 x, -2 Sqrt[x], -2 x^(3/5)}, {x, 0, 1},
PlotStyle -> {{Red}, {Blue}, {Orange}}];
plotb = ParametricPlot[{2.4056 (u - Sin[u]), 2.4056 (Cos[u] - 1)}, {u, 0, 1.40138},
PlotStyle -> {{Black}}];
And now
ShowLegend[Show[plota, plotb],
{{{Graphics[{Red, Line[{{0, 0}, {1, 0}}]}], Label1},
{Graphics[{Blue, Line[{{0, 0}, {1, 0}}]}], Label2},
{Graphics[{Orange, Line[{{0, 0}, {1, 0}}]}], Label3},
{Graphics[{Black, Line[{{0, 0}, {1, 0}}]}], Label4}},
LegendSize -> {0.5, 0.5}, LegendPosition -> {0.5, -0.2}}]
which will give you this:
You can also write some simple functions to make this a little less cumbersome, if you deal with this problem often.
Well, the root cause of the error is the PlotLegends package, which is a terrible, buggy package. Removing that, Show combines them correctly:
plota = Plot[{-2 x, -2 Sqrt[x], -2 x^(3/5)}, {x, 0, 1}]
plotb = ParametricPlot[{2.4056 (u - Sin[u]), 2.4056 (Cos[u] - 1)}, {u,
0, 1.40138}]
Show[plota, plotb]
You can see Simon's solution here for ideas to label your different curves without using PlotLegends. This answer by James also demonstrates why PlotLegends has the reputation it has...
You can still salvage something with the PlotLegends package. Here's an example using ShowLegends that you can modify to your tastes
colors = {Red, Green, Blue, Pink};
legends = {-2 x, -2 Sqrt[x], -2 x^(3/5), "Problem 3"};
plota = Plot[{-2 x, -2 Sqrt[x], -2 x^(3/5)}, {x, 0, 1},
PlotStyle -> colors[[1 ;; 3]]];
plotb = ParametricPlot[{2.4056 (u - Sin[u]), 2.4056 (Cos[u] - 1)}, {u,
0, 1.40138}, PlotStyle -> colors[[4]]];
ShowLegend[
Show[plota,
plotb], {Table[{Graphics[{colors[[i]], Thick,
Line[{{0, 0}, {1, 0}}]}], legends[[i]]}, {i, 4}],
LegendPosition -> {0.4, -0.15}, LegendSpacing -> 0,
LegendShadow -> None, LegendSize -> 0.6}]
As the other answers pointed out, the culprit is PlotLegend. So, sometimes is useful to be able to roll your own plot legends:
plotStyle = {Red, Green, Blue};
labls = {"a", "b", "Let's go"};
f[i_, s_] := {Graphics[{plotStyle[[i]], Line[{{0, 0}, {1, 0}}]},
ImageSize -> {15, 10}], Style[labls[[i]], s]};
Plot[{Sin[x], Sin[2 x], Sin[3 x]}, {x, 0, 2 Pi},
PlotStyle -> plotStyle,
Epilog ->
Inset[Framed[Style#Column[{Grid[Table[f[i, 15], {i, 1, 3}]]}]],
Offset[{-2, -2}, Scaled[{1, 1}]], {Right, Top}],
PlotRangePadding -> 1
]
How to get arrows for the axes when using the command Plot in Mathematica?
Thanks for any helpful answers.
For 2D plots such as generated by Plot the following works great:
Plot[Sin[x], {x, 0, 10}, AxesStyle -> Arrowheads[0.07]]
or with custom arrow heads:
h = Graphics[Line[{{-1, 1/2}, {0, 0}, {-1, -1/2}}]];
Plot[Sin[x], {x, 0, 10},
AxesStyle -> Arrowheads[{{Automatic, Automatic, h}}]]
Building on Sjoerd's answer,
a plot such as
may be obtained as follows (for example):
Plot[Sin[x], {x, -2\[Pi], 2 \[Pi]},
AxesStyle-> {
Directive[{Red,
Arrowheads[{{-0.06,0(*Xleft*),{Graphics[{
Polygon[
{{-1,0.5`},{0,0},{-1,-0.5`}}]}],0.98`}},
{0.03,.9(*Xright*),{Graphics[{
Polygon[
{{-1,0.5`},{0,0},{-1,-0.5`}}]}],0.98`}}}]}],
Directive[{Blue,
Arrowheads[{{-0.05,0(*Ydown*),{Graphics[{
Polygon[
{{-1,0.5`},{0,0},{-1,-0.5`}}]}],0.98`}},{0.03,.8(*Yup*),{Graphics[{
Polygon[
{{-1,0.5`},{0,0},{-1,-0.5`}}]}],0.98`}}}]}
]}]
There are nice examples of arrowheads given in Drawings Tools and Graphics Inspector. There are probably much better ways of getting the info but I annotate a plot with an arrow that I like and then abstract (using a suggestion from Simon):
Cases["Paste-Graphic_Here", Arrowheads[___], Infinity]
To give another example:
The code is as follows
Plot[Sin[x], {x, -2\[Pi],2 \[Pi]},
AxesStyle-> { Directive[{Red,
Arrowheads[{{-0.06,0.1(*Xleft*),
{Graphics[{arrowhead}]/.arrowhead-> arrowhead2,0.98`}},
{0.05,0.95(*Xright*),
{Graphics[{arrowhead}],0.98`}}}]/.arrowhead-> arrowhead4}],
Directive[{Blue,
Arrowheads[{{-0.05,0(*Ydown*),
{Graphics[{arrowhead}]/.arrowhead-> arrowhead3,0.98`}},{0.03,.8(*Yup*),
{Graphics[{arrowhead}]/.arrowhead-> arrowhead1,0.98`}}}]}
]}]
where
arrowhead1=Polygon[{{-1,0.5`},{0,0},{-1,-0.5`}}];
arrowhead2=Polygon[{{-1.5833333333333333`,0.4166666666666667`},{-1.5410500000000003`,0.369283333333333`},{-1.448333333333333`,0.255583333333333`},{-1.3991000000000005`,0.18721666666666673`},{-1.3564666666666663`,0.11826666666666673`},{-1.3268499999999999`,0.05408333333333341`},{-1.3166666666666667`,0.`},{-1.3268499999999999`,-0.048950000000000195`},{-1.3564666666666663`,-0.11228333333333372`},{-1.3991000000000005`,-0.18353333333333333`},{-1.448333333333333`,-0.2562833333333335`},{-1.5410500000000003`,-0.38048333333333345`},{-1.5833333333333333`,-0.43333333333333335`},{0.`,0.`},{-1.5833333333333333`,0.4166666666666667`},{-1.5833333333333333`,0.4166666666666667`}}];
arrowhead3=Polygon[{{-1,0.5`},{0,0},{-1,-0.5`},{-0.6`,0},{-1,0.5`}}];
arrowhead4={{FaceForm[GrayLevel[1]],Polygon[{{-0.6`,0},{-1.`,0.5`},{0.`,0},{-1.`,-0.5`},{-0.6`,0}}],Line[{{-0.6`,0},{-1.`,0.5`},{0.`,0},{-1.`,-0.5`},{-0.6`,0}}]}};
arrowhead5=Polygon[{{-0.6582278481012658`,-0.43037974683544306`},{0.`,0.`},{0.`,0.`},{0.`,0.`},{0.`,0.`},{0.`,0.`},{-0.6455696202531646`,0.43037974683544306`},{-0.4810126582278481`,0.`},{-0.6582278481012658`,-0.43037974683544306`},{-0.6582278481012658`,-0.43037974683544306`}}];
A list of arrowheads 1 to 5:
Here you have a solution posted in https://math.stackexchange.com/
As the solution in the reference is for Plot3D, here I modified (but not improved) it for Plot[ ]:
axes[x_, y_, f_, a_] :=
Graphics[Join[{Arrowheads[a]},
Arrow[{{0, 0}, #}] & /# {{x, 0}, {0, y}},
{Text[Style["x", FontSize -> Scaled[f]], {0.9*x, 0.1*y}],
Text[Style["y", FontSize -> Scaled[f]], {0.1 x, 0.95*y}]
}]]
Show[Plot[Exp[-x^2], {x, -2, 2},
Axes -> None,
PlotRange -> {{-2.1, 2.1}, {-.1, 1.1}}],
axes[2, 1, 0.05, 0.02]
]
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}]