Related
I'm trying to draw lines to the intersection of two functions in Mathematica that can be manipulated with a couple variables each in the following equation:
Manipulate[
Show[
Plot[
Tooltip[QSupply + q^PriceElasticity, "Supply"], {q, 0, 150},
AxesOrigin -> {0, 0},
PlotStyle -> {Thick, Red},
AxesLabel -> {"quantity", "price"},
PlotRange -> {{0, 200}, {0, 200}},
PlotLabel -> Macroeconomy, Ticks -> {{{45, "Qe"}}, {{54.3, "Pe"}}},
BaseStyle -> {FontWeight -> "Bold", FontSize -> 12}
],
Plot[
Tooltip[(DemandElasticity/q) + QDemand, "Aggregate Demand"], {q,
0, 180},
AxesOrigin -> {0, 0},
PlotStyle -> {Thick, Blue}
],
Graphics[{Dashed, Line[{{45, 0}, {45, 54.3}}]}],
Graphics[{Dashed, Line[{{0, 54.3}, {45, 54.3}}]}]
],
{PriceElasticity, 0.6, 10},
{QSupply, -17, 55, 2},
{DemandElasticity, 500, 10000, 100},
{QDemand, 0, 150, 10}
]
I tried using the FindRoot function, but the output doesn't give a raw value (eg. {q->40.0123}. Is there a way to extract the value from the FindRoot output? Or is there a better way to go about this?
I also looked into using Mesh but it looks like that would only help draw a dot at the point of intersection.
Thanks for your help!
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}}]];
Please Consider:
dalist={{21, 22}, {26, 13}, {32, 17}, {31, 11}, {30, 9},
{25, 12}, {12, 16}, {18, 20}, {13, 23}, {19, 21},
{14, 16}, {14, 22}, {18,22}, {10, 22}, {17, 23}}
ScreenCenter = {20, 15}
FrameXYs = {{4.32, 3.23}, {35.68, 26.75}}
Graphics[{EdgeForm[Thick], White, Rectangle ## FrameXYs,
Black, Point#dalist, Red, Disk[ScreenCenter, .5]}]
What I would like to do is to compute, for each point, its angle in a coordinate system such as :
Above is the Deisred output, those are frequency count of point given a particular "Angle Bin".
Once I know how to compute the angle i should be able to do that.
Mathematica has a special plot function for this purpose: ListPolarPlot. You need to convert your x,y pairs to theta, r pairs, for instance as follows:
ListPolarPlot[{ArcTan[##], EuclideanDistance[##]} & ### (#-ScreenCenter & /# dalist),
PolarAxes -> True,
PolarGridLines -> Automatic,
Joined -> False,
PolarTicks -> {"Degrees", Automatic},
BaseStyle -> {FontFamily -> "Arial", FontWeight -> Bold,FontSize -> 12},
PlotStyle -> {Red, PointSize -> 0.02}
]
UPDATE
As requested per comment, polar histograms can be made as follows:
maxScale = 100;
angleDivisions = 20;
dAng = (2 \[Pi])/angleDivisions;
Some test data:
(counts = Table[RandomInteger[{0, 100}], {ang, angleDivisions}]) // BarChart
ListPolarPlot[{{0, maxScale}},
PolarAxes -> True, PolarGridLines -> Automatic,
PolarTicks -> {"Degrees", Automatic},
BaseStyle -> {FontFamily -> "Arial", FontWeight -> Bold, FontSize -> 12},
PlotStyle -> {None},
Epilog -> {Opacity[0.7], Blue,
Table[
Polygon#
{
{0, 0},
counts[[ang + 1]] {Cos[ang dAng - dAng/2],Sin[ang dAng- dAng/2]},
counts[[ang + 1]] {Cos[ang dAng + dAng/2],Sin[ang dAng+ dAng/2]}
},
{ang, 0, angleDivisions - 1}
]}
]
A small visual improvement using Disk sectors instead of Polygons:
ListPolarPlot[{{0, maxScale}},
PolarAxes -> True, PolarGridLines -> Automatic,
PolarTicks -> {"Degrees", Automatic},
BaseStyle -> {FontFamily -> "Arial", FontWeight -> Bold,
FontSize -> 12}, PlotStyle -> {None},
Epilog -> {Opacity[0.7], Blue,
Table[
Disk[{0,0},counts[[ang+1]],{ang dAng-dAng/2,ang dAng+dAng/2}],
{ang, 0, angleDivisions - 1}
]
}
]
A clearer separation of the 'bars' is obtained with the addition of EdgeForm[{Black, Thickness[0.005]}] in the Epilog. Now the numbers marking the rings still have the unnecessary decimal point trailing them. Following the plot with the replacement /. Style[num_?MachineNumberQ, List[]] -> Style[num // Round, List[]] removes those. The end result is:
The above plot can also be generated with SectorChart although this plot is primarily intended to show varying width and height of the data, and isn't fine-tuned for plots where you have fixed-width sectors and you want to highlight directions and data counts in those directions. But it can be done by using SectorOrigin. The problem is I take it that the midpoint of a sector codes for its direction so to have 0 deg in the mid of a sector I have to offset the origin by \[Pi]/angleDivisions and specify the ticks by hand as they get rotated too:
SectorChart[
{ConstantArray[1, Length[counts]], counts}\[Transpose],
SectorOrigin -> {-\[Pi]/angleDivisions, "Counterclockwise"},
PolarAxes -> True, PolarGridLines -> Automatic,
PolarTicks ->
{
Table[{i \[Degree] + \[Pi]/angleDivisions, i \[Degree]}, {i, 0, 345, 15}],
Automatic
},
ChartStyle -> {Directive[EdgeForm[{Black, Thickness[0.005]}], Blue]},
BaseStyle -> {FontFamily -> "Arial", FontWeight -> Bold,
FontSize -> 12}
]
The plot is almost the same, but it is more interactive (tooltips and so).
That seems to be the polar coordinate system. The Cartesian-to-polar conversion formulas are in that same article:
This returns the angle in radians.
This
N#ArcTan[#[[1]], #[[2]]] & /# (# - ScreenCenter & /# dalist)
returns the list of angles of the ray from ScreenCenter to each point, in radians and between -pi and pi.
That is, I assumed you want the angle between each point in your plot and the red dot.
Note the use of ArcTan[x,y] rather than ArcTan[y/x], which automatically chooses the appropriate sign (otherwise you'd have to do it by hand, as in #Blender's answer).
If you run the following code snippet:
Manipulate[
Graphics3D[
{Cuboid[{{-1, -1, -1}, {1, 1, 1}}], Sphere[{5, 5, 5}, 1]},
ViewPoint -> {1, 1, a}, AxesOrigin -> {0,0,0}
],
{a, 1, 100}
]
and move the viewpoint from (1,1,1) to (1,1,100) with the slider you will see that after a while the objects remain fixed in size.
Questions.
1. When I move the viewpoint further away from the scene I want the objects to become smaller. How should this be done in Mathematica?
( EDIT: )
2. What is the position of the 'camera' in relation to Viewpoint?
See ViewAngle. Under "More Information", note that the default setting ViewAngle -> Automatic is effectively equivalent to ViewAngle -> All when you zoom far enough out.
You just need to add an explicit setting for ViewAngle:
Manipulate[
Graphics3D[{Cuboid[{{-1, -1, -1}, {1, 1, 1}}], Sphere[{5, 5, 5}, 1]},
ViewPoint -> {1, 1, a}, AxesOrigin -> {0, 0, 0},
ViewAngle -> 35 Degree], {a, 1, 100}]
As far as I know, the camera viewpoint really coincides with the position given by ViewPoint. Because Mathematica scales the result to fit in about the same image you don't see much changes but they are there. The perspective changes considerably. Try, for instance, to move away from a semi-transparant square and you'll see that the farther you go, the more the projection becomes an orthogonal projection:
If you want to scale your image according to distance you can use ImageSize. SphericalRegion is good to stabilize the image.
Manipulate[
vp = {1, 1, a};
Graphics3D[{Cuboid[{{-1, -1, -1}, {1, 1, 1}}], Sphere[{5, 5, 5}, 1]},
ViewPoint -> vp,
AxesOrigin -> {0, 0, 0},
SphericalRegion -> True,
ImageSize -> 500/Norm[vp]],
{a, 1, 100}
]
[animation made with some ImagePadding to keep object in the center. I stopped the animation at a = 10, the image gets pretty small after that]
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}]