Combining Plots in Mathematica is not giving the expected result - wolfram-mathematica

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
]

Related

Make Axis and ticks invisible in mathematica plot, but keep labels

I want to make a mathematica plot with no visible y-axis, but retaining the tick labels.
I've tried AxesStyle -> {Thickness[.001], Thickness[0]} with no effect, and setting the opacity to 0 also makes the tick labels fully transparent (and thus invisible).
Any help would be very much appreciated...
p = Plot[Sin[x], {x, 0, 6 Pi},
AxesStyle -> {Black, Opacity[0]},
TicksStyle -> Directive[Opacity[1], Black]]
ticks = AbsoluteOptions[p, Ticks];
ticks[[1, 2, 2]] = DeleteCases[ticks[[1, 2, 2]], {_, "", __}];
ticks[[1, 2, 2, All, 3]] = ConstantArray[{0, 0},
Length[ticks[[1, 2, 2, All, 3]]]];
ticks[[1, 2, 2, All, 2]] = Map[ToString,
ticks[[1, 2, 2, All, 2]]] /. a_String :>
If[StringTake[a, -1] == ".", a <> "0", a];
Plot[Sin[x], {x, 0, 6 Pi},
AxesStyle -> {Black, Directive[Opacity[0], Red]},
TicksStyle -> Directive[Opacity[1], Black],
Ticks -> {Automatic, ticks[[1, 2, 2]]}]
To get the exact original ticks you can use
Cases[Charting`FindTicks[{0, 1}, {0, 1}] ## PlotRange[p][[2]], {_, _}]
{{-1.,-1.0},{-0.5,-0.5},{0.,0},{0.5,0.5},{1.,1.0}}
as implemented here:
p = Plot[Sin[x], {x, 0, 6 Pi},
AxesStyle -> {Automatic, Opacity[0]},
TicksStyle -> Opacity[1]];
ticks = AbsoluteOptions[p, Ticks];
onestyledtick = ticks[[1, 2, 2, 1]];
labels = Cases[Charting`FindTicks[{0, 1}, {0, 1}] ##
PlotRange[p][[2]], {_, _}];
yticks = Map[Join[#, {{0, 0}},
Take[onestyledtick, -1]] &, labels];
Plot[Sin[x], {x, 0, 6 Pi},
AxesStyle -> {Automatic, Opacity[0]},
TicksStyle -> Opacity[1],
Ticks -> {Automatic, yticks}]

Labeling vertices of a polygon in Mathematica

Given a set of points in the plane T={a1,a2,...,an} then Graphics[Polygon[T]] will plot the polygon generated by the points. How can I add labels to the polygon's vertices? Have merely the index as a label would be better then nothing. Any ideas?
pts = {{1, 0}, {0, Sqrt[3]}, {-1, 0}};
Graphics[
{{LightGray, Polygon[pts]},
{pts /. {x_, y_} :> Text[Style[{x, y}, Red], {x, y}]}}
]
To add point also
pts = {{1, 0}, {0, Sqrt[3]}, {-1, 0}};
Graphics[
{{LightGray, Polygon[pts]},
{pts /. {x_, y_} :> Text[Style[{x, y}, Red], {x, y}, {0, -1}]},
{pts /. {x_, y_} :> {Blue, PointSize[0.02], Point[{x, y}]}}
}
]
update:
Use the index:
pts = {{1, 0}, {0, Sqrt[3]}, {-1, 0}};
Graphics[
{{LightGray, Polygon[pts]},
{pts /. {x_, y_} :>
Text[Style[Position[pts, {x, y}], Red], {x, y}, {0, -1}]}
}
]
Nasser's version (update) uses pattern matching. This one uses functional programming. MapIndexed gives you both the coordinates and their index without the need for Position to find it.
pts = {{1, 0}, {0, Sqrt[3]}, {-1, 0}};
Graphics[
{
{LightGray, Polygon[pts]},
MapIndexed[Text[Style[#2[[1]], Red], #1, {0, -1}] &, pts]
}
]
or, if you don't like MapIndexed, here's a version with Apply (at level 1, infix notation ###).
pts = {{1, 0}, {0, Sqrt[3]}, {-1, 0}};
idx = Range[Length[pts]];
Graphics[
{
{LightGray, Polygon[pts]},
Text[Style[#2, Red], #1, {0, -1}] & ### ({pts, idx}\[Transpose])
}
]
This can be expanded to arbitrary labels as follows:
pts = {{1, 0}, {0, Sqrt[3]}, {-1, 0}};
idx = {"One", "Two", "Three"};
Graphics[
{
{LightGray, Polygon[pts]},
Text[Style[#2, Red], #1, {0, -1}] & ### ({pts, idx}\[Transpose])
}
]
You can leverage the options of GraphPlot for this. Example:
c = RandomReal[1, {3, 2}]
g = GraphPlot[c, VertexLabeling -> True, VertexCoordinateRules -> c];
Graphics[{Polygon#c, g[[1]]}]
This way you can also make use of VertexLabeling -> Tooltip, or VertexRenderingFunction if you want to. If you do not want the edges overlaid, you may add EdgeRenderingFunction -> None to the GraphPlot function. Example:
c = RandomReal[1, {3, 2}]
g = GraphPlot[c, VertexLabeling -> All, VertexCoordinateRules -> c,
EdgeRenderingFunction -> None,
VertexRenderingFunction -> ({White, EdgeForm[Black], Disk[#, .02],
Black, Text[#2, #1]} &)];
Graphics[{Brown, Polygon#c, g[[1]]}]

Arrows for the axes

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]
]

Spherical co-ordinate graphics in Mathematica

Is it possible to create graphics of spherical co-ordinate system like this in mathematica or should I use photoshop? I'm asking because I want a high resolution graphic, but lot of the files on internet are grainy when zoomed.
Here is the image:
The figure is made up of simple geometric shapes and these can be easily recreated in Mathematica using equations. Here is one that is close to this plot, which IMO is less cluttered than the above, but you can always use these ideas to recreate your image exactly.
Clear[ellipsePhi, ellipseTheta, circle]
circle[x_] = {Cos[x], Sin[x]};
ellipsePhi[x_, a_: - Pi/2] = {Cos[x - a]/3, Sin[x + a]};
ellipseTheta[x_, a_: 0] = {Cos[x + a], Sin[-x - a]/2};
(*Main circle*)
ParametricPlot[circle[x], {x, 0, 2 Pi},
PlotStyle -> Black,
Epilog -> First /# {
(*Ellipses*)
ParametricPlot[{ellipsePhi[x], ellipsePhi[-x], ellipseTheta[-x],
ellipseTheta[x]}, {x, 0, Pi},
PlotStyle -> {{Black, Dashed}, Black}],
(*Co-ordinate axes*)
Graphics[
Table[GeometricTransformation[{Arrowheads[0.03],
Arrow[{{0, 0}, {1.2, 0}}]},
ReflectionMatrix[circle[x]]], {x, {Pi/2, -Pi/4, Pi/8}}]],
(*mark point, rho, phi & theta directions*)
ParametricPlot[{ellipsePhi[x, Pi/2], ellipseTheta[-x, 13 Pi/20]}, {x,
0, Pi/4},
PlotStyle -> {{Red, Thick}, {Blue, Thick}}] /.
Line[x__] :> Sequence[Arrowheads[0.03], Arrow[x]],
Graphics[{{Directive[Darker#Green, Thick], Arrowheads[0.03],
Arrow[{{0, 0}, ellipsePhi[-3 Pi/4]}]},
{Directive[Purple], Disk[ellipsePhi[-3 Pi/4], 0.02]}}],
(*text*)
Graphics[{
Text[Style["x", Italic, Larger], 1.25 circle[5 Pi/4]],
Text[Style["y", Italic, Larger], 1.25 circle[0]],
Text[Style["z", Italic, Larger], 1.25 circle[Pi/2]],
Text[Style["\[Rho]", Italic, Larger], 0.4 circle[4 Pi/11]],
Text[Style["\[CurlyPhi]", Italic, Larger],
1.1 ellipsePhi[Pi + Pi/5]],
Text[Style["\[Theta]", Italic, Larger],
1.1 ellipseTheta[13 Pi/20 - Pi/8]],
Text[Style["P", Italic, Larger], 1.2 ellipsePhi[-3 Pi/4 + Pi/24]]}]
},
Axes -> False, PlotRange -> 1.3 {{-1, 1}, {-1, 1}}
]
which gives you this
Although it is possible to set the angles & arrows precisely, in some places (e.g., 13 Pi/20), I've only roughly approximated it. You really can't tell the difference in the final figure, but if you're picky you can change them and fix the positions exactly.
This alternative solution has the advantage of being created using 3D directives. As such, it was easy to wrap inside a Manipulate and you can drag it with your mouse to change the viewpoint:
Manipulate[
Module[{x = Sin[\[Phi]] Cos[\[Theta]], y = Sin[\[Phi]] Sin[\[Theta]],
z = Cos[\[Phi]]},
Show[
ParametricPlot3D[
{{Cos[t], Sin[t], 0},
{0, Sin[t], Cos[t]},
{Sin[t], 0, Cos[t]}},
{t, 0, 2 \[Pi]}, PlotStyle -> Black, Boxed -> False,
Axes -> False, AxesLabel -> {"x", "y", "z"}],
ParametricPlot3D[0.5*{Cos[t], Sin[t], 0}, {t, 0, \[Theta]}],
ParametricPlot3D[
RotationTransform[\[Theta], {0, 0, 1}][{Sin[t]/2, 0,
Cos[t]/2}], {t, 0, \[Phi]}],
Graphics3D[{
{{Blue, Thick,
Arrow[{{0, 0, 0}, #}] & /# {{1, 0, 0}, {0, 1, 0}, {0, 0,
1}, {x, y, z}}},
{Opacity[0.1],
Red, Polygon[{{0, 0, 0}, {x, y, 0}, {x, y, z}}],
Green, Polygon[{{0, 0, 0}, {x, 0, 0}, {x, y, 0}}]}},
{Opacity[0.05], Sphere[{0, 0, 0}]},
{Text["O", {-.03, -.03, -.03}],
Text["X", {1.1, 0, 0}],
Text["Q", {x, y, 0}, {1, 1}],
Text["P", {x, y, z}, {0, -1}],
Text["Y", {0, 1.1, 0}],
Text["Z", {0, 0, 1.1}],
Text["r", {x/2, y/2, 0}, {1, 1}],
Text[
"\[Theta]", {Cos[\[Theta]/2]/2, Sin[\[Theta]/2]/2, 0}, {1,
1}],
Text["\[Phi]",
RotationTransform[\[Theta], {0, 0, 1}][{Sin[\[Phi]/2]/2, 0,
Cos[\[Phi]/2]/2}], {1, 1}]}}]]],
{{\[Phi], \[Pi]/4}, 0.01, \[Pi]/2}, {{\[Theta], \[Pi]/4}, 0.01,
2 \[Pi]}]

Zoom region and display as a subplot within plot

Is it possible to zoom into a region and display it as a subplot within the same plot? Here is my primitive attempt at freehand graphics, to illustrate my question:
I can think of using Plot, and then Epilog, but then I get lost in the positioning and in giving the plot its own origin (When I try Epilog on Plot, the new plot lays on top of the old one, using the old one's origin).
Also, it would be nice if the positioning of the subplot can be input, as different curves have different "empty regions" that can be used to position the image.
I've seen this in several articles and I can do this in MATLAB, but I have no clue how to do it in mma.
Use Inset. Here's an example:
f[x_] = Sum[Sin[3^n x]/2^n, {n, 0, 20}];
x1 = x /. FindRoot[f[x] == -1, {x, -2.1}];
x2 = x /. FindRoot[f[x] == -1, {x, -1.1, -1}];
g = Plot[f[x], {x, x1, x2}, AspectRatio -> Automatic,
Axes -> False, Frame -> True, FrameTicks -> None];
{y1, y2} = Last[PlotRange /. FullOptions[g]];
Plot[Sum[Sin[3^n x]/2^n, {n, 0, 20}], {x, -Pi, Pi},
Epilog -> {Line[{
{{x2, y2 + 0.1}, {-0.5, 0.5}}, {{x1, y2 + 0.1}, {-3.5, 0.5}},
{{x1, y1}, {x2, y1}, {x2, y2 + 0.1}, {x1, y2 + 0.1}, {x1,
y1}}}],
Inset[g, {-0.5, 0.5}, {Right, Bottom}, 3]},
PlotRange -> {{-4, 4}, {-3, 3}}, AspectRatio -> Automatic]
And, borrowing from belisarius' code, you can also select the focus of your inset interactively by selecting a position at the x-axis:
imgsz = 400;
f[x_] := Piecewise[{{Sin#x, Abs#x > .1}, {Sin[100 x], Abs[x] <= 0.1}}];
Manipulate[
Plot[f[x], {x, -3, 3}, PlotRange -> {{-3, 3}, {-2, 5}},
ImageSize -> imgsz,
Epilog ->
Inset[Plot[f[y], {y, p[[1]] - .3, p[[1]] + 0.3}, PlotStyle -> Red,
Axes -> False, Frame -> True, ImageSize -> imgsz/3], {1.5, 3}]],
{{p, {0, 0}}, Locator, Appearance -> None}]
or, if you also want to place the inset interactively:
Manipulate[
Plot[f[x], {x, -3, 3}, PlotRange -> {{-3, 3}, {-2, 5}},
ImageSize -> imgsz,
Epilog ->
Inset[Plot[f[y], {y, p[[1, 1]] - .3, p[[1, 1]] + 0.3},
PlotStyle -> Red, Axes -> False, Frame -> True,
ImageSize -> imgsz/3], p[[2]]]],
{{p, {{0, 0}, {1.5, 3}}}, Locator, Appearance -> None}]
EDIT
one more alternative based on dbjohn's question:
imgsz = 400;
f[x_] := Piecewise[{{Sin#x, Abs#x > .1}, {Sin[100 x], Abs[x] <= 0.1}}];
Manipulate[
Plot[f[x], {x, -3, 3}, PlotRange -> {{-3, 3}, {-2, 5}},
ImageSize -> imgsz,
Epilog ->
Inset[Plot[f[y], {y, p[[1]] - .3, p[[1]] + 0.3}, PlotStyle -> Red,
Axes -> False, Frame -> True, ImageSize -> imgsz/3],
Scaled[zw]]], {{p, {0, 0}}, Locator,
Appearance -> None}, {{zw, {0.5, 0.5}, "Zoom window"}, Slider2D}]
Just a kickstart:
imgsz = 400;
f[x_] := Piecewise[{{Sin#x, Abs#x > .1}, {Sin[100 x], Abs[x] <= 0.1}}];
Plot[f[x], {x, -3, 3}, PlotRange -> {{-5, 5}, {-5, 5}},
ImageSize -> imgsz, Epilog ->
Inset[Plot[f[y], {y, -.3, 0.3}, PlotStyle -> Red, Axes -> False,
Frame -> True, ImageSize -> imgsz/3], {3, 3}]]
I find this an area in need of better built in tools. I have been working on this solution based on a demo here. I prefer to have the zoomed image and unzoomed image separated and as a bonus I added a presentable area where one could put relevant text or equations. For different functions the aspect ratio may need to be tweaked manually.
(f[x_] := x^2;
; xMin = -5; yMin = -5; xMax = 5; yMax = 5;
Manipulate[
Grid[{{LocatorPane[{a},
Plot[f[x], {x, xMin, xMax},
PlotRange -> {{xMin, xMax }, {yMin, yMax}},
ImageSize -> Medium, AspectRatio -> 1, AxesOrigin -> {0, 0}]],
Plot[f[x], {x, (a[[1]]) + xMin*mag, (a[[1]]) + xMax*mag},
PlotRange -> {{(a[[1]]) + xMin*mag, (a[[1]]) +
xMax*mag}, {(a[[2]]) + yMin*mag, (a[[2]]) + yMax*mag}},
ImageSize -> Medium, AspectRatio -> 1, AxesOrigin -> {0, 0}],
Item[StringForm["This is a suitable area to put any text.
Value of A is :
`1` ", a], Alignment -> {Left, Top}]}}, Frame -> All,
ItemSize -> All,
Spacings -> 5], {{a, {0, 0}}, {xMin, yMin}, {xMax, yMax}, Locator,
Appearance ->
Graphics[{Yellow, Opacity[.2],
Rectangle[Scaled[{.5 - (mag/2), .5 - (mag/2)}],
Scaled[{.5 + (mag/2), .5 + (mag/2)}]]}]}, {{mag, .5,
"Magnification"}, 0.01, 1, Appearance -> "Labeled"}])
(f[x_] :=
Piecewise[{{Sin#x, Abs#x > .1}, {Sin[100 x], Abs[x] <= 0.1}}];
; xMin = -3; yMin = -3; xMax = 3; yMax = 3;
Manipulate[
Grid[{{LocatorPane[{a},
Plot[f[x], {x, xMin, xMax},
PlotRange -> {{xMin, xMax }, {yMin, yMax}},
ImageSize -> Medium, AspectRatio -> 1, AxesOrigin -> {0, 0}]],
Plot[f[x], {x, (a[[1]]) + xMin*mag, (a[[1]]) + xMax*mag},
PlotRange -> {(*{(a[[1]])+xMin*mag,(a[[1]])+xMax*
mag},*){(a[[2]]) + yMin*mag, (a[[2]]) + yMax*mag}},
ImageSize -> Medium, AspectRatio -> 1, AxesOrigin -> {0, 0},
Frame -> True],
Item[StringForm["This is a suitable area to put any text.
Value of A is :
`1` ", a], Alignment -> {Left, Top}]}}, Frame -> All,
ItemSize -> All,
Spacings -> 5], {{a, {0, 0}}, {xMin, yMin}, {xMax, yMax}, Locator,
Appearance ->
Graphics[{Yellow, Opacity[.2],
Rectangle[Scaled[{.5 - (mag/2), .5 - (mag/2)}],
Scaled[{.5 + (mag/2), .5 + (mag/2)}]]}]}, {{mag, .06,
"Magnification"}, 0.01, 1, Appearance -> "Labeled"}])

Resources