Community RSS Feed
http://community.wolfram.com
RSS Feed for Wolfram Community showing any discussions in tag Graphics and Visualization sorted by activePresentation on parallel projections with interactive elements
http://community.wolfram.com/groups/-/m/t/823652
Hello, I would like to share my presentation on parallel projections with Interactive elements. This is resource is for future primary school teachers. It is in Russian but I hope it is still useful.
![enter image description here][1]
![enter image description here][2]
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=sdf435rtsgfadsrtwh.gif&userId=11733
[2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=sdf35464yhrgfds.gif&userId=11733Nadejzhda Assonova2016-03-15T10:09:05ZAvoid kernel crash when calculating sum of HypergeometricPFQ functions?
http://community.wolfram.com/groups/-/m/t/1070255
Why does the kernel crash and exit when I try to run the last three evaluations in the attached notebook?
Does anyone have any suggestions as to how I can get around this obstacle?
I'm running Mathematica 11 Home Edition on Ubuntu 16.04 LTS on an Intel i5 processor:
Version Number: 11.0.0.0
Platform: Linux x86 (64-bit)
Here's an extract of the definition of the function.
fSum[y_, imax_] := Block[{i = 1, isum = 0},
While[i <= imax,
isum += (HypergeometricPFQ[{3/4 + 1/2 I Im[ZetaZero[i]]}, {1,
7/4 + 1/2 I Im[ZetaZero[i]]}, -(y^2/4)]/(-3 I +
2 Im[ZetaZero[i]]) -
HypergeometricPFQ[{3/4 - 1/2 I Im[ZetaZero[i]]}, {1,
7/4 - 1/2 I Im[ZetaZero[i]]}, -(y^2/4)]/(
3 I + 2 Im[ZetaZero[i]])); i++];
2 I isum]
Here's an extract of the evaluation which causes the problem. I can run an evaluation with imax=45, but not with imax=46.
Plot[N[fSum[y, 46]], {y, 0, 50}, GridLines -> Automatic,
PlotPoints -> 200, MaxRecursion -> 0]Steven Clark2017-04-23T23:34:02ZMechanisms of deposition of material unto surfaces
http://community.wolfram.com/groups/-/m/t/1070065
Long time ago I was asked to look theoretically at the question whether short time (that means cheap) deposition experiments could be used to differentiate between several (intensely discussed at that time) mechanisms of deposition of material unto surfaces.
They can not.
This is quite a time ago, anyhow I decided to publish the attached notebook, which confirms the above conclusion, but on the other hand shows the threefold superior abilities of Mathematica (symbolical computation, numerical computation, acting like a text system) in preparing such a report.
And perhaps it could be useful for people looking for solving the Diffusion Equation for some special environments.Hans Dolhaine2017-04-23T20:29:25ZThe Chaos Game - Sierpinski triangles and beyond - part I
http://community.wolfram.com/groups/-/m/t/1025180
EDIT: See also the follow up posts [here.][1] and [here][2].
![enter image description here][3]
Roughly 8-9 years ago a friend of mine told me I could make the Sierpinski triangle by starting at one of the vertices of an equilateral triangle, and then repeatedly jump half-way to one of the (randomly chosen) vertices.
## 0 memory ##
The following code will accomplish that:
ClearAll[sequence]
sequence[n_,m_]:=RandomChoice[Range[n],m]
pts=N@CirclePoints[3];
pts=FoldList[(#1+pts[[#2]])/2&,RandomChoice[pts],sequence[3,10]]
Graphics[{{FaceForm[],EdgeForm[Black],RegularPolygon[3]},Red,Arrow[Partition[pts,2,1]]}]
giving:
![enter image description here][4]
If one does this 1000s of time, and only mark the viewed points, one will get:
ClearAll[sequence]
sequence[n_,m_]:=RandomChoice[Range[n],m]
pts=N@CirclePoints[3];
pts=FoldList[(#1+pts[[#2]])/2&,RandomChoice[pts],sequence[3,25000]];
Graphics[{FaceForm[],EdgeForm[Black],RegularPolygon[3],PointSize[0.001],Point[pts]}]
giving:
![enter image description here][5]
Which will indeed show that by randomly choosing a vertex we can still get structure! Quite a surprise! Of course we can do this with squares, pentagons, hexagons et cetera:
ClearAll[sequence]
sequence[n_,m_]:=RandomChoice[Range[n],m]
Table[
circlepoints=N@CirclePoints[n];
pts=FoldList[(#1+circlepoints[[#2]])/2&,RandomChoice[circlepoints],sequence[n,50000]];
Rasterize[Graphics[{FaceForm[],EdgeForm[Black],RegularPolygon[n],PointSize[0.001],Point[pts]},ImageSize->500,PlotRange->1.1],"Image"]
,
{n,3,8}
] // Partition[#, 3] & // ImageAssemble
giving:
![enter image description here][6]
Very neat! (apart from 4, which just gives a homogeneous distribution of points). Here I run the pentagon many many points and high resolution to get:
![enter image description here][7]
Where now the gray-color represents the density of points.
## 0 memory - restricted ##
Now we can make the dynamics a bit more interesting by not moving to any other vertex but to only specific vertices. Imagine that we are at some position p, then we always have n choices (n being the number of sides): we can jump to the vertex 1 ahead, 2 ahead, .... n ahead (same as last time).
ClearAll[CreateSequence,CreateSequenceImage]
CreateSequence[n_,steps_,choices_]:=Mod[Accumulate[RandomChoice[choices,steps-1]~Prepend~1],n,1]
CreateSequenceImage[n_,m_,choices_]:=Module[{seq,pts},
seq=CreateSequence[n,m,choices];
pts=N@CirclePoints[n];
seq=FoldList[(#1+pts[[#2]])/2&,First[pts],seq];
Rasterize[Graphics[{PointSize[0.001],Point[seq]},ImageSize->500,PlotRange->1],"Image",RasterSize->{300,300}]
]
For a 3 sided polygon (i've been told these are called triangles) we can jump 1, 2, or 3 ahead or subsets of that:
Grid[Join@@@Partition[{#,CreateSequenceImage[3,10^5,#]}&/@Subsets[Range[3],{1,\[Infinity]}],UpTo[3]],Frame->All]
![enter image description here][8]
Some interesting structure can be seen for some of the subsets.
For squares:
Grid[Join@@@Partition[{#,CreateSequenceImage[4,10^5,#]}&/@Subsets[Range[4],{1,\[Infinity]}],UpTo[4]],Frame->All]
![enter image description here][9]
and for pentagons:
Grid[Join@@@Partition[{#,CreateSequenceImage[5,10^5,#]}&/@Subsets[Range[5],{1,\[Infinity]}],UpTo[4]],Frame->All]
![enter image description here][10]
the higher the number of sides, the more subsets we can choose. The number of subsets scales as 2^n -1 (minus one because the set can not be empty; we have to jump somewhere!).
Lastly, for hexagons:
Grid[Join@@@Partition[{#,CreateSequenceImage[5,10^5,#]}&/@Subsets[Range[5],{1,\[Infinity]}],UpTo[4]],Frame->All]
![enter image description here][11]
Ok, you can try polygons with large number of sides on your own, but note that the number of subsets doubles every time.
## 1 memory - restricted ##
We can even go beyond this, and consider the position of the penultimate vertex as well:
![enter image description here][12]
We can consider 5 cases for a pentagon (or, in general, n cases). We will consider the last point to be at position 0 (or n), now the penultimate vertex could be in 5 different positions. For each of these combinations we can choose a different subset of {1,2,3,4,5}. Just to get an idea how many possibilities we now have:
the number of subsets is 2^n - 1, and we have to choose n of these, so there will be (2^n-1)^n different systems to explore:
Table[{n, (2^n - 1)^n}, {n, 3, 8}] // Grid
![enter image description here][13]
as one can see, the combination grow very quickly.
ClearAll[Stamp,CreateSequence2,CreateSequenceImage2]
CreateSequence2[n_,m_,start:{start1_,start2_},choices_]:=Module[{out,last, penultimate,new,pos2},
{penultimate,last}=out=start;
out=Reap[Do[
pos2=Mod[penultimate-last,n,1];
new=Mod[last+RandomChoice[choices[[pos2]]],n,1];
penultimate=last;
last=new;
Sow[new]
,
{m-2}
]][[2,1]];
Join[start,out]
]
Stamp[n_,choices_]:=Module[{},
Image[Normal[SparseArray[Thread[Join@@MapThread[Thread[{#1,#2}]&,{Range[Length[choices]],choices}]->1],{n,n}]]]
]
CreateSequenceImage2[n_,m_,start:{start1_,start2_},choices_]:=Module[{seq,pts,ras,stamp},
seq=CreateSequence2[n,m,start,choices];
pts=N@CirclePoints[n];
seq=FoldList[(#1+pts[[#2]])/2&,First[pts],seq];
ras=Rasterize[Graphics[{PointSize[0.001],Point[seq]},ImageSize->500,PlotRange->1],"Image",RasterSize->{300,300}];
stamp=ImagePad[Stamp[n,choices],1,Red];
ImageCompose[ras,stamp,{Center,Bottom},{Center,Bottom}]
]
Before looking at the general case, we can look at a small subset, namely one can **not** jump i ahead from the last, and j ahead from the penultimate. Here the example for i=1, and j =3:
ClearAll[JumpPos2]
JumpPos2[n_,{d1_,d2_}]:=Module[{pos},
pos=Range[n];
pos=DeleteCases[pos,d1];
DeleteCases[pos,Mod[d2+#,n,1]]&/@Range[n]
]
CreateSequenceImage2[4,10^4,{1,2},JumpPos2[4,{1,3}]]
![enter image description here][14]
Very neat structure! Of course we can try all i and j from the set {1,2,3,4}:
delta=Tuples[Range[4],2];
deltas=JumpPos2[4,#]&/@delta;
Grid[Join@@@Table[{{i,j},CreateSequenceImage2[4,10^4,{1,2},JumpPos2[4,{i,j}]]},{i,4},{j,4}],Frame->All]
![enter image description here][15]
All very neat, but it is just a small subset of the 50625 possibilities. Here let's try 64 random ones:
sc=Reverse@Subsets[Range[4],{1,\[Infinity]}];
Table[
CreateSequenceImage2[4,10^4,{1,2},RandomChoice[sc,4]]
,
{64}
] // Partition[#,8]& // ImageAssemble
![enter image description here][16]
As you can see very nice and rich structure! Notice that I 'stamped' all of them with their 'input':
CreateSequenceImage2[4, 10^4, {1, 2}, {{1, 4}, {3}, {1, 3, 4}, {1, 2, 3}}]
![enter image description here][17]
And if one looks closely (save the image and zoom), one will see the 'stamp' (or the rule) at the bottom:
![enter image description here][18]
This can be read as follows:
- The first (top) line, the white pixels are in places 1 and 4, so if the penultimate vertex was '1', move 1 or 4 places from the last vertex
- The 2nd line, the white pixel is in place 3, jump the position 3 ahead compared to last vertex
- 3rd line, white pixel at 1,3, and 4.
- 4th line 1, 2, or 3.
Basically the nth line corresponds to the position of the penultimate vertex. and the white pixels corresponds to 'allowed' number of jumps.
I'll stop here for now. There are many more ideas to explore, I'll name a few:
- <s>3D positions, 3D images</s> See below the post of Henrik!
- Anything other than regular polygons
- Have different probabilities for each of the vertices...
- Move in the perpendicular direction
- ...
See also the follow up posts [here.][19] and [here][20] and some additional visualizations below!
[1]: http://community.wolfram.com/groups/-/m/t/1039030
[2]: http://community.wolfram.com/groups/-/m/t/1047603
[3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=opener.png&userId=73716
[4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial1.png&userId=73716
[5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial2.png&userId=73716
[6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=3446trial3.png&userId=73716
[7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial4b.jpg&userId=73716
[8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial5.png&userId=73716
[9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial6.png&userId=73716
[10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial7.png&userId=73716
[11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial8.png&userId=73716
[12]: http://community.wolfram.com//c/portal/getImageAttachment?filename=explanation-01.png&userId=73716
[13]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial9.png&userId=73716
[14]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial10.png&userId=73716
[15]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial11.png&userId=73716
[16]: http://community.wolfram.com//c/portal/getImageAttachment?filename=5983trial12.png&userId=73716
[17]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial13.png&userId=73716
[18]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial14.png&userId=73716
[19]: http://community.wolfram.com/groups/-/m/t/1039030
[20]: http://community.wolfram.com/groups/-/m/t/1047603Sander Huisman2017-03-04T21:41:21Z[✓] Plot multiple functions (2D and 3D)?
http://community.wolfram.com/groups/-/m/t/1069828
Hi!
I can't get the graphing functions to quite work.
I want to plot three simple functions that look something like this:
x^2+2y-3z=8, x+y=10, 3z+7y=20
And I want to show them in both 2D and 3D graphs where they intersect, (ex: in x=3, y=8, z=10), how do I do that?
I was looking at the Plot and LogPlot command, but I am not quite sure I am looking at the right placeJonas Eriksson2017-04-22T19:02:44Z[GIF] Horizon (Marching lines)
http://community.wolfram.com/groups/-/m/t/1070002
![Marching lines][1]
**Horizon**
This is essentially the exact same code as [_Stay Upright_][2]; the only real difference is that it's viewed from a different perspective.
Here's the code:
DynamicModule[{n = 100, a = π/4, viewpoint = {1, -1, 0}, θ = π, range = 8, plane,
cols = RGBColor /@ {"#F71735", "#FDFFFC", "#41EAD4", "#011627"}},
plane = NullSpace[{viewpoint}];
Manipulate[
Graphics[{Thickness[.003],
Table[{Blend[cols[[;; -2]], r/π],
InfiniteLine[
RotationMatrix[θ].plane.# & /@ {{Cot[r] Csc[a], 0, Cot[a]}, {0, Cot[r] Sec[a], -Tan[a]}}]},
{r, 2 π/n + s, π, 2 π/n}]},
Background -> cols[[-1]], PlotRange -> range, ImageSize -> 540],
{s, 0, 2 π/n}]
]
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=hopf21.gif&userId=610054
[2]: http://community.wolfram.com/groups/-/m/t/1066393Clayton Shonkwiler2017-04-22T23:13:08Z[✓] Change the order of interpolation of ListContourPlot?
http://community.wolfram.com/groups/-/m/t/1069749
Hi,
I would like to change the order of interpolation of
ListContourPlot.
This function makes a linear interpolation...but I need of an interpolation order 3.
How could I do?
Thank you
Regardsmargherita ferrucci2017-04-22T14:24:18Z[✓] Plot a function with multiple constraints?
http://community.wolfram.com/groups/-/m/t/1069723
Hello,
I am not able to plot a graph of the function f(x,y) = 2x+y, that is in the domain
given by y ≥ 0, x − y ≥ −1, x + y ≤ 1.
Help would be greatly appreciated!Madis Lemsalu2017-04-22T12:49:23ZFast spherical polygon generation?
http://community.wolfram.com/groups/-/m/t/1068326
Cross posted on mathematica.stackexchange - https://mathematica.stackexchange.com/q/144167/5478
## Question
Given a list of points on a sphere and the sphere/radius I'd like to plot a spherical polygon with vertices in those points.
And this needs to be fast, fast enough for the user to not "feel" generation time.
One should be able to style them too. Most importantly the surface but an edge style would be nice aswell.
## What have I tried?
- https://mathematica.stackexchange.com/q/78705/5478
This is very closely related topic but answers there are not fast enough for my needs.
- [J.M.'s answer](https://mathematica.stackexchange.com/a/133264/5478) from https://mathematica.stackexchange.com/q/126075/5478
Is great but "only good for making spherical quadrilaterals, or isosceles spherical triangles".
- `ClipPlanes` in V11+ can be used as a directive which is very effective:
RandomSeed[3];
pts = Normalize /@ RandomReal[{-1, 1}, {3, 3}]
Graphics3D[
{AbsolutePointSize@12, Point@pts,
Red, Sphere[{0, 0, 0}, .999], Blue,
Style[Sphere[], ClipPlanes -> {
InfinitePlane[{#, #2, {0, 0, 0}}],
InfinitePlane[{{0, 0, 0}, #3, #}],
InfinitePlane[{{0, 0, 0}, #2, #3}]
},
ClipPlanesStyle -> Directive[Opacity@.2, Red]]
}
] & @@ pts
[![enter image description here][1]][1]
But I'd need to write some code to determine in what order should those points be put in `InfinitePlanes` in order to clip from the right side ([ClipPlane orientation](https://mathematica.stackexchange.com/a/143939/5478)). I didn't do this because I was too lazy and because:
> The number of clipping planes that can be implemented with ClipPlanes is limited by available graphics hardware.
So it won't be general enough. Though if you want to make this method automatic I will gladly upvote it.
## Motivation
I think it will be useful in many applications.
I don't have time for this but I thought it would be a nice feature to have to improve code I was playing with lately, mostly based on [another J.M.'s answer - Voronoi grid on a sphere](https://mathematica.stackexchange.com/a/142100/5478)
arc[center_?VectorQ, {start_?VectorQ, end_?VectorQ}] := Module[{ang, co, r}, ang = VectorAngle[start - center, end - center];
co = Cos[ang/2]; r = EuclideanDistance[center, start];
{{start, center + r/co Normalize[(start + end)/2 - center], end}, co}
]
points = {2 \[Pi] #1, ArcCos[2 #2 - 1]} & @@@ RandomReal[1, {10, 2}];
sp = Append[Sin[#2] Through[{Cos, Sin}[#1]], Cos[#2]] & @@@ points;
proc[] := (
ch = ConvexHullMesh[sp];
verts = MeshCoordinates[ch]; polys = First /@ MeshCells[ch, 2];
voro = Normalize[ Cross[verts[[#2]] - verts[[#1]], verts[[#3]] - verts[[#1]]]] & @@@ polys;
edges = arc[{0, 0, 0}, voro[[##]]] & /@ Select[Subsets[Range[Length[polys]], {2}], Length[Intersection @@ polys[[#]]] >= 2 &];
);
proc[];
DynamicModule[{run = True}, Graphics3D[{ {Opacity[.75],
DynamicWrapper[EventHandler[Sphere[],
"MouseMoved" :> Module[{pos = MousePosition["Graphics3DBoxIntercepts", True],
pt}, If[
Not@TrueQ@pos , pt = RegionIntersection[Sphere[], Line@pos];
If[pt =!= EmptyRegion[3], sp[[-1]] = First@Nearest[pt[[1]], pos[[1]]]; proc[]] ]]]
, TrackedSymbols :> {run}
]
}
, {AbsoluteThickness[2],
Dynamic[BSplineCurve[#, SplineDegree -> 2,
SplineKnots -> {0, 0, 0, 1, 1, 1},
SplineWeights -> {1, #2, 1}] & @@@ edges]}
, {Red, Sphere[Most@sp, .02], Dynamic@Sphere[Last@sp, .02]}
}
, PlotRange -> 1.1 , SphericalRegion -> True , ImageSize -> 500]
]
[![enter image description here][2]][2]
To look more like https://www.jasondavies.com/maps/voronoi/
[![enter image description here][3]][3]
[1]: https://i.stack.imgur.com/VgVKt.png
[2]: https://i.stack.imgur.com/MU8nf.gif
[3]: https://i.stack.imgur.com/hfAw8.pngKuba Podkalicki2017-04-21T19:42:27Z[✓] Change density of ticks?
http://community.wolfram.com/groups/-/m/t/1067780
Hello guys, I am doing bachelor with huge data sets (x: 0 , 800 000) ; (y: -55, 30)
I need to change density of ticks in _x axis but even with help I could find answer. :( I have never done Mathematica before and it seems little complicated for first time user. I want labels and grid to be 4x denser for better reading. Here is my graph
![enter image description here][1]
Can you please help? Thanks.
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Capture.JPG&userId=11733Martin Dlabaja2017-04-21T18:50:53ZCombine an Image with a ParametricPlot under DynamicModule?
http://community.wolfram.com/groups/-/m/t/1068088
I am trying to place an image imported from a cloud service to the background of a function. Here I try two alternative methods. The first one return an error and not sure. The second is getting to where I want but the image is rendering too small and want it to the resize to cover the full area of the Plot or at least the size of the image itself.
fromCartesian[a_, {x_, y_}] :=
Module[{rA = Norm[{x + a, y}],
rB = Norm[{x - a, y}]}, {ArcCosh[(rA + rB)/(2 a)], (2 UnitStep[y] -
1) ArcCos[(rA - rB)/(2 a)]}]
(* BEGINGS EXAMPLE ----This is a example to verify function---- *)
res = fromCartesian[3, {2, 5}] //
Simplify(* This converst from cartesian to Elliptical*)
N[%, 20]
toCartesian[a_, {\[Xi]_, \[Eta]_}] := {a Cosh[\[Xi]] Cos[\[Eta]],
a Sinh[\[Xi]] Sin[\[Eta]]}
Simplify[toCartesian[3, res]]
(*END EXAMPLE*)
tmax = 20;
\[Eta]Func[t_] := \[Pi] t/tmax
\[Xi]Func[t_] := t + tmax
pointLabel[{\[Xi]_, \[Eta]_}] :=
Row[{"\[Xi] = ", ToString[\[Xi]], ", \[Eta] = ", ToString[\[Eta]]}]
skin = ServiceExecute["Flickr",
"AlbumImages", {"AlbumID" -> "72157679595085384", "Elements" -> "Images",
"ImageSize" -> "Large", MaxItems -> 5}]
(* THIS IS THE ORIGINAL CODE obtained from WOrlfram Mathematica *)
(*
Manipulate[
DynamicModule[{a,\[Xi],\[Eta]},
a=R/2;
{\[Xi],\[Eta]}=fromCartesian[a,pt];
ParametricPlot[Evaluate[{Tooltip[toCartesian[a,{\[Xi],\[Eta]Func[t]}],"\[Xi] \
constant"],Tooltip[toCartesian[a,{\[Xi]Func[t],\[Eta]}],"\[Eta] constant \
assyntote"]}],{t,-tmax,tmax},
PlotRange\[Rule]{{-15,15},{-10,10}},
Ticks\[Rule]True,
AxesLabel\[Rule](Style[#,Italic]&/@{"x","y"}),
PerformanceGoal\[Rule]"Quality",
Prolog\[Rule]{PointSize[0.02],Point[{a,0}],Point[{-a,0}]},
Epilog\[Rule]{Transparent,PointSize[0.1],Tooltip[Point[pt],pointLabel[{\[Xi],\
\[Eta]}]]},
PlotStyle\[Rule]Thick,
ImageSize\[Rule]500,
PlotLabel\[Rule]"elliptic coordinates (\[Xi], \[Eta])"]],
{{pt,{1.88,-4.11}},{-20,-20},{20,20},Locator},
{{R,10.,"interfocal separation"},0.001,20.},
SaveDefinitions\[Rule]True]
*)
Manipulate[
DynamicModule[{a, \[Xi], \[Eta]},
a = R/2;
{\[Xi], \[Eta]} = fromCartesian[a, pt];
Show[skin[[1]],
ParametricPlot[
Evaluate[{Flatten[
Table[toCartesian[a, {z*\[Xi], \[Eta]Func[t]}], {z, 1/2, 2, 1/8}]],
Tooltip[toCartesian[a, {\[Xi], \[Eta]Func[t]}], "\[Xi] constant"],
Tooltip[toCartesian[a, {\[Xi]Func[t], \[Eta]}],
"\[Eta] constant assyntote"]}], {t, -tmax, tmax},
PlotRange -> {{-15, 15}, {-10, 10}},
Ticks -> True,
AxesLabel -> (Style[#, Italic] & /@ {"x", "y"}),
PerformanceGoal -> "Quality",
Prolog -> {PointSize[0.02], Point[{a, 0}], Point[{-a, 0}]},
Epilog -> {Transparent, PointSize[0.1],
Tooltip[Point[pt], pointLabel[{\[Xi], \[Eta]}]]},
PlotStyle -> Thick,
ImageSize -> 1000,
PlotLabel -> "elliptic coordinates (\[Xi], \[Eta])"
]
]],
{{pt, {1.88, -4.11}}, {-20, -20}, {20, 20}, Locator},
{{R, 10., "interfocal separation"}, Exp[-10], 20.},
SaveDefinitions -> True]
Manipulate[
DynamicModule[{a, \[Xi], \[Eta]},
a = R/2;
{\[Xi], \[Eta]} = fromCartesian[a, pt];
ParametricPlot[
Evaluate[{Flatten[
Table[toCartesian[a, {z*\[Xi], \[Eta]Func[t]}], {z, 1/2, 2, 1/8}]],
Tooltip[toCartesian[a, {\[Xi], \[Eta]Func[t]}], "\[Xi] constant"],
Tooltip[toCartesian[a, {\[Xi]Func[t], \[Eta]}],
"\[Eta] constant assyntote"]}], {t, -tmax, tmax},
PlotRange -> {{-15, 15}, {-10, 10}},
Ticks -> True,
AxesLabel -> (Style[#, Italic] & /@ {"x", "y"}),
PerformanceGoal -> "Quality",
Prolog -> {Inset[skin[[1]]], PointSize[0.02], Point[{a, 0}],
Point[{-a, 0}]},
Epilog -> {Transparent, PointSize[0.1],
Tooltip[Point[pt], pointLabel[{\[Xi], \[Eta]}]]},
PlotStyle -> Thick,
ImageSize -> 1000,
PlotLabel -> "elliptic coordinates (\[Xi], \[Eta])"
]],
{{pt, {1.88, -4.11}}, {-20, -20}, {20, 20}, Locator},
{{R, 10., "interfocal separation"}, Exp[-10], 20.},
SaveDefinitions -> True]Jose Calderon2017-04-21T21:47:00Z[GIF] Stay Upright (Projective view of Hopf circles)
http://community.wolfram.com/groups/-/m/t/1066393
![Projective view of Hopf circles][1]
**Stay Upright**
As with [_Light Show_][2], I'm starting with a collection of Hopf circles on the 3-sphere, taking the 2-planes in $\mathbb{R}^4$ they determine (note that a Hopf circle always determines a complex line in $\mathbb{C}^2$, so these 2-planes are complex lines), and intersecting those 2-planes with the hyperplane $w=1$, which gives a collection of lines in 3-space (actually in projective 3-space, but I'm just ignoring the lines at infinity). In _Light Show_ I was taking equally-spaced Hopf circles on the Clifford torus, whereas in this animation I'm taking a single circle on each of the tori interpolating between the unit circle in the $xy$-plane and the unit circle in the $zw$-plane (the unit circle in the $xy$-plane corresponds to a line at infinity; after the lines go off the screen they actually shoot off to infinity).
In fact, due to rendering issues I'm orthogonally projecting the lines in 3-space to the plane normal to what would be the `ViewPoint` vector if this were a `Graphics3D` object: hence the `viewpoint` and `plane` variables. Here's the code:
DynamicModule[{n = 60, a = π/4, viewpoint = {1, 1.5, 2.5}, θ = 1.19, r = 2.77, plane,
cols = RGBColor /@ {"#f43530", "#e0e5da", "#00aabb", "#46454b"}},
plane = NullSpace[{viewpoint}];
Manipulate[
Graphics[
{Thickness[.003],
Table[{Blend[cols[[;; -2]], r/π],
InfiniteLine[
RotationMatrix[θ].plane.# & /@ {{Cot[r] Csc[a], 0, Cot[a]}, {0, Cot[r] Sec[a], -Tan[a]}}]},
{r, π/(2 n) + s, π, 2 π/n}]},
Background -> cols[[-1]], PlotRange -> r, ImageSize -> 540],
{s, 0., 2 π/n}]
]
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=hopf14.gif&userId=610054
[2]: http://community.wolfram.com/groups/-/m/t/1063215Clayton Shonkwiler2017-04-20T03:29:06ZPlot auto-extracted sub-matrices?
http://community.wolfram.com/groups/-/m/t/1067533
I have a 70x16 matrix ("DATA22K") in which the first column represents time, and the next 15 columns represent trials of a timecourse assay I've performed (n 1 thru 15). I would like to quickly create 15 submatrices with time (col 1) plotted against the values for each trial, each having iterated names of the format "Tr22Ki" (where i = 1 - 15). This is the code I'm using to generate the table of matrices (which seems to work):
Table[Evaluate[Symbol["Tr22K" <> ToString[i]]] ==
Transpose[{DATA22K[[All, 1]], DATA22K[[All, i]]}], {i, 2, 15, 1}];
**THE PROBLEM**: I used to be able to generate a graph with all Tr22Ki traces superimposed over each other with this code:
ListLinePlot[Tr22Ki]
but it no longer works (blank graph), and I can't figure out why. There is no error code, but I've checked, and all the matrices have been made. The same happens when I write the code as:
Tr22Kall=Table[Evaluate[Symbol["Tr22K" <> ToString[i]]] ==
Transpose[{DATA22K[[All, 1]], DATA22K[[All, i]]}], {i, 2, 15, 1}];
ListLinePlot[Tr22Kall]
Please help! Thank you for your time.Jesse Martin2017-04-21T00:47:10ZUse manipulate on variables in other equations?
http://community.wolfram.com/groups/-/m/t/1066233
The end goal of this endeavor is to make an interactive site where users import pictures then slide some manipulate bars to set parameters which selects things from the image. We start with binarizing the whole thing, filltransform the image to fill in the blobs, then selecting blobs of a set number of pixles. The sliders theoretically set the binarize threshhold, and the max & min pixel counts.
The problem I'm encountering is the manipulate command (or the sliders) will be used on a different line than the output line. The command that sets the max/min is not the output command that is used to display the picture. I tried making my program all on one line, but that was too long and too confusing and it didn't run properly with the manipulate command anyway (maybe I didn't write it right, but it doesn't seem like a feasible solution for me).
I'm thinking maybe I have to play with the dynamic command, to manipulate variables from previous lines? But that means I have to learn everything about dynamic, DynamicModule, and the rest of that can of worms...
im = THEFREAKINGPICTURE
isolate = FillingTransform@Binarize[im, {0, 0.36}]
selectsizes = Manipulate[Colorize[SelectComponents[WatershedComponents[GradientFilter[isolate, 2], isolate], "Area", minimum < # < maximum &]], {minimum, 0, 500}, {maximum, 500, 5000}]
circles =ComponentMeasurements[selectsizes, {"Centroid", "EquivalentDiskRadius", "Label"}];
Show[im, Graphics[{Red, Thick, Circle @@ # & /@ circles[[All, 2]]}]]
I want to put the 0.36 from my isolate command on a slider. I want to put minimum and maximum from my selectsizes command on a manipulate slider. I want to put all the sliders in a catch-all command at the end if that would work.... Basically all I want is have sliders for my variables that update the picture as needed. My brain has melted for today, and I have no idea how to make that work yet. If anyone has any helpful suggestions I would love to hear them, I'll be back at this tomorrow.Bill Norman2017-04-20T00:21:58ZGet all integration orders and plot them?
http://community.wolfram.com/groups/-/m/t/1066533
Hello,
I just downloaded Wolfram Mathematica and would like to know how to plot and get the integration limits in all orders. I know it can be done because I saw someone doing it in college and he was using Mathematica, probably an older version though. The volume described by the integrals are not defined using functions but as the sort:
![lR^3 solid description][1]
I went through the references and guides and could find regionplot3D function and others similar but all of them need the range for x,y and z. I'd like to be able to put the inequalities such as in the image and get all 6 possibles integrals to calculate. I don't know if i'm being clear :s
Also can I use wolfram cloud on my phone using the college's license? I tried to but apparently I have to pay for mathematica online (and app therefore). Can this (what I'm asking) be done in wolfram alpha or Matlab?
Thanks and excuse my english
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=integral.jpg&userId=1066194Mauro Pungo2017-04-19T21:22:40Z[GIF] Circle - Gecko - triangular tiling transformation inspired by Escher
http://community.wolfram.com/groups/-/m/t/870903
Inspired by the work of the Frisian artist M.C. Escher, I decided to make this little animation:
![enter image description here][1]
The code is nothing more than linear interpolation between sets of points:
SetDirectory[NotebookDirectory[]];
p1 = {{0.`,0.`},{0.0678`,0.054200000000000005`},{0.1336`,0.09570000000000001`},{0.1831`,0.1257`},{0.2398`,0.1714`},{0.26780000000000004`,0.20850000000000002`},{0.2528`,0.2606`},{0.22760000000000002`,0.3084`},{0.2117`,0.3584`},{0.21930000000000002`,0.41000000000000003`},{0.24550000000000002`,0.4595`},{0.28500000000000003`,0.5056`},{0.34`,0.48260000000000003`},{0.3935`,0.45320000000000005`},{0.4305`,0.43760000000000004`},{0.43820000000000003`,0.39840000000000003`},{0.4303`,0.3698`},{0.3831`,0.3678`},{0.3552`,0.3683`},{0.3925`,0.33180000000000004`},{0.4148`,0.2927`},{0.4339`,0.2671`},{0.49720000000000003`,0.2947`},{0.5356000000000001`,0.33380000000000004`},{0.5789000000000001`,0.3659`},{0.558`,0.4297`},{0.5141`,0.48090000000000005`},{0.5`,0.5`},{0.5`,0.5`},{0.4859`,0.5191`},{0.442`,0.5703`},{0.42110000000000003`,0.6341`},{0.46440000000000003`,0.6662`},{0.5028`,0.7053`},{0.5661`,0.7329`},{0.5852`,0.7073`},{0.6075`,0.6682`},{0.6448`,0.6317`},{0.6169`,0.6322`},{0.5697`,0.6302`},{0.5618000000000001`,0.6016`},{0.5695`,0.5624`},{0.6065`,0.5468000000000001`},{0.66`,0.5174`},{0.7150000000000001`,0.4944`},{0.7545000000000001`,0.5405`},{0.7807000000000001`,0.5900000000000001`},{0.7883`,0.6416000000000001`},{0.7724000000000001`,0.6916`},{0.7472000000000001`,0.7394000000000001`},{0.7322000000000001`,0.7915000000000001`},{0.7602`,0.8286`},{0.8169000000000001`,0.8743000000000001`},{0.8664000000000001`,0.9043`},{0.9322`,0.9458000000000001`},{1.`,1.`}};
p2 = {{1.`,1.`},{1.0396177978506647`,0.8923346254845568`},{1.0553148607198288`,0.8165562085782169`},{1.0612803330660763`,0.7422415758850744`},{1.0593972739777413`,0.6855070651494309`},{1.0410889377634256`,0.6295007686706042`},{0.9985803499841852`,0.5851973901977947`},{0.9483041434655642`,0.5486542747648014`},{0.9100397943346402`,0.495994821587507`},{0.8886126415052703`,0.4220994637695018`},{0.8802712781999131`,0.3410911444732952`},{0.9107680085914569`,0.2922860778674355`},{0.944118750413758`,0.23431580960507237`},{0.9891650545425124`,0.1782359561306078`},{1.0249726000191246`,0.2133888443460414`},{1.0610964405769812`,0.25639761969562114`},{1.0125267563571634`,0.29612575303974287`},{0.9819491132704178`,0.3427388211755879`},{1.042685124568772`,0.3779726220862235`},{1.0923875865214163`,0.4314412022155367`},{1.110695922735732`,0.3701240906516413`},{1.139236037043303`,0.307894872341834`},{1.1672759637805352`,0.24281899830083345`},{1.190159545123539`,0.19293999955865795`},{1.1550875696033072`,0.15058588147025714`},{1.1048113630846865`,0.1033990687684352`},{1.0520783529117537`,0.05681542343084531`},{1.`,0.`}};
rf = RotationTransform[\[Pi]/2, {1, 0}];
p3 = Reverse[rf /@ p2];
colors = {RGBColor[0.9280877328700329, 0.8058790727091572, 0.41541817087124444`],RGBColor[0.5551256603319519, 0.6745729914926235, 0.40725444158653856`]};
ClearAll[GetLines, MakeScene]
GetLines[\[Beta]_] :=
Module[{\[Alpha], goal1, goal2, goal3, goal, lenp},
If[0 <= \[Beta] <= 0.5,
\[Alpha] = 2 \[Beta];
lenp = Length[p1] + Length[p2] + Length[p3];
goal = CirclePoints[{0.66, 0.33}, {0.33, 3.97}, lenp];
{goal1, goal2, goal3} = FoldPairList[TakeDrop, goal, (Length /@ {p3, p2, p1})][[{3, 2, 1}]];
Polygon[Join @@ {\[Alpha] p1 + (1 - \[Alpha]) Reverse[
goal1], \[Alpha] p2 + (1 - \[Alpha]) Reverse[
goal2], \[Alpha] p3 + (1 - \[Alpha]) Reverse[ goal3]}]
,
\[Alpha] = 2 (\[Beta] - 0.5);
goal1 = Subdivide[0, 1, Length[p1] - 1];
goal1 = {goal1, goal1}\[Transpose];
goal2 = Subdivide[1, 0, Length[p2] - 1];
goal2 = Thread[{1, goal2}];
goal3 = Subdivide[1, 0, Length[p3] - 1];
goal3 = Thread[{goal3, 0}];
Polygon[Join @@ {(1 - \[Alpha]) p1 + \[Alpha] goal1, (1 - \[Alpha]) p2 + \
\[Alpha] goal2, (1 - \[Alpha]) p3 + \[Alpha] goal3}]
]
]
MakeScene[\[Alpha]_] := Module[{in, shape},
in = GetLines[\[Alpha]];
shape = {in, Rotate[in, \[Pi], {0.5, 0.5}]};
shape = Riffle[colors, shape];
shape = Rotate[shape, #, {0, 0}] & /@ Range[0, 3 \[Pi]/2, \[Pi]/2];
shape = Translate[shape, Tuples[{-2, 0, 2}, 2]];
shape
]
To animate it using manipulate use:
Manipulate[Graphics[MakeScene[\[Tau]], PlotRange -> 2.5], {\[Tau], 0, 1}]
And to output the animation I used:
n=150;
ClearAll[Nonlineartime]
Nonlineartime[t_]:=0.5LogisticSigmoid[25(t-0.2)]+0.5LogisticSigmoid[25(t-0.75)]
Plot[Nonlineartime[t],{t,0,1}]
ts=Table[Nonlineartime[t],{t,Subdivide[0.0,1,n]}];
ts[[{1,-1}]]={0.0,1.0};
imgs=Table[Rasterize[Graphics[MakeScene[t],PlotRange->2.5,ImageSize->400],"Image"],{t,ts}];
Export["geckotransform.gif",imgs~Join~Reverse[imgs],"DisplayDurations"->0.03]
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=geckotransform.gif&userId=73716Sander Huisman2016-06-10T22:28:43Z[✓] Create an animation of the Nephroid of Freeth?
http://community.wolfram.com/groups/-/m/t/1066315
Trying to create an animation of the Nephroid of Freeth with Mathematica
Clear[z];
a = 1;
Do[z[j] = PolarPlot[a*(1 + 2*Sin[t/2]), {t, 0, j}, Ticks -> False,
PlotRange -> {{-3, 1.5}, {-2.5, 2.5}}], {j, 4 Pi/50, 4 Pi, 4 Pi/50}];Mary Ann2017-04-19T17:02:09Z