New answers tagged

2

ClearAll["Global`*"] Remove["Global`*"] {ysol, xsol} = ParametricNDSolve[{x'[t] == x[t] + g*x[t]*y[t], y'[t] == 1 - 2*x[t]^2 - g*y[t]^2, x[1] == 1, y[1] == 1}, {y, x}, {t, 0, 10}, {g}]; ParametricPlot[Evaluate@Table[{y[g][t] /. ysol, x[g][t] /. xsol}, {g, 0, 1, 1/4}], {t, 0, 2}, PlotRange -> {{-3, 3}, {-3, 3}}, PlotLegends -> {"g=1/4", "g=2/4", "g=...


9

You are looking for TransformedRegion. GeometricTransformation is for transforming graphics primitives, but you are looking at region functionality. This is a case where the difference is important. Simply, t = TransformedRegion[p, AffineTransform@A] (* Parallelogram[{0, 0}, {{-1, 2}, {3, 0}}] *) where the AffineTransform was needed as TransformedRegion ...


3

test = points[70]; With somewhat equally spaced points on the sphere from this answer. Graphics3D[{Sphere[], test /. r : {x_, y_, z_} :> Cone[{.95 r, 1.25 r}, .1]}, ImageSize -> Medium, Boxed -> False]


4

Tricks to my mind,Suppose your version is 10.2 or later,although I don't sure you will like Show[SliceContourPlot3D[#, "CenterPlanes", {x, -2, 2}, {y, -2, 2}, {z, -2, 2}, ContourShading -> White] & /@ {x, y, z}, Axes -> True, Boxed -> False, AxesOrigin -> {0, 0, 0}]


12

A mathematical approach using $A_\text{g}$ irreps of $I_h$ symmetry group expressed in terms of spherical harmonics. First some data l[1] = 6; mlist[1] = {-5, 0, 5}; slist[1] = {Sqrt[7]/5, Sqrt[11]/5, -(Sqrt[7]/5)}; l[2] = 10; mlist[2] = {-10, -5, 0, 5, 10}; slist[2] = {Sqrt[187/3]/25, -(Sqrt[209]/25), Sqrt[247/3]/25, Sqrt[ 209]/25, Sqrt[187/3]/25}; l[...


4

Well, maybe you can make something with this? a1 := SliceContourPlot3D[z, x == 0, {x, -5, 5}, {y, -5, 5}, {z, -5, 5}, Background -> Black, ContourShading -> White, Contours -> 9, TicksStyle -> {Red, Green, Blue}] a2 := SliceContourPlot3D[z, y == 0, {x, -5, 5}, {y, -5, 5}, {z, -5, 5}, ContourShading -> White, Contours -> 9] ...


24

This is probably too slow to get a decent image, but here's a simple attempt. As JM suggests, you can use Geodesate to get a good set of points on the sphere. I used ContourPlot3D to plot a sphere whose radius increases in the vicinity of one of those points. Needs["PolyhedronOperations`"] pts = Geodesate[PolyhedronData["Icosahedron"], 2][[1, 1, 14 ;;]]; ...


4

Really just to amplify Simon Woods excellent answer: transforming $f(x,y)$ to a more manageable range (here with log): Plot3D[Log[1 + f[x, y]], {x, 1, 8}, {y, 1.5, 5}, PlotPoints -> 50, MaxRecursion -> 5, MeshFunctions -> {#3 &}, Mesh -> {{0.0005}}, MeshStyle -> {Red, Thickness[0.03]}, Background -> Black, Axes -> False, Boxed ...


9

First you should note that you copied the function down incorrectly. It should be f[x_, y_] := (y - 3 - Abs[x - 3])^2 ((x - 3)^2 + (y - 3 + Sqrt[y^2 - 6 y + 9])^2)^2 ((x - 6)^2 + (y - 3)^2 - 1)^2 + (y^2 - 6 y + 8 + Sqrt[y^4 - 12 y^3 + 52 y^2 - 96 y + 64])^2 The function does not cross zero at the position of the lines, it only touches. For example ...


6

This would reproduce the picture you show in the question: With[{off = 30}, Do[ CreateDocument[{Plot[Sin[i x], {x, 0, Pi}]}, WindowSize -> {300, 200}, WindowOpacity -> .7, WindowMargins -> {{100 + off i, Automatic}, {Automatic, 10 + off i}}], {i, 1, 10}]] I added opacity as per the comment.


4

Okay, so you have a set of Regions that you want to fill, but you can only define those regions by a set of points distributed within them. Let's make some data that reproduces this. Here are three non-overlapping regions that fill up a square: region1 = Disk[{0, 0}, 1, {0, π/2}]; region2 = RegionDifference[Rectangle[], region1]; region3 = Disk[{0, 0}, 1, ...


0

Example Code ListPlot[Range @ 100, Filling -> Bottom] ListLinePlot[Range @ 100, Filling -> Bottom] Output Reference Filling ListPlot ListLinePlot


6

An alternative way of getting a similar display would be to define a new function leftFramed that only puts a vertical extensible line to the left of the content: leftFrame /: MakeBoxes[leftFrame[obj_], _] := RowBox[{"\[LeftBracketingBar]", ToBoxes[obj]}] Framed[x -> leftFrame[ Column[{"Depression", "PTSD", "Diabetes Type II", "Smoker"}]]] ...


6

Would a CellFrame around a TextCell work? Framed[ x -> TextCell[ Column[{"Depression", "PTSD", "Diabetes Type II", "Smoker"}], "Text", CellFrame -> {{True, False}, {False, False}}]]


4

See PlotRange hh = 3; ll = 10; Animate[Graphics[{Thick, Blue, Line[{{0, 0}, {0, hh}}] , Thick, Green , Line[{{xr, 0} , {xr - (ll*xr)/Sqrt[xr^2 + hh^2], (ll*hh)/Sqrt[xr^2 + hh^2]}}]} , Axes -> True , PlotRange -> {{-4, 10}, {0, 4}}] , {xr, 3, Sqrt[ll^2 - hh^2]}]


3

In V.10.4.1, ListPlot works as expected when given the OP's data. i = Table[Labeled[{Re[5 Exp[I 5/2 t]], Im[5 Exp[I 5/2 t]]}, t, {Right}], {t, 0, 6}]; ListPlot[i] So what the OP experienced appears to be a bug that has been fixed.


2

Generally, you can suppress the tooltip-on-formatting-error by setting "FormattingErrorTooltips" (or other related options) to False in the given notebook, or in the front-end: SetOptions[EvaluationNotebook[], AutoStyleOptions -> { "FormattingErrorStyle" -> {FontColor -> RGBColor[1., 0.33, 0.33], Background -> RGBColor[1., 0.33,...


5

The same behaviour is observed in Mathematica 10.4.1 under Windows 10. A fix for the frame ticks is to use the option FrameTicksStyle -> Background -> None


2

I'll give you an example. If you are new to Mathematica, there will be many things to look up. Just select a symbol name and hit F1 (or Command-Shift-F) to look it up in the documentation. Once you understand it, you will be able to edit it to fit your needs. points = RandomInteger[{-5, 5}, {10, 2}]; ListPlot[ Labeled[#, StringForm["(``,``)", #[[1]], #[...


2

In this case, at least, what you seek can be achieved by evaluating the function defining the contour at each of your test points data1 = Select[data, Function[{xy}, xy[[1]]^2/4 + xy[[2]]^2/9 < 1]]; L1 = ListPlot[data1, PlotStyle -> {Blue, PointSize[0.001]}]; P1 = Show[{L1, S0}, AspectRatio -> Automatic]


4

First you produce your data xlim = 4; ds = 0.25; data = Flatten[Table[{i, j}, {i, -xlim, xlim, ds}, {j, -xlim, xlim, ds}], 1]; nic = Length[data] Then you make your contour from arbitrary points and get the polygon out of it pts = RandomReal[{2, 3}] {Cos[#], Sin[#]} & /@ Range[0, 2 Pi, Pi/20]; contour = ListLinePlot[pts, AspectRatio -> 1, ...


3

I came up with a solution using ReflectionTransform[]. Here's my code: TabView[{ "Square" -> Manipulate[Graphics[ {{Opacity[1], Red, Rectangle[{a,b},{c,d}]}, Line[{{5, 5}, {5, -5}}], GeometricTransformation[{Opacity[1], Blue,Large,Rectangle[{a,b},{c,d}]}, ReflectionTransform[{5, 0}, {5,0}]]}],{a,0,2},{b,0,2},{c,1,4},{d,1,4} ], "Triangle" -&...


1

Let's first refactor your code to simplify it. Note I am removing the memoization of T, a, and b, because I don't think you gain much from memoization of these functions. You can easily restore it if you think I've misjudged the situation. T[x_] := Piecewise[{{1 - x, 0 <= x < 1/7}, {(x + 6)/7, 1/7 <= x <= 1}}] a[n_] := n/(n + 1) b[n_] := n/(n + ...


1

I may have found a nice way. However, I think the output is a bit ugly. Here's the working code : NullCurve1[n_] := NDSolve[{ u'[r] == 2/(1 - 1/r), u[0] == 2 n }, {u}, {r, 0, 1}, Method -> Automatic, MaxSteps -> 100000 ] NullCurve2[n_] := NDSolve[{ u'[r] == 2/(1 - 1/r), u[5] == 2 n }, {u}, {r, 1, 10}, Method -&...


2

I will use Eq. 22.7 of your reference $ v = 2 r + 4 m \ln(|r - 2 m|) + B$ The obliques are, I guess is given by $v=-u$. For scaling I am considering $u=2mr$. m = 1/2; Show[ContourPlot[Evaluate@Table[ v == 2 r + 4 m Log[Abs[r - 2 m]] + n, {n, -5, 5}], {r,0,4 m}, {v,-3m,3m}, ContourStyle -> Blue, AspectRatio -> 3/2], ContourPlot[Evaluate@Table[v == -...


0

Piecewise basically uses an array, so you can put it with a Table. for example val = Sort@RandomReal[1, 10] step[x_] = Piecewise[Table[{i, val[[i - 1]] < x < val[[i]]}, {i, 2, 10}]]; Plot[step[x], {x, 0, 1}, GridLines -> {val, {}}] {0.254837, 0.27277, 0.302014, 0.339608, 0.504063, 0.567221, 0.826478, \ 0.869325, 0.879442, 0.904477}


4

You can also do this without LocatorPane. Let's start by creating test data: SeedRandom[25]; pts = RandomReal[200, {10, 2}]; labels = RandomInteger[1000, 10]; map = Deploy@Graphics[{ Disk[#, 10] & /@ pts, PointSize[Large], Red, Point[pts] }, PlotRange -> {{0, 200}, {0, 200}}]; It is important to specify the plot range explicitly, ...


2

As an example img = Graphics[{Blue, Disk[{0, 0}, 1], Red, Disk[{0, 0}, 0.5]}, ImageSize -> 300]; tag[p_] := Piecewise[{{"Red", Norm[p] < 0.5}, {"Blue", 0.5 < Norm[p] < 1}, {"White", Norm[p] > 1}, {"Boundary", Norm[p] == 0.5 || Norm[p] == 1}}] csign[{x_, y_}] := StringForm["[``,``]", Sign[x], Sign[y]] Manipulate[Show[img,...


2

Cases[square, Polygon[x_, ___] :> x, Infinity][[1]] or square[[1, 1]] both give {{0, 0}, {0, 1}, {1, 1}, {1, 0}}


2

Try the following code: Extract[square,Position[square,{_,_}]] Maybe this will help. In a 2-D graphics object, generally this code can extract all the coordinates. Maybe there'll have some problem e.g. like some options with the same form..... I'm currently typing with my tiny phone without my computer, so if there's anything wrong with my code (not ...


4

Here is a solution that with the help of Riffle[] and ListLinePlot[] down = {0, 0} + # {1.5, 1} & /@ Range[0, 10]; up = {0, 1} + # {1.5, 1} & /@ Range[0, 9]; ListLinePlot[Riffle[down, up], Filling -> Axis] Another simple method I think is using Floor[] directly. Plot[Floor[x], {x, 0, 15}, Filling -> Axis]


8

This is a minor bug, acknowledged by WRI and present as of v10.4. The problem is that for Plot3D the required syntax for AxesLabel is a list with three entries instead of two. When given a two-member list as an argument, though, Plot3D silently interprets that as the AxesLabel→Automatic setting, and it labels the axes with the internal variables of the plot, ...


0

LogPolar[x_, y_] := {Log[Sqrt[x^2 + y^2]], ArcTan[x, y]} ImageTransformation[img, LogPolar[#[[1]], #[[2]]] &, DataRange -> {{-Pi, Pi}, {-Pi, Pi}}] Juts for clarification. I am allmost shure that the above doese the inverse Log Polar Transform. To actualy do the transform one would have to use ImageForwardTransform[]. Alternatively ...


7

Since version 10.0, the functions DayHemisphere[], NightHemisphere[], and DayNightTerminator[] are now built-in, and can be used with GeoGraphics[]. These three can either take a specified date, and will otherwise default to Now. One can now do things like this: GeoGraphics[{GeoStyling[GrayLevel[0, 2/3]], NightHemisphere[]}, GeoBackground -> ...


7

In addition to @kglr comment. I would recommend placing all in a single Manipulate and making use of Prolog for the img background. The Graphic is actually resetting its PlotRange as it is redrawn. This is why you need to set it as constant. Manipulate[ Graphics[{ Text[Style["50 Magnets", White, 30], {250, 250}], {White, AbsoluteThickness[5], Line[{...


2

{data1, data2, data3, data4} = {{0.0001, 0.0051, 0.0101, 0.0151, 0.0201, 0.0251, 0.0301, 0.0351, 0.0401, 0.0451}, {0.223635, 0.268779, 0.353563, 0.508274, 0.799853, 1.38739, 2.68267, 5.85528, 14.5708, 41.5504}, {0.15296, 0.184358, 0.245081, 0.361329, 0.598999, 1.14273, 2.57898, 7.04022, 23.4568, 95.0122}, {0.106818, 0.128991, 0.172903, 0....


3

I admit that I am uncertain what the aim is. I post this with the hope that it may prompt correction/clarification with respect to the goal. In the following the mesh shading reflects mesh functions y=Sin[x] (the 1 was used to avoid difficulties with 0). Either one certainly would 'cut the sphere' in half (but any great circle could be chosen without the ...


3

WOW! I made it! Code first~ Graphics2Graph[g_] := Module[{cd = If[FreeQ[g, Line], DirectedEdge @@@ (Extract[g, Position[g, Arrow[___]]] /. Arrow[x_, ___] :> {First@x, Last@x}), UndirectedEdge @@@ Extract[g, Position[g, Line[_]]][[1, 1]]]}, Graph[cd, VertexCoordinates -> Extract[Extract[g, Position[g, ...


5

I thank Rahul for pointing out my blunder. In the following I have changed R3 to be 360 to allow this linkage system to operate. I am not sure whether R3 is meant to be fixed or whether the specified angular speed and angular acceleration are for rotations around O1 and O2 and thus R3 would vary. I post this in case it is helpful or motivating for the ...


0

I made it with a non-perferct solution,but actually I don't content with it.I hope to get a general methond to do this rather than customized for every Graphics. For g1 pos = Cases[Normal[g1], _Arrow, Infinity][[All, 1]]; rule = MapIndexed[Rule[#, First[#2]] &, DeleteDuplicates@Catenate[pos]]; Graph[UndirectedEdge @@@ (pos /. rule), ...


4

Starting with the Szabolcs' Notebook from the comment, it is as simple as follows using Mathematica 10: << PolygonPlotMarkers` fm[name_, size_: 7] := Graphics[{EdgeForm[], PolygonMarker[name, Offset[size]]}] ListPlot[ Table[Accumulate@RandomReal[1, 10] + i, {i, 3}], PlotMarkers -> fm /@ {"Triangle", "Square", "Diamond"}, Joined -> True, ...


2

myRange = Range[0, 6, 0.5] {0., 0.5, 1., 1.5, 2., 2.5, 3., 3.5, 4., 4.5, 5., 5.5, 6.} Graphics[{Line[{{0, 0}, {6, 6}}]}, Frame -> True, GridLines -> {myRange, myRange}] And directly from the documentation: grids[min_, max_] := Join[Range[Ceiling[min], Floor[max]], Table[{j + .5, Dashed}, {j, Round[min], Round[max - 1], 1}]] Graphics[{...


1

Share a solution just applicable to 10.4 or later version.The code is very terse,but it seem to have some mysterious bug in it.And I have post it as a discuss.Firstly I make a function name of diskMake diskMake[region_, n_] := Module[{p, rad, dist, temRegion = region}, SeedRandom[1]; Reap[Do[p = RandomPoint[temRegion]; rad = If[(dist = Abs[...


5

I don't know about PolygonPlotMarkers` package, so I am presenting a general solution. You can always define your own Graphics as markers. For example, I use here regular polygons col = {Red, Blue, Green, Orange, Black}; marker[col_, n_] := Graphics[{col, Polygon[{Cos[2 Pi #/n], Sin[2 Pi #/n]} & /@ Range[n]]} ,...


6

A series of n cosine functions at successively doubled frequencies can be phased so their signs produce a Gray Code (– for 0, + for 1). If these cosines are also scaled to successively halved amplitudes, they partition the plane over one major cycle into 2^n non-overlapping regions, just like the circles of a Venn diagram. These regions cover the angle axis ...


2

You could use Property, e.g. sims = MapIndexed[Property[#2[[1]], VertexShape -> #1] &, simpsons] g = {1 -> 2, 2 -> 4, 2 -> 5, 2 -> 6, 3 -> 4, 3 -> 5, 3 -> 6}; Graph[sims, g, VertexSize -> 0.6] I am posting image of code to see effect:


3

I can't imagine any case where this would be the best option, but no one has mentioned SectorChart yet - where I use equal theta bins, and radius indicates percentage. The only benefit I see is you can compare percentages within a sublist easily. GraphicsGrid[ Partition[ SectorChart[Transpose@{ConstantArray[1, Length@Rest@#], Rest@#}, PlotLabel -&...


6

The data in the question presents a good case for visualization with Chernoff faces. For that data, actually, the Chernoff faces work "out of the box" pretty well! Make faces Load Chernoff faces plotting package: Import["https://raw.githubusercontent.com/antononcube/\ MathematicaForPrediction/master/ChernoffFaces.m"] As it is explained in the question ...


3

Something seems off in the use of ColorFunction by Raster here. This seems akin to the problem reported before in similar matrices containing $(0,1)$ entries (see e.g. MatrixPlot ignores ColorFunction for 0 matrices and ArrayPlot with a user-defined color function is misbehaving). In your case, ArrayPlot seems to work as desired using this synthetic data ...


6

The problem appears only when you use some specific stylesheets of the notebook. To replicate the issue one can choose standard report from Format->Stylesheets->Report. To get rid of the issue you can either use some stylesheet without a background for labels or remove the backgroud by manually changing BaseStyle -> {FontSize -> 17, Background -> ...



Top 50 recent answers are included