Tag Info

Hot answers tagged

22

Generally always check Demonstrations site for good code. I cannot not mention an excellent "classic" of planar three body problem by Stephen Wolfram and Michael Trott. Code is short and I verified it runs in the latest M10.1. I slightly changed variable labels so code parses better here, removed MaxRecursion -> ControlActive[3, 9] from plot option and ...


8

Probably this match your plot: ParametricPlot[{r {r k2, v1}}, {s1, 0.0, 50}, {r, 0, 1}, PlotRange -> {{0, 0.3}, {0, 1.5}}, AspectRatio -> 0.5, BoundaryStyle -> Directive[Black, Thick], Mesh -> 100, MeshFunctions -> (50 #1 - #2 &)]


7

Here is an alternative to RegionPlot that potentially produces higher quality: it's based on Tube with varying radius, as I also used in this answer: With[ {a = 1, R = .7, n = 40, xMax = 1.5}, Manipulate[ Graphics3D[ GeometricTransformation[ {CapForm[None], {Opacity[.5], Pink, #, Cyan, GeometricTransformation[#, {{-1, 0, 0}, ...


7

To fill with a solid color, you can post-process the Line primitive into a Polygon ParametricPlot[{k2, v1}, {s1, 0.0, 50}, PlotRange -> {{0, 0.3}, {0, 1.5}}, AspectRatio -> 0.5, PlotStyle -> Black] /. Line[x_] :> {Blue, Polygon[x]} Update: Using the approach in this answer mentioned in Alexey's comment: poly = Cases[pp, Line[x_] :> ...


6

In your case, you have some arrows that are all drawn in the same style. This allows you to put all of them into a single Arrow command. For several differently colored arrows you would then have groups of Arrow commands for each different style: Manipulate[ Graphics[{Black, Thick, Circle[{-x, 0}, r], PointSize[.03], Point[{0, 0}], Red, ...


4

Here is another approach: data = RandomReal[1, {10, 5}]; dataNorm=Accumulate@Normalize[#,Total]&/@ data; setLength=Length@data[[1]]; colors = <|1->Red,2->Blue,3->Green,4->Orange,5->Purple|>; ListPlot[Transpose@dataNorm ,Joined->True ,Filling -> Table[i -> {{i-1}/.{0}-> 0, colors[i]} ,{i,setLength}] ...


4

Something like this? g[x_, alfa_] := (alfa + 1) x - alfa x^3; p[x_, alfa_] := Piecewise[ {{-1, x < -1}, {x (1 - alfa) - alfa, -alfa > x >= -1}, {x (2 - alfa), alfa >= x >= -alfa}, {x (1 - alfa) + alfa, 1 >= x > alfa}, {1, x > 1}} ]; lyapunov[f_, x0_, alfa_, n_, tr_: 0] := Module[ {df, xi}, df = ...


4

Here's an approach using ParametricPlot3D, in which spheres are plotted and then sliced off using the option RegionFunction. It's not clear to me how you intend to have the inner regions "blank" as they are occluded, but the options to Show let you vary the appearance. outerSphere[sphereCenter_: {0, 0, 0}, regionLimit_: 0.6, color_, opacity_] := Module[ ...


3

There is the somewhat hidden built-in graph-method of "EdgeLayout" that can be exploited for this purpose (see Details under GraphLayout): AdjacencyGraph[Range@8, Table[Boole[j > i], {i, 8}, {j, 8}], DirectedEdges -> True, VertexLabels -> "Name", GraphLayout -> { "EdgeLayout" -> {"DividedEdgeBundling", "CoulombConstant" ...


3

Here's an approach using ParametricPlot, where ListAnimate permits smooth animation. testparaNew[α_] := Show[{ ParametricPlot[ {{Cos[θ], Sin[θ]}, {2 Cos[α] + Cos[θ], 2 Sin[α] + Sin[θ]}}, {θ, 0, 2 π}, PlotRange -> 3, Axes -> False, Frame -> False ], ParametricPlot[ {{2 Cos[α] + r Cos[2 α + π], 2 ...


2

I will show a way to find the cells and the nucleusus with LaplacianGaussianFilter. Nucleouses To find the nucleuses there many ways to define the regions, the idea here is to find local maxima, rather then absolute maxima, which the threshold does. This finds the centers of the nucleuses. nucleouscenter=Binarize[ImageMultiply[MaxDetect[#], #] &@ ...


2

The problem is caused by padding that is added around the Graphics scene by default. You can disable it by setting PlotRangePadding to 0 or None: mask = Graphics[{Black, Rectangle[{0, 0}, {256, 256}], White, Disk[Abs[{0, 256} - pos], 7]}, PlotRangePadding -> 0]


2

The InPolygonQ function has moved in version 10 to Graphics`PolygonUtils`InPolygonQ. With that change it should work properly. – Simon Woods Aug 19 '14 at 19:35 [Just to give an answer. Seemed better than closing the question.]


2

Inspired by Murta's answer, here is a similar smooth plot: randomPolynoms = Table[Fit[MapIndexed[{#2[[1]] - 1, #1/2} &, RandomReal[1, 21]], Table[x^i, {i, 0, 10}], x], {i, 1, 5}]; randomFunctions = (# + Abs[MinValue[{#, 0 <= x <= 10}, x]]) & /@ randomPolynoms; dataNorm = Accumulate@Normalize[randomFunctions, Total]; setLength = ...


1

Example: Plot[{Sin[x], Cos[x]}, {x, -3, 3}, PlotLegends -> "Expressions", PlotLabel -> "This is my plot"] Then from the Edit pulldown menu: Edit > CopyAs > PDF Then paste into your Word document.



Only top voted, non community-wiki answers of a minimum length are eligible