New answers tagged

0

You've created a MeshRegion, so you can plot it with RegionPlot3D, Of course, since your cylinder is rotated with respect to the cartesian coordinates, you'll need to find the right combination of coordinates to give the mesh you want. Here are some examples, RegionPlot3D[hull, Mesh -> 10, MeshFunctions -> #, Axes -> True, ImageSize -> ...


3

r3 = AppendTo[Table[{Graphics[{Text[ Which[i == 1, Subscript[P, 0], i == Length[d0], Subscript[P, f], True, ToString[i - 1]], Offset[{0, 10}, d0[[i]]]]}], Graphics[{PointSize[Large], Which[i == 1, Red], Which[i == Length[d0] - 1, {Point[d0[[i]]], Blue, Point[d0[[i + 1]]]}, True, Point[d0[[i]]]]}], Graphics[{Arrow[d0[[i ;; i + ...


7

This is not ideal but in case similar procedure for other values of k. A modification of function. Once segment is not colored. dr[p_, r_, k_] := Module[{}, sols = Solve[(x^2)^(1/r) + (y^2)^(1/k) == 1 && p == 0]; sols = {x, y} /. sols; g1 = ListPlot[sols, PlotStyle -> {Red}, PlotMarkers -> {Automatic, 10}]; g2 = ...


4

Use a Graph with directed edges labels = Thread[ Range[12] -> (Placed[#, Above] & /@ Join[{Subscript[x, 0]}, Range[10], {Subscript[x, f]}])]; Graph[# \[DirectedEdge] # + 1 & /@ Range[11], VertexCoordinates -> d0, VertexLabels -> labels, VertexStyle -> {1 -> Red, 12 -> Blue}] Or, if you need to have it look like the ...


9

Here is another way to implement the same thing as JasonB. I'm assuming that sols is the roots given by your code. angles = Sort@N[ArcTan @@@ sols]; cones = Partition[First[angles] + Accumulate@Differences[angles], 2, 1]; cones is a list of intervals of angles representing the cones. Two intervals are missing due to how the list is computed, we add them ...


6

This function will take any points and create what is essentially a pie chart from them, pointsPieChart[pts_, radius_: 1, center_: {0, 0}] := Module[{angles}, angles = ArcTan @@@ pts // Sort // Append[#, First@# + 2 π] &; Graphics[ Table[{ColorData[97][n], Disk[center, radius, angles[[n ;; n + 1]]]}, {n, Length@pts}]] ] It ...


5

Here's a possibility. Copy the graphic into a new cell, type p1 = in front of the plot and evaluate the cell. Then, do p1 /. Point[a__] :> {PointSize[0.2], Point[a]} Here's a gif showing the procedure:


0

I never used Fourier in MMA before, so I am going to do it in a rather primitive way. First I am going to extract the coordinate from the image. For that I will resize and scale the image to make the number of data less as possible. img = Import["http://i.stack.imgur.com/gxyMR.jpg"]; img1 = img // Binarize dat = Sort@Union@PixelValuePositions[img1, ...


0

Upload your data to http://pastebin.com/ to show you the exact frequency spectrum. Here is a simple code which reads your data from a ascii file (2 columns time and mx) and creates 2 plots, one showing the liner amplitude versus frequency and the other one showing the logarithmic amplitude versus frequency. dir = "F:"; (* the output directory for the ...


6

Here's something you can start with, rinit = 6; rfactor = 0.05; rstep = .025; npoints = Floor[(rinit - rfactor rinit)/rstep]; imglist = Table[ With[{r = rinit - n rstep}, Graphics[{Thickness[.03], Circle[#, rfactor r]} & /@ CirclePoints[{0, -r + 2 (rinit - npoints rstep)}, {r, 2 π/npoints n}, 40.], ImageSize -> ...


0

What about lst = {"A", "B", "D"}; Table[Graphics3D[Table[{Sphere[]}, {i, 1, Length[lst]}], ViewPoint -> Above, Boxed -> False,Epilog -> Text[lst[[i]], Scaled[{0.5, 0.5}]]], {i, 1, Length[lst]}]


2

I think it may be more expedient to use Framed to generate the frame you want, rather than having an extra graphics object: Framed[ Show[ { Graphics[{Red, Thick, Circle[]}], Plot[Sin[x], {x, -2, 5}, PlotStyle -> Directive[Thick, Blue]] }, PlotRange -> {{0, Pi}, {-Pi/2, Pi/2}}, (*REMOVED*) (*PlotRangeClipping -> ...


5

This isn't elegant, but I think it should work pretty reliably. Start with the base plot: plot = ParametricPlot[ Evaluate@BezierFunction[temPoint = RandomReal[{-50, 50}, {5, 2}]][ t], {t, 0, 1}, AxesOrigin -> {0, 0}] Create a version that has the point, but wrap the point in Annotation, with type "Region": plot2 = Show[plot, Epilog -> ...


0

Just a comment to @kglr with picture.I change his temp2[[1]]=temp1[[1]]to temp2[[2]]=temp1[[2]];temp2[[3]]=Mean@Delete[temp1,2].But this method don't sufficient to guarantee intersection of the curves like plot1 = ParametricPlot[ Evaluate[ l1[t] = BezierFunction[ temp1 = RandomReal[{0, RandomReal[50]}, {3, 2}]][t]], {t, 0, 3}]; plot2 = ...


2

A simpler and minimal version Manipulate[ Graphics[{Red, Circle[{0, 0}, Cos[Pi/n]], Blue, Circle[{0, 0}, 1], Green, Line[{Cos[2 Pi #/n], Sin[2 Pi #/n]} & /@ Range[0, n]]}], {n, 3, 30, 1}] Inner circle will adjust itself according to the polygon.


6

There are numerous ways to do this in Mathematica, and it's hard to say which would be most useful for learning. Here's one; a unit circle is drawn, then a polygon with no filling and black edge on basis of CirclePoints which generates points of a regular polygon lying on the unit circle. Finally, mean of two first points is taken, and distance to the origin ...


3

One way is to force temp1 and temp2 to share an endpoint: plot1 = ParametricPlot[Evaluate[l1[t] = BezierFunction[ temp1 = RandomReal[{0, RandomReal[50]}, {3, 2}]][t]], {t, 0, 3}]; plot2 = ParametricPlot[Evaluate[l2[t] = BezierFunction[ temp2 = RandomReal[{0, RandomReal[50]}, {3, 2}]; temp2[[1]] = temp1[[1]]; temp2][t]], {t, 0, 3}, ...


1

What about something like this? Show[RegionPlot[{g[x, y] > h[x, y], g[x, y] < h[x, y]}, {x, -1, 1}, {y, -1, 1}, MaxRecursion -> 6, PlotStyle -> {Red, Blue}], ContourPlot[f[x, y], {x, -1, 1}, {y, -1, 1}, ContourShading -> None, Contours -> 5]] Since your function are diverging in x==y==0 it's a bit difficult to get nice results ...


2

Maybe something like Quiet@Plot3D[f[x, y], {x, -1, 1}, {y, -1, 1}, PlotPoints -> 50, MaxRecursion -> 6, Mesh -> None, ClippingStyle -> None, Axes -> {True, True, False}, BoundaryStyle -> None, ViewPoint -> {0, 0, Infinity}, ColorFunctionScaling -> False, ColorFunction -> Function[{x, y, z}, Blend[{{h[x, y], Red}, {g[x, ...


1

Using Labeled: plots = Plot[#[x], {x, -Pi, Pi}] & /@ {Sin, Cos, ArcSin, ArcCos}; labels = Style[#, "Section", 18, Black] & /@ {"Sin", "Cos", "ArcSin", "ArcCos"}; labeledplots = Labeled[#1, #2, Top] & @@@ Transpose[{plots, labels}]; Grid[Partition[labeledplots, 2], Spacings -> {2, 2}, Dividers -> All]


2

I put together documentation and this question (for the number of points needed): Graphics3D[ Tube[BSplineCurve[{{-1, 0, 1}, {3, 2, 1}, {0, -2, 1}, {-3, 2, 1}, {1, 0, 1}}], 0.05]] Play with the 5 points until you are satisfied.


0

I just found another way : textStyle = Sequence[12, Italic, FontFamily -> "Times"]; Manipulate[ ParametricPlot[ {a Sin[b t + c], d Cos[f t + g]}, {t, 0, 6 Pi}, Frame -> True, PlotRange -> {{-5, 5}, {-5, 5}} ], {{a, 1, Style[a, textStyle]}, 0, 5, 0.01}, {{b, 1, Style[b, textStyle]}, 0, 10, 0.01}, {{c, 1, ...


4

You can use the option LabelStyle: labelstyle = Directive[12, Italic, FontFamily -> "Times"]; Manipulate[ParametricPlot[{a Sin[b t + c], d Cos[f t + g]}, {t, 0, 6 Pi}, Frame -> True, PlotRange -> {{-5, 5}, {-5, 5}}], {{a, 1}, 0, 5, 0.01}, {{b, 1}, 0, 10, 0.01}, {{c, 1}, 0, 2 Pi, 0.01}, {{d, 1}, 0, 5, 0.01}, {{f, 1}, 0, 10, 0.01}, ...


3

curve[v_, g_] := ParametricPlot[{Chi[t[tau, v, g], x[tau, v, g]], Eta[t[tau, v, g], x[tau, v, g]]}, {tau, -50, 50}, PlotRange -> All, RegionFunction -> Function[{x, y, u}, Norm[{x, y}, 1] < .99999 Pi]] Show[RegionPlot[Norm[{x, y}, 1] <= Pi, {x, -Pi, Pi}, {y, -Pi, Pi}], curve[0.5, 2], PlotRange -> {{-Pi, Pi}, {-Pi, Pi}}, Frame -> ...


4

On MMA 10.3 on OSX 10.10.5 I get the same behaviour as @chuy - blunt on the front end and both export formats. I think the implementation is kind of buggy as one might expect the option JoinForm -> "Miter" to solve the problem, however it changes nothing. However, using the additional option JoinForm -> {"Miter",d} does create the desired behaviour ...


6

Using your definitions, let's derive a RegionMemberFunction that indicates whether a point lies on the boundary of the diamond-shaped region that you want to exclude from plotting: rmf = RegionMember@DiscretizeRegion@Line[{{-Pi, 0}, {0, -Pi}, {Pi, 0}, {0, Pi}, {-Pi, 0}}]; Notice that the first point must be repeated to obtain a closed line. Using that ...


4

You can use FrameStyle -> Directive[Opacity @ 0, FontOpacity -> 1], FrameTicks -> None, ... But in general I'd go with Labeled.


5

I think this code answers the question: data = RandomInteger[{0, 1}, {120, 4}]; edges = DirectedEdge @@@ Partition[data, 2, 1]; Graph[edges, VertexLabels -> "Name"] Continuation... Because of a question in a comment here is some code that shows the derivation of graphs, spanning trees of those graphs, their disjoint union, and a highlighted ...


2

If you are using Mathematica version 9.0 or later, you can use the PlotLegends option as shown in the documentation and in Lukas's answer (beat me to it by 2 minutes). But if you are using an older version you have to resort to the PlotLegends package (I know it's confusing), << PlotLegends` With[{arrayData = Array[Sin[.01 π (#1 - 2 #2)] &, {100, ...


3

This is how you add a color legend to your ListContourPlot (also true for similar types of plots). This is by the way the third example in the ListContourPlot documentation. Of course, the crucial part is the PlotLegends option. data = Table[{x = RandomReal[{-2, 2}], y = RandomReal[{-2, 2}], Sin[x y]}, 1000}]; ListContourPlot[ data, ColorFunction -> ...


3

I would memoize sol[a]. The Evaluate in position does nothing if it does not wrap the entire expression after the :=. It's not that important, so I would just drop it. The issue with [[1]] (or First) can be handle in sol. Here are the changes I've described: sol[a_] := sol[a] = First@NDSolve[{x''[t] == -2 x[t], x[0] == a, x'[0] == 1}, {x}, {t, 0, 10}] ...


0

This helps to get rid of that [[1]] as per your request, however without having the code that is really slowing this down, I cannot be sure it would help improve your performance. If it does, great! If not, you have eliminated one possible cause. You state the performance glitch is with position[t,a] function. However, can you remove the 0.01 timesteps in ...


3

I remember playing around with clear plastic sheets with grid lines. Here's a way to simulate the real-time moving around of the sheets. Starting with gpap's function, change this to an image and set the alpha channel so that the white area is actually transparent. Then use GraphicsGrid to display multiple copies. Now you can move them around and rotate ...


12

I like to keep things simple, so I'll skip the letter labels, but include the lines overhanging from the grid: m = 30 (* number of mesh lines *); h = 2 (* overhang *); lins = Join[#, Map[Reverse, #, {2}]] & @ Outer[{##} &, ArrayPad[Range[-1, 1, 2/m], h, "Extrapolated"], {-1, 1}]; Table[Graphics[{AbsoluteThickness[1/100], ...


5

g = Graphics@GraphicsGroup[ Table[{Line[{{x, -5}, {x, 5}}], Line[{{-5, x}, {5, x}}]}, {x, -5, 5, .25}] ]; Manipulate[ Overlay[ Table[ Rotate[g, i θ], {i, -2, 2}], Alignment -> Center ], {θ, 0, π/12}] or g = Graphics@GraphicsGroup[ Table[{Line[{{x, -5}, {x, 5}}], Line[{{-5, x}, {5, x}}]}, {x, -5, 5, .25}] ]; ...


1

reflectedMPF = With[{m = ArrayPad[#, Thread[{0, Dimensions[#]}], "Reversed"]}, MatrixPlot[m, Frame -> False]]& Examples: reflectedMPF@Table[Mod[i + j, 4], {i, 0, 3}, {j, 0, 3}] reflectedMPF[RandomInteger[100, {5, 10}]]


1

I think this is what you need for reflection. reflectBottom[x_] := Join[x, Reverse[x]]; reflectRight[x_] := Transpose@reflectBottom@Transpose[x]; Table[Mod[i + j, 4], {i, 0, 3}, {j, 0, 3}] // MatrixPlot[reflectBottom@reflectRight[#], Frame -> None] & Update rotate90[x_] := Transpose@Reverse[x]; rotate90Glue[x_] := ...


4

Without diving into your code too much, everything will run a LOT more smoothly if you use ParametricNDSolve to solve your differential equations with the parameter a: pfun = ParametricNDSolveValue[{x''[t] == -2 x[t], x[0] == a, x'[0] == 1}, x, {t, 0, 10}, {a}] position[t_, a_] := {Sin[#], Cos[#]} &@pfun[a][t] You can keep everything else the same. ...


31

I feel that once you start with Moire patterns, there's no ending. The way I would replicate these is by making a grid into a function (like @JasonB) but also parametrise the angle of rotation into it: lines[t_, n_] := Line /@ ({RotationMatrix[t].# & /@ {{-1, #}, {1, #}}, RotationMatrix[t].# & /@ {{#, -1}, {#, 1}}} & /@ ...


23

Something like this: nlines = 30; Table[ Overlay[ Rotate[ Graphics[{ Table[{ Line[{{0, n}, {nlines, n}}], Line[{{n, 0}, {n, nlines}}]}, {n, 0, nlines}], Text[Style[#1, 18], {0, 0}, {-1, -1}, Background -> White] }, AspectRatio -> 1, PlotRangePadding -> None, ImageSize -> ...


1

Just a different visualization. clock[n_, t_, tmax_] := Module[{c}, c = {Circle[{0, 0}, 1], Red, Arrow[{{0, 0}, 0.7 {Sin[Mod[t, n] 2 Pi/n], Cos[2 Pi Mod[t, n]/n]}}], {Red, ChartElementData[ "BezelSector"][{{Pi/2 - 2 Pi t/n, Pi/2}, {1, 1 + 0.1 Floor[Quotient[t, n]]}}, 0]}, Black, Table[{Text[ n j/(2 Pi), ...


3

Using @Quantum_Oli's nice generalization in an alternative way: ppF = With[{tmin = π/2 - 2 π Mod[##]/#2, tmax = π/2 + 2 π Floor[Divide@##], epilog = Table[With[{pos = {Cos[π/2 - 2 π i/#2], Sin[π/2 - 2 π i/#2]}}, {Line[{0.9 pos, pos}], Text[ToString@i, 0.8 pos]}], {i, 0, #2 - 1}], h = Graphics[{Thick, ...


8

So the quick hack I posted in the comment works: Graphics[First[plt] /. {x_, y_} :> {-x, y}] Just negates the x coordinate of all the values on the line, thus reflecting the spiral in the y-axis. However it is a bit hacky. You can with a little maths just find the end points of your spiral such that you can use the default counterclockwise behaviour, ...


6

We have to modify snipa little bit: ClearAll[snip] snipCurve = Graphics[ {BezierCurve[{{0, -(1/2)}, {1/2, 0}, {-(1/2), 0}, {0, 1/2}}]} ]; snip[pos_?NumberQ, primitive_Graphics: snipCurve] := snip[ {pos}, primitive ]; snip[pos_List, primitive_Graphics: snipCurve] := Arrowheads[ {Automatic, #, primitive} & /@ pos ]; snip[pos_List, ...


6

Update: Speaking of "pie slices", you can use SectorChart3D directly as follows: ClearAll[sliceF] sliceF[opts : OptionsPattern[]][x_, y_, r_: {0, 2}, h_: 2] := SectorChart3D[{{(y - x) Degree, r[[2]], h}, {(360 - y + x) Degree , r[[2]], h}}, SectorOrigin -> {{x Degree}, r[[1]]}, opts] sliceF[BoxRatios -> 1, Axes -> True][30, 70] ...


0

As explained in the comment. The sol yields {y[t]->...}. This argument will be evaluated in Plot but not with Point. If the aim is just to see bounce on vertical line you just have to take first part of sol (e.g First[sol]. If you want to plot y v time he is one of many ways: sol = y[t] /. First@NDSolve[{y''[t] == -9.81, y[0] == 5, y'[0] == 0, ...


3

Here is my late attempt based off my answer here. tri = DiscretizeGraphics @ SSSTriangle[3, 4, 5]; Using PropertyValue we can set the labels to be part of the triangle: PropertyValue[{tri, {1, All}}, MeshCellLabel] = Style[Framed[#], Bold, Red, 10, Background -> Yellow] & /@ {5, 3, 4}; Visualize: tri


4

See if the following can give you a starting point: radius = 3; height = 3; angle = 30 Degree; RegionPlot3D[ x^2 + y^2 <= radius^2 && x >= 0 && 0 <= y <= ArcTan[angle] x && 0 <= z <= height, {x, 0, 4}, {y, 0, 4}, {z, 0, height}, Mesh -> None, PlotPoints -> 100, PlotRangePadding -> {Scaled[0.05], ...


2

You can move the patch around the left torus to see where it's mapped on the right torus by func. func = Function[{u, v}, {u + v, 2 u}]; func = Function[{u, v}, {u + v, 2 u}]; nmesh = 10; mesh = {(-0.5 + Range[-nmesh, 2 nmesh])/nmesh, (-0.5 + Range[-nmesh, 2 nmesh])/nmesh}; param = Function[{u, v}, {(2 + Cos[2 π v]) Sin[2 π u], (2 + Cos[2 π ...


40

I'd like to expand on Quantum_Oli's answer to give an intuitive explanation for what's happening, because there's a neat geometric interpretation. At one point in the animation it looks like there is a circle of colored dots moving about the center, this is a special case of so called hypocycloids known as Cardano circles. A hypocyloid is a curve generated ...



Top 50 recent answers are included