Related
I am having some problems in plotting this. Everything is ok until the plot statement where nothing plots. Can someone please help me so that it can plot something. The following is my code:
j = 10;
s = 0; r = 0;
B[n_] = Integrate[2*Sin[n*Pi*x]*(x), {x, 0, 1}];
u[x_, psi_] = Sum[B[n]*Sin[n*Pi*x]*Exp[-(n*Pi)^2*psi], {n, 1, j}];
K[x_, psi_] =
Sum[Sin[n*Pi*x]*
Sin[n*Pi*
psi]*(2*Exp[-(n*Pi)^2*
Abs[s + r]] - (Exp[-(n*Pi)^2*Abs[s - r]] -
Exp[-(n*Pi)^2*(s + r)])/(n*Pi)^2 ), {n, 1, j}];
w = RandomReal[NormalDistribution[0, 1], 101];
d = Round[100*x + 1];
S = Total[Total[u[x, psi]/Length[u[x, psi]]] + w[d]]
T[x_, psi_] = Integrate[K[x - y, psi]*(y)*S, {y, -10, 10}]
Plot3D[T[x, psi], {x, 0, 1}, {psi, 0.01, 1},
AxesLabel -> {"x", "t", "Temperature"}, Boxed -> False,
Mesh -> False]
Basically, I have some data from "u" and I want to make it noisy (from "w") for each "x" value and then perform the convolution in "T" and plot.
I will really appreciate anyone's kind help.
Thanks very much!
I'm not sure that I understand the problem you're trying to solve. However, modifying your code as shown below allows it to run - I rephrased several expression to be functions (a good rule of thumb is to use := if the left hand side involves a pattern, like B[n_]) and I removed some code that was apparently trying to treat scalars as vectors.
j = 10; s = 0; r = 0;
ClearAll[B];
B[n_] := B[n] = Integrate[2*Sin[n*Pi*a]*(a), {a, 0, 1}];
ClearAll[u];
u[x_, psi_] := Sum[B[n]*Sin[n*Pi*x]*Exp[-(n*Pi)^2*psi], {n, 1, j}];
K[x_, psi_] :=
Sum[Sin[n*Pi*x]*
Sin[n*Pi*
psi]*(2*Exp[-(n*Pi)^2*Abs[s + r]] - (Exp[-(n*Pi)^2*Abs[s - r]] -
Exp[-(n*Pi)^2*(s + r)])/(n*Pi)^2), {n, 1, j}];
S[x_, psi_] := u[x, psi] + RandomReal[NormalDistribution[]]
T[x_, psi_] := Integrate[K[x - y, psi]*(y)*S[x, psi], {y, -10, 10}]
Plot3D[T[x, psi], {x, 0, 1}, {psi, 0.01, 1},
AxesLabel -> {"x", "t", "Temperature"}, Boxed -> False,
Mesh -> False]
After running for some time (~ 1 hour) it produces the plot below
There is probably a much more efficient way to produce this plot using a more idiomatic approach. If you could provide more detailed information about what you're trying to do with the code you posted, then maybe I or others could give you a more useful answer.
It looks very much as if you are using = where you should be using :=. The former makes an immediate assignment (called Set) the other a delayed assignment (SetDelayed). The difference is fundamental in Mathematica, you should read the documentation until you understand this difference thoroughly.
Here is a template solution based on the outline of your question:
data = RandomInteger[{0, 1}, 100]; (* data creation function *)
noise = RandomVariate[NormalDistribution[0, 1], Length#data]; (* noise vector *)
noisyData = data + noise; (* sum noise and data *)
ListConvolve[data, noisyData] (* apply convolution *)
{8.20928}
How does this prototype match with your goals ?
I need help. I have many variables, that I use in my Graphics[] command, that are dependent of one variable (H in my example). I want to manipulate my graphic so that by changing value of H graphic changes accordingly. But it is not as easy as I've thought.
If you have any idea on how to acomplish this, I would be grateful.
(*This variables are dependent on H that I want to change in
manipulate*)
R = 10;
\[Alpha] = ArcSin[H/R];
p = H/Tan[\[Alpha]];
n = 1.5;
\[Beta] = ArcSin[n Sin[\[Alpha]]];
\[Theta] = \[Beta] - \[Alpha];
l = H/Tan[\[Theta]];
(*This is the graphic I want to make manipulated*)
Graphics[{(*Incident ray*)Line[{{-2, H}, {p, H}}],(*Prism*)
Circle[{0, 0}, R, {0, Pi/2}],
Line[{{0, 0}, {0, 10}}],(*Refracted ray*)
Line[{{p, H}, {p + l, 0}}],(*Surface*)
Line[{{0, 0}, {p + l + 10, 0}}]}]
Here's one of my solutions but it's really messy. What I did is just manually pluged in those values. Is there any more appropriate way to acomplish this:
R = 10;
n = 1.5;
Manipulate[
Graphics[{(*Incident ray*)
Line[{{-2, H}, {H/Tan[ArcSin[H/10]], H}}],(*Prism*)
Circle[{0, 0}, R, {0, Pi/2}],
Line[{{0, 0}, {0, 10}}],(*Refracted ray*)
Line[{{H/Tan[ArcSin[H/10]],
H}, {H/Tan[ArcSin[H/10]] +
H/Tan[ArcSin[n Sin[ArcSin[H/10]]] - ArcSin[H/10]],
0}}],(*Surface*)
Line[{{0,
0}, {H/Tan[ArcSin[H/10]] +
H/Tan[ArcSin[n Sin[ArcSin[H/10]]] - ArcSin[H/10]] + 10,
0}}]}], {H, 0.0001, 10, Appearance -> "Labeled"}]
And also how to make my graphic not to change it's size constantly. I want prism to have fixed size and incident ray to change its position (as it happens when H gets > 6.66 in my example above / this solution).
The question is maybe confusing, but if you try it in Mathematica, you'll see what I want. Thank you for any suggestions.
I think your solution is not bad in general, Mark already noticed in his reply. I loved simplicity of Mark's solution too. Just for the sake of experiment I share my ideas too.
1) It is always a good thing to localize your variables for a specific Manipulate, so their values do not leak and interfere with other dynamic content. It matters if you have additional computation in your notebook - they may start resetting each other.
2) In this particular case if you try to get read of extra variables plugging expressions one into each other your equations became complicated and it is hard to see why they would fail some times. A bit of algebra with help of functions TrigExpand and FullSimplify may help to clarify that your variable H has limitations depending on refraction index value n (see below).
3) If we are aware of point (2) we can make variable n dynamic too and link the value H to n (resetting upper bound of H) right in the controls definition, so always it should be H<10/n . If[..] is also necessary so the controls will not “pink”.
4) If your formulas would depend on R we could also make R dynamic. But I do not have this information, so I localized R via concept of a “dummy“ control (ControlType -> None) – which is quite useful concept for Manipulate.
5) Use PlotRange and ImageSize to stop jiggling of graphics
6) Make it beautiful ;-)
These points would be important if you’d like, for example, to submit a Demonstration to the Wolfram Demonstration Project. If you are just playing around – I think yours and Mark’s solutions are very good.
Thanks,
Vitaliy
Manipulate[If[H >= 10/n, H = 10/n - .0001]; Graphics[{
{Red, Thick, Line[{{-2, H}, {Sqrt[100 - H^2], H}}]},
{Blue, Opacity[.5], Disk[{0, 0}, R, {0, Pi/2}]},
{Red, Thick, Line[{{Sqrt[100 - H^2], H},
{(100 n)/(Sqrt[100 - H^2] n - Sqrt[100 - H^2 n^2]), 0}}]}},
Axes -> True, PlotRange -> {{0, 30}, {0, 10}},
ImageSize -> {600, 200}], {{R, 10}, ControlType -> None},
{{n, 1.5, "Refraction"}, 1.001, 2, Appearance -> "Labeled"},
{{H, 3, "Length"}, 0.0001, 10/n - .0001, Appearance -> "Labeled"}]
I think your first batch of code looks fine and is easy to place into a Manipulate. I would recommend use of the PlotRange option in Graphics.
R = 10;
n = 1.5;
Manipulate[
\[Alpha] = ArcSin[H/R];
p = H/Tan[\[Alpha]];
\[Beta] = ArcSin[n Sin[\[Alpha]]];
\[Theta] = \[Beta] - \[Alpha];
l = H/Tan[\[Theta]];
Graphics[{
Line[{{-2, H}, {p, H}}],(*Prism*)
Circle[{0, 0}, R, {0, Pi/2}],
Line[{{0, 0}, {0, 10}}],(*Refracted ray*)
Line[{{p, H}, {p + l, 0}}],(*Surface*)
Line[{{0, 0}, {p + l + 10, 0}}]},
PlotRange -> {{-1,33},{-1,11}}],
{H,0.0001,6,Appearance->"Labeled"}]
I am wondering if anyone can help me to plot the Cantor dust on the plane in Mathematica. This is linked to the Cantor set.
Thanks a lot.
EDIT
I actually wanted to have something like this:
Here's a naive and probably not very optimized way of reproducing the graphics for the ternary Cantor set construction:
cantorRule = Line[{{a_, n_}, {b_, n_}}] :>
With[{d = b - a, np = n - .1},
{Line[{{a, np}, {a + d/3, np}}], Line[{{b - d/3, np}, {b, np}}]}]
Graphics[{CapForm["Butt"], Thickness[.05],
Flatten#NestList[#/.cantorRule&, Line[{{0., 0}, {1., 0}}], 6]}]
To make Cantor dust using the same replacement rules, we take the result at a particular level, e.g. 4:
dust4=Flatten#Nest[#/.cantorRule&,Line[{{0.,0},{1.,0}}],4]/.Line[{{a_,_},{b_,_}}]:>{a,b}
and take tuples of it
dust4 = Transpose /# Tuples[dust4, 2];
Then we just plot the rectangles
Graphics[Rectangle ### dust4]
Edit: Cantor dust + squares
Changed specs -> New, but similar, solution (still not optimized).
Set n to be a positive integer and choice any subset of 1,...,n then
n = 3; choice = {1, 3};
CanDChoice = c:CanD[__]/;Length[c]===n :> CanD[c[[choice]]];
splitRange = {a_, b_} :> With[{d = (b - a + 0.)/n},
CanD##NestList[# + d &, {a, a + d}, n - 1]];
cantLevToRect[lev_]:=Rectangle###(Transpose/#Tuples[{lev}/.CanD->Sequence,2])
dust = NestList[# /. CanDChoice /. splitRange &, {0, 1}, 4] // Rest;
Graphics[{FaceForm[LightGray], EdgeForm[Black],
Table[cantLevToRect[lev], {lev, Most#dust}],
FaceForm[Black], cantLevToRect[Last#dust /. CanDChoice]}]
Here's the graphics for
n = 7; choice = {1, 2, 4, 6, 7};
dust = NestList[# /. CanDChoice /. splitRange &, {0, 1}, 2] // Rest;
and everything else the same:
Once can use the following approach. Define cantor function:
cantorF[r:(0|1)] = r;
cantorF[r_Rational /; 0 < r < 1] :=
Module[{digs, scale}, {digs, scale} = RealDigits[r, 3];
If[! FreeQ[digs, 1],
digs = Append[TakeWhile[Most[digs]~Join~Last[digs], # != 1 &], 1];];
FromDigits[{digs, scale}, 2]]
Then form the dust by computing differences of F[n/3^k]-F[(n+1/2)/3^k]:
With[{k = 4},
Outer[Times, #, #] &[
Table[(cantorF[(n + 1/2)/3^k] - cantorF[(n)/3^k]), {n, 0,
3^k - 1}]]] // ArrayPlot
I like recursive functions, so
cantor[size_, n_][pt_] :=
With[{s = size/3, ct = cantor[size/3, n - 1]},
{ct[pt], ct[pt + {2 s, 0}], ct[pt + {0, 2 s}], ct[pt + {2 s, 2 s}]}
]
cantor[size_, 0][pt_] := Rectangle[pt, pt + {size, size}]
drawCantor[n_] := Graphics[cantor[1, n][{0, 0}]]
drawCantor[5]
Explanation: size is the edge length of the square the set fits into. pt is the {x,y} coordinates of it lower left corner.
I am looking to plot something like the whispering gallery modes -- a 2D cylindrically symmetric plot in polar coordinates. Something like this:
I found the following code snippet in Trott's symbolics guidebook. Tried running it on a very small data set; it ate 4 GB of memory and hosed my kernel:
(* add points to get smooth curves *)
addPoints[lp_][points_, \[Delta]\[CurlyEpsilon]_] :=
Module[{n, l}, Join ## (Function[pair,
If[(* additional points needed? *)
(l = Sqrt[#. #]&[Subtract ## pair]) < \[Delta]\[CurlyEpsilon], pair,
n = Floor[l/\[Delta]\[CurlyEpsilon]] + 1;
Table[# + i/n (#2 - #1), {i, 0, n - 1}]& ## pair]] /#
Partition[If[lp === Polygon,
Append[#, First[#]], #]&[points], 2, 1])]
(* Make the plot circular *)
With[{\[Delta]\[CurlyEpsilon] = 0.1, R = 10},
Show[{gr /. (lp : (Polygon | Line))[l_] :>
lp[{#2 Cos[#1], #2 Sin[#1]} & ###(* add points *)
addPoints[lp][l, \[Delta]\[CurlyEpsilon]]],
Graphics[{Thickness[0.01], GrayLevel[0], Circle[{0, 0}, R]}]},
DisplayFunction -> $DisplayFunction, Frame -> False]]
Here, gr is a rectangular 2D ListContourPlot, generated using something like this (for example):
data = With[{eth = 2, er = 2, wc = 1, m = 4},
Table[Re[
BesselJ[(Sqrt[eth] m)/Sqrt[er], Sqrt[eth] r wc] Exp[
I m phi]], {r, 0, 10, .2}, {phi, 0, 2 Pi, 0.1}]];
gr = ListContourPlot[data, Contours -> 50, ContourLines -> False,
DataRange -> {{0, 2 Pi}, {0, 10}}, DisplayFunction -> Identity,
ContourStyle -> {Thickness[0.002]}, PlotRange -> All,
ColorFunctionScaling -> False]
Is there a straightforward way to do cylindrical plots like this?.. I find it hard to believe that I would have to turn to Matlab for my curvilinear coordinate needs :)
Previous snippets deleted, since this is clearly the best answer I came up with:
With[{eth = 2, er = 2, wc = 1, m = 4},
ContourPlot[
Re[BesselJ[(Sqrt[eth] m)/Sqrt[er], Sqrt[eth] r wc] Exp[I phi m]]/.
{r ->Norm[{x, y}], phi ->ArcTan[x, y]},
{x, -10, 10}, {y, -10, 10},
Contours -> 50, ContourLines -> False,
RegionFunction -> (#1^2 + #2^2 < 100 &),
ColorFunction -> "SunsetColors"
]
]
Edit
Replacing ContourPlot by Plot3D and removing the unsupported options you get:
This is a relatively straightforward problem. The key is that if you can parametrize it, you can plot it. According to the documentation both ListContourPlot and ListDensityPlot accept data in two forms: an array of height values or a list of coordinates plus function value ({{x, y, f} ..}). The second form is easier to deal with, such that even if your data is in the first form, we'll transform it into the second form.
Simply, to transform data of the form {{r, t, f} ..} into data of the form {{x, y, f} ..} you doN[{#[[1]] Cos[ #[[2]] ], #[[1]] Sin[ #[[2]] ], #[[3]]}]& /# data, when applied to data taken from BesselJ[1, r/2] Cos[3 t] you get
What about when you just have an array of data, like this guy? In that case, you have a 2D array where each point in the array has known location, and in order to plot it, you have to turn it into the second form. I'm partial to MapIndexed, but there are other ways of doing it. Let's say your data is stored in an array where the rows correspond to the radial coordinate and the columns are the angular coordinate. Then to transform it, I'd use
R = 0.01; (*radial increment*)
T = 0.05 Pi; (*angular increment*)
xformed = MapIndexed[
With[{r = #2[[1]]*R, t = #2[[1]]*t, f = #1},
{r Cos[t], r Sin[t], f}]&, data, {2}]//Flatten[#,1]&
which gives the same result.
If you have an analytic solution, then you need to transform it to Cartesian coordinates, like above, but you use replacement rules, instead. For instance,
ContourPlot[ Evaluate[
BesselJ[1, r/2]*Cos[3 t ] /. {r -> Sqrt[x^2 + y^2], t -> ArcTan[x, y]}],
{x, -5, 5}, {y, -5, 5}, PlotPoints -> 50,
ColorFunction -> ColorData["DarkRainbow"], Contours -> 25]
gives
Two things to note: 1) Evaluate is needed to ensure that the replacement is performed correctly, and 2) ArcTan[x, y] takes into account the quadrant that the point {x,y} is found in.
Inspired by this question at ask.sagemath, what is the best way of adding arrows to the end of curves produced by Plot, ContourPlot, etc...? These are the types of plots seen in high school, indicating the curve continues off the end of the page.
After some searching, I could not find a built-in way or up-to-date package to do this. (There is ArrowExtended, but it's quite old).
The solution given in the ask.sagemath question relies on the knowledge of the function and its endpoints and (maybe) the ability to take derivatives. Its translation into Mathematica is
f[x_] := Cos[12 x^2]; xmin = -1; xmax = 1; small = .01;
Plot[f[x],{x,xmin,xmax}, PlotLabel -> y==f[x], AxesLabel->{x,y},
Epilog->{Blue,
Arrow[{{xmin,f[xmin]},{xmin-small,f[xmin-small]}}],
Arrow[{{xmax,f[xmax]},{xmax+small,f[xmax+small]}}]
}]
An alternative method is to simply replace the Line[] objects generate by Plot[] with Arrow[]. For example
Plot[{x^2, Sin[10 x], UnitStep[x]}, {x, -1, 1},
PlotStyle -> {Red, Green, {Thick, Blue}},
(*AxesStyle -> Arrowheads[.03],*) PlotRange -> All] /.
Line[x__] :> Sequence[Arrowheads[{-.04, .04}], Arrow[x]]
But this has the problem that any discontinuities in the lines generate arrow heads where you don't want them (this can often be fixed by the option Exclusions -> None). More importantly, this approach is hopeless with CountourPlots. Eg try
ContourPlot[x^2 + y^3 == 1, {x, -2, 2}, {y, -2, 1}] /.
Line[x__] :> Sequence[Arrowheads[{-.04, .04}], Arrow[x]]
(the problems in the above case can be fixed by the rule, e.g., {a___, l1_Line, l2_Line, b___} :> {a, Line[Join[l2[[1]], l1[[1]]]], b} or by using appropriate single headed arrows.).
As you can see, neither of the above (quick hacks) are particularly robust or flexible. Does anyone know an approach that is?
The following seems to work, by sorting the segments first:
f[x_] := {E^-x^2, Sin[10 x], Sign[x], Tan[x], UnitBox[x],
IntegerPart[x], Gamma[x],
Piecewise[{{x^2, x < 0}, {x, x > 0}}], {x, x^2}};
arrowPlot[f_] :=
Plot[{#}, {x, -2, 2}, Axes -> False, Frame -> True, PlotRangePadding -> .2] /.
{Hue[qq__], a___, x___Line} :> {Hue[qq], a, SortBy[{x}, #[[1, 1, 1]] &]} /.
{a___,{Line[x___], d___, Line[z__]}} :>
List[Arrowheads[{-.06, 0}], a, Arrow[x], {d},
Arrowheads[{0, .06}], Arrow[z]] /.
{a___,{Line[x__]}}:> List[Arrowheads[{-.06, 0.06}], a, Arrow[x]] & /# f[x];
arrowPlot[f]
Inspired by both Alexey's comment and belisarius's answers, here's my attempt.
makeArrowPlot[g_Graphics, ah_: 0.06, dx_: 1*^-6, dy_: 1*^-6] :=
Module[{pr = PlotRange /. Options[g, PlotRange], gg, lhs, rhs},
gg = g /. GraphicsComplex -> (Normal[GraphicsComplex[##]] &);
lhs := Or##Flatten[{Thread[Abs[#[[1, 1, 1]] - pr[[1]]] < dx],
Thread[Abs[#[[1, 1, 2]] - pr[[2]]] < dy]}]&;
rhs := Or##Flatten[{Thread[Abs[#[[1, -1, 1]] - pr[[1]]] < dx],
Thread[Abs[#[[1, -1, 2]] - pr[[2]]] < dy]}]&;
gg = gg /. x_Line?(lhs[#]&&rhs[#]&) :> {Arrowheads[{-ah, ah}], Arrow##x};
gg = gg /. x_Line?lhs :> {Arrowheads[{-ah, 0}], Arrow##x};
gg = gg /. x_Line?rhs :> {Arrowheads[{0, ah}], Arrow##x};
gg
]
We can test this on some functions
Plot[{x^2, IntegerPart[x], Tan[x]}, {x, -3, 3}, PlotStyle -> Thick]//makeArrowPlot
And on some contour plots
ContourPlot[{x^2 + y^2 == 1, x^2 + y^2 == 6, x^3 + y^3 == {1, -1}},
{x, -2, 2}, {y, -2, 2}] // makeArrowPlot
One place where this fails is where you have horizontal or vertical lines on the edge of the plot;
Plot[IntegerPart[x],{x,-2.5,2.5}]//makeArrowPlot[#,.03]&
This can be fixed by options such as PlotRange->{-2.1,2.1} or Exclusions->None.
Finally, it would be nice to add an option so that each "curve" can arrow heads only on their boundaries. This would give plots like those in Belisarius's answer (it would also avoid the problem mentioned above). But this is a matter of taste.
The following construct has the advantage of not messing with the internal structure of the Graphics structure, and is more general than the one suggested in ask.sagemath, as it manage PlotRange and infinities better.
f[x_] = Gamma[x]
{plot, evals} =
Reap[Plot[f[x], {x, -2, 2}, Axes -> False, Frame -> True,
PlotRangePadding -> .2, EvaluationMonitor :> Sow[{x, f[x]}]]];
{{minX, maxX}, {minY, maxY}} = Options[plot, PlotRange] /. {_ -> y_} -> y;
ev = Select[evals[[1]], minX <= #[[1]] <= maxX && minY <= #[[2]] <= maxY &];
seq = SortBy[ev, #[[1]] &];
arr = {Arrow[{seq[[2]], seq[[1]]}], Arrow[{seq[[-2]], seq[[-1]]}]};
Show[plot, Graphics[{Red, arr}]]
Edit
As a function:
arrowPlot[f_, interval_] := Module[{plot, evals, within, seq, arr},
within[p_, r_] :=
r[[1, 1]] <= p[[1]] <= r[[1, 2]] &&
r[[2, 1]] <= p[[2]] <= r[[2, 2]];
{plot, evals} = Reap[
Plot[f[x], Evaluate#{x, interval /. List -> Sequence},
Axes -> False,
Frame -> True,
PlotRangePadding -> .2,
EvaluationMonitor :> Sow[{x, f[x]}]]];
seq = SortBy[Select[evals[[1]],
within[#,
Options[plot, PlotRange] /. {_ -> y_} -> y] &], #[[1]] &];
arr = {Arrow[{seq[[2]], seq[[1]]}], Arrow[{seq[[-2]], seq[[-1]]}]};
Show[plot, Graphics[{Red, arr}]]
];
arrowPlot[Gamma, {-3, 4}]
Still thinking what is better for ListPlot & al.