Related
I am trying to plot a few points on the following picture in Mathematica:
ParametricPlot3D[
{{u, v, (Cos[u] + Cos[v])/3}, {u, -1, (Cos[u] + Cos[0])/3},
{5, v, (Cos[4] + Cos[v])/3}}, {u, -4, 4}, {v, 0, 8}, Axes -> False,
Boxed -> False, BoxRatios -> {8, 8, 1.5}]
(they should just look like dots on the surface)
What I was trying to do is enter the coordinates of the points manually on another graph using ListPointPlot3D, and then combine them using Show. But for some reason that isn't working. Suggestions?
Also, I would like to add small vectors tangent to the surface in the x directions for the points I have plotted, but I have no idea on how to do that, so suggestions would be very much appreciated!
Perhaps this will help you get started on a solution. It plots 3 random points on the surface. You can change the number of points by setting nPoints. I don't know how to plot tangents along x. But when you figure that out you can use Arrows, as suggested by #Verbeia.
nPoints = 3;
Show[ParametricPlot3D[{
{u, v, (Cos[u] + Cos[v])/3},
{u, -1, (Cos[u] + Cos[0])/3}, {5, v, (Cos[4] + Cos[v])/3}},
{u, -4, 4}, {v, 0, 8}, Axes -> False,
Boxed -> False, BoxRatios -> {8, 8, 1.5},
PlotStyle -> Directive[Opacity[0.5]]],
Graphics3D[{Red, PointSize[.025],
Point[Table[{u1 = RandomReal[{-3, 3}], v1 = RandomReal[{1, 7}],
(Cos[u1] + Cos[v1])/3}, {nPoints}]]}]]
Edit
The following dynamic variation makes use of #belisarius 's contribution:
Manipulate[
Show[ParametricPlot3D[{{u, v, (Cos[u] + Cos[v])/3} },
{u, -4, 4}, {v, 0, 8}, Axes -> False, Boxed -> False,
BoxRatios -> {8, 8, 1.5},
Mesh -> None,
ImageSize -> {400, 300},
PlotRange -> {{-4, 4}, {0, 8}},
PlotRangePadding -> {{0, 1.4}, {0, 0}},
PlotStyle -> Directive[Opacity[0.5]]],
Graphics3D[({Red, PointSize[.025],
Point#f[pt[[1, 1]], pt[[1, 2]]], Black,
Arrow[{f[pt[[1, 1]], pt[[1, 2]]],
f[pt[[1, 1]], pt[[1, 2]]] + D[f[t, pt[[1, 2]]], t] /.
t -> pt[[1, 1]]}]}]],
Grid[{{
LocatorPane[Dynamic[pt],
Dynamic[Graphics[{},
PlotRange -> {{-4, 4}, {0, 8}},
Frame -> True,
ImageSize -> 160,
FrameTicks -> {Range[-4, 4], Range[0, 8], None, None},
FrameLabel -> {"u", "v"},
GridLines -> {Range[-4, 4], Range[0, 8]},
GridLinesStyle -> Directive[LightGray]]],
{{-4, 0}, {4, 8}}]}}],
{{pt, {{1, 2}}}, ControlType -> None},
Initialization :> {f[u_, v_] := {u, v, (Cos[u] + Cos[v])/3};}]
For the Arrows
f[u_, v_] := {u, v, (Cos[u] + Cos[v])/3};
Show[ParametricPlot3D[{f[u, v]}, {u, -4, 4}, {v, 0, 8},
Axes -> False, Mesh -> None, Boxed -> False, BoxRatios -> {8, 8, 1.5},
PlotStyle -> Directive[Opacity[0.5]]],
Graphics3D#
Table[{Red, PointSize[.025], Point#f[u, v],
Black, Arrow[{f[u, v], f[u, v] + D[f[t, v], t] /. t -> u}]},
{u, -4, 4, 2}, {v, 0, 8, 2}]]
For getting the arrows in any direction a = { a1, a2 } instead of x, you may do:
Dot[{a1,a2}.#] & /# D[f[u, v], {{u, v}}]
(*
-> {a1, a2, -(1/3) a1 Sin[u] - 1/3 a2 Sin[v]}
*)
Edit
Both derivatives and normal:
f[u_, v_] := {u, v, (Cos[u] + Cos[v])/3};
Show[
Graphics3D#
Table[{Red, PointSize[.025], Point#f[u, v], Black, Arrowheads[.02],
Arrow[{f[u, v], f[u, v] + D[f[t, v], t] /. t -> u}],
Arrow[{f[u, v], f[u, v] + D[f[u, t], t] /. t -> v}],
Arrow[{f[u, v], f[u, v] +
Cross[D[f[t, v], t] /. t -> u,
D[f[u, t], t] /. t -> v]}]},
{u, -4, 4, 2}, {v, 0, 8, 2}],
ParametricPlot3D[{f[u, v]}, {u, -4, 4}, {v, 0, 8},
Axes -> False, Mesh -> 3, MeshStyle -> {{Opacity[0.1], LightBlue}},
Boxed -> False, BoxRatios -> {8, 8, 1.5},
PlotStyle -> Directive[Opacity[0.5]]]]
You can combine the plot with points using Graphics3D[listofpoints], where listofpoints is a T*3 matrix list, and the arrows using constructs like Graphics3D[Arrow[{{1, 1, -1}, {2, 2, 0}, {3, 3, -1}, {4, 4, 0}}]]. If they are all Graphics3D objects, you should be able to combine them with Show.
Sorry, I am not near a Mathematica installation to provide you with an example just now.
I want to look at both the real and imaginary parts of some functions that depend on a parameter n. Individually (with set values of n), I get perfectly nice graphs, but when putting them in a Manipulate they become very small.
Here is the exact code I'm using; remove the manipulate and the graphs display at a good size, but with it they are too small to be legible.
Manipulate[
Plot3D[Im[Sqrt[-1 + (x + I y)^2 n]], {x, -2, 2}, {y, -1, 1},
AxesLabel -> Automatic]
Plot3D[Re[Sqrt[-1 + (x + I y)^2 n]], {x, -2, 2}, {y, -2, 2},
AxesLabel -> Automatic]
, {n, 1, 10, 1}]
Why is it doing this, and how can I fix it?
Manipulate[
Row[{
Plot3D[Im[Sqrt[-1 + (x + I y)^2 n]], {x, -2, 2}, {y, -1, 1},
AxesLabel -> Automatic, ImageSize -> 300] ,
Plot3D[Re[Sqrt[-1 + (x + I y)^2 n]], {x, -2, 2}, {y, -2, 2},
AxesLabel -> Automatic, ImageSize -> 300]}],
{n, 1, 10, 1}]
Edit
Remember that you may also do something like:
a = Sequence ##{{x, -2, 2}, {y, -1, 1}, AxesLabel-> Automatic, ImageSize-> 200};
Manipulate[
Row[{
Plot3D[Im[Sqrt[-1 + (x + I y)^2 n]], Evaluate#a],
Plot3D[Re[Sqrt[-1 + (x + I y)^2 n]], Evaluate#a]}],
{n, 1, 10, 1},
PreserveImageOptions -> False]
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]]}]
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"}])
Say I have three lists: a={1,5,10,15} b={2,4,6,8} and c={1,1,0,1,0}. I want a plot which has a as the x axis, b as the y axis and a red/black dot to mark 1/0. For. e.g. The coordinate (5,4) will have a red dot.
In other words the coordinate (a[i],b[i]) will have a red/black dot depending on whether c[i] is 1 or 0.
I have been trying my hand with ListPlot but can't figure out the options.
I suggest this.
a = {1, 5, 10, 15};
b = {2, 4, 6, 8};
c = {1, 1, 0, 1};
Graphics[
{#, Point#{##2}} & ###
Thread#{c /. {1 -> Red, 0 -> Black}, a, b},
Axes -> True, AxesOrigin -> 0
]
Or shorter but more obfuscated
Graphics[
{Hue[1, 1, #], Point#{##2}} & ### Thread#{c, a, b},
Axes -> True, AxesOrigin -> 0
]
Leonid's idea, perhaps more naive.
f[a_, b_, c_] :=
ListPlot[Pick[Transpose[{a, b}], c, #] & /# {0, 1},
PlotStyle -> {PointSize[Large], {Blue, Red}}]
f[a, b, c]
Edit: Just for fun
f[h_, a_, b_, c_, opt___] :=
h[Pick[Transpose[{a, b}], c, #] & /# {0, 1},
PlotStyle -> {PointSize[Large], {Blue, Red}}, opt]
f[ ListPlot,
Sort#RandomReal[1, 100],
Sin[(2 \[Pi] #)/100] + RandomReal[#/100] & /# Range[100],
RandomInteger[1, 100],
Joined -> True,
InterpolationOrder -> 2,
Filling -> Axis]
Here are your points:
a = {1, 5, 10, 15};
b = {2, 4, 6, 8};
c = {1, 1, 0, 1};
(I deleted the last element from c to make it the same length as a and b). What I'd suggest is to separately make images for points with zeros and ones and then combine them - this seems easiest in this situation:
showPoints[a_, b_, c_] :=
With[{coords = Transpose[{a, b}]},
With[{plotF = ListPlot[Pick[coords, c, #], PlotMarkers -> Automatic, PlotStyle -> #2] &},
Show[MapThread[plotF, {{0, 1}, {Black, Red}}]]]]
Here is the usage:
showPoints[a, b, c]
One possibility:
ListPlot[List /# Transpose[{a, b}],
PlotMarkers -> {1, 1, 0, 1} /. {1 -> { Style[\[FilledCircle], Red], 10},
0 -> { { Style[\[FilledCircle], Black], 10}}},
AxesOrigin -> {0, 0}]
Giving as output:
You could obtain similar results (to those of Leonid) using Graphics:
Graphics[{PointSize[.02], Transpose[{(c/. {1 -> Red, 0 -> Black}),
Point /# Transpose[{a, b}]}]},
Axes -> True, AxesOrigin -> {0, 0}]