8
Here is one way that gives you a proper Graphics expression without rasterization and rotated labels following the contours (code below):
The strategy is as follows:
Use the tricks from @CarlWoll's answer from here to get the plot range in plot coordinates and image coordinates, together with the bounding boxes of all the labels
Group labels together with ...
8
Initialize
Ncut = 10;
eig = RandomReal[{0, 1}, Ncut];
matrix = RandomReal[{0, 1}, {Ncut, Ncut}];
Testing original code
Timing[Plot[Re[OTOC[t, 100.]], {t, 0., 10.}];]
(*15.3793*)
New code
OTOCn[ev_, ma_, t_, T_] := Module[{nc, EE, A, B, b, c, z},
nc = Length[ev];
EE = Table[ev[[n]] - ev[[m]], {n, nc}, {m, nc}];
A = ma*Exp[I*EE*t];
B = ma*EE;
b = ...
7
Here's one way:
fx[t_] :=
Sin[t] + 1/3 Sin[2 t] + 1/5 Sin[3 t + .5] - 1/2 Sin[5 t - .2];
fy[t_] := Cos[t] - 1/2 Sin[3 t] + 1/5 Cos[4 t];
fullplot = Show[
ParametricPlot[{fx[t], fy[t]}, {t, 0, 1},
PlotStyle -> Thickness[0.015], Frame -> True],
Graphics[
{
PointSize[0.025],
Table[{Hue[t], Point@{fx[t], fy[t]},
HalfLine[...
7
Also use NonConvexHullMesh.
pts = Import["xy.dat"];
reg = ResourceFunction["NonConvexHullMesh"][pts, .001];
bdreg = RegionBoundary[reg];
dist = RegionDistance[bdreg];
bdpts = Select[pts, dist[#] == 0 &];
Graphics[{{Green, bdreg}, {Opacity[.2], Yellow, reg}, {Red,
Point[bdpts]}}, AspectRatio -> 1]
7
im is the image.
pts = -Cross /@ DeleteDuplicates[Round[Position[ImageData[im, "Byte"], {25, 204, 255, 255}], 2]];
If you plot the points as huge disks, you can only see the circular boundary of those disks that have a center point on the boundary of the region. In the interior nearby disks cover it.
To check which disks are covered, I used the 10 ...
6
This will work:
ListPlot[{zm, zs} /. phase]
6
A bit kludgy:
SetOptions[ContourPlot, Frame -> None];
f[x_, y_] := x/Exp[x^2 + y^2]; (* plug in your function *)
theColors =
ContourPlot[f[x, y], {x, -2, 2}, {y, -2, 2},
ContourStyle -> None];
theContours =
ContourPlot[f[x, y], {x, -2, 2}, {y, -2, 2},
ContourLabels -> (Text[
Framed[" ", ...
6
Use MapThread to combine all three lists together.
dataWithError = MapThread[{#1, Around[#2, #3]} &, {time, data, error}];
ListPlot[dataWithError];
5
Does not like PostScript, we can not easy to clip the region in Mathematica.
Here we use the positions of the texts to split every contours into two contours and erase some neighborhood points.
SetOptions[ContourPlot, PlotPoints -> Automatic, Frame -> False,
ContourLabels -> All];
f[x_, y_] := x/Exp[x^2 + y^2];
plot = ContourPlot[f[x, y], {x, -2, ...
5
fx[t_] := Sin[t] + 1/3 Sin[2 t] + 1/5 Sin[3 t + .5] - 1/2 Sin[5 t - .2];
fy[t_] := Cos[t] - 1/2 Sin[3 t] + 1/5 Cos[4 t];
We can use a single ParametricPlot to render all graphics primitives:
gap = .25;
plot = ParametricPlot[{{t - (1 + gap), fy[t]},
{fx[t], fy[t]}, {fx[t], t - (1 + gap)}}, {t, 0, 1},
PlotStyle -> Thickness[0.011],
...
4
ParametricPlot[ReIm[Exp[I t]], {t, 0, 2 \[Pi]}] /.
Line[data___] :> {Arrowheads[{{.1, 0.1}, {.1, 0.5}}], Arrow[data]}
There are a lot of explanations about the post-processing .../.Line[data__] :> ... Here
In Arrowheads[{{.1, .09}, {.1, 0.5}}] the .1 specify the size of the arrows, .09 and 0.5 their location along the Line. See Arrowheads ...
4
$Version
(* "12.3.1 for Mac OS X x86 (64-bit) (June 19, 2021)" *)
Clear["Global`*"]
pp = ParametricPlot[ReIm[Exp[I t]], {t, 0, 2 π}];
Show[pp,
Graphics[Arrow /@
Partition[Cases[pp, Line[pts_] :> pts, Infinity][[1]], 221]],
Frame -> True]
EDIT: Re question in comments, to reverse the arrows change the Graphics to
Graphics[...
4
Clear[a, x, y, x1, x2]
SeedRandom[2]
npts = 200;
r = 3;
pts1 = RandomReal[{-1.5, 1.5}, {npts, 2}];
parms = {a -> 1/2, b -> -1/2};
f[x_, y_] := y - a x^2 - b /. parms
px[x_] := 1/2 x Sqrt[1 + 4 a^2 x^2] + ArcSinh[2 a x]/(4 a) /. parms
vecn = Grad[f[x, y], {x, y}];
GRS = {};
INTS = {};
For[k = 1, k <= npts, k++,
{x0, y0} = pts1[[k]];
equs = Join[...
4
data = {{x1, y11, y12, y13, y14},
{x2, y21, y22, y23, y24},
{x3, y31, y32, y33, y34}};
Table[{e[[1]], e[[j + 1]]}, {j, Length@First@data - 1}, {e, data}]
(** {{{x1, y11}, {x2, y21}, {x3, y31}},
{{x1, y12}, {x2, y22}, {x3, y32}},
{{x1, y13}, {x2, y23}, {x3, y33}},
{{x1, y14}, {x2, y24}, {x3, y34}}} **)
3
$Version
(* "12.3.1 for Mac OS X x86 (64-bit) (June 19, 2021)" *)
Clear["Global`*"]
data = {{{0, 0, 0}, 1}, {{0, 1, 1}, 2}, {{0, 2, 1}, 3}};
{fmin, fmax} = MinMax[data[[All, 2]]]
(* {1, 3} *)
Legended[
Graphics3D[
{AbsolutePointSize[6],
{ColorData["Rainbow"][Rescale[#[[2]], {fmin, fmax}]],
Point[#[[1]]]} & /...
3
Little different, the parameters need adjusting
A rough attempt edge detect vertically and horizontally
Using Coolwater's really nice use of ShortestPath to plot
v = Table[
Position[xy[[All, 1]], #] & /@
MinMax[Select[xy, i + 0.001 > #[[2]] > i &][[All, 1]]], {i, 0.01,
0.026, 0.001}] // Flatten
h = Table[
Position[xy[[All, 2]], ...
3
Thread[{First@#,Rest@#}]&/@data//Transpose
(* {
{{x1, y11}, {x2, y21}, {x3, y31}},
{{x1, y12}, {x2, y22}, {x3, y32}},
{{x1, y13}, {x2, y23}, {x3, y33}},
{{x1, y14}, {x2, y24}, {x3, y34}}
} *)
Original Answer:
Distribute[{First@#, Rest@#},List]&/@data//Transpose
Alternative form:
ArrayReduce[Thread[{First@#,Rest@#}]&, data, 2]...
3
Clear["Global`*"]
Format[x[n_]] := Subscript[x, n]
Format[y[m_, n_]] := Subscript[y, Row[{m, n}]]
(data = {{x[1], y[1, 1], y[1, 2], y[1, 3], y[1, 4]},
{x[2], y[2, 1], y[2, 2], y[2, 3], y[2, 4]},
{x[3], y[3, 1], y[3, 2], y[3, 3], y[3, 4]},
{x[4], y[4, 1], y[4, 2], y[4, 3], y[4, 4]},
{x[5], y[5, 1], y[5, 2], y[5, 3], y[5, 4]}}) // ...
2
newdata = Flatten /@ data;
ListLinePlot[newdata]
2
ParametricPlot[ReIm[Exp[I t]], {t, 0, 2 π},
PlotStyle -> Arrowheads[Table[Large, 4]]] /. Line -> Arrow
ParametricPlot[ReIm[Exp[I t]], {t, 0, 2 π},
PlotStyle -> Arrowheads[Table[-Large, 4]]] /. Line -> Arrow
2
OP
We should Flatten the data about b and set the AspectRatio -> Automatic to use the original scaling.
n = 3;
θ = (2 π Range[0, n])/n;
points = Transpose@{Cos[θ], Sin[θ]};
k = Range[3];
p = Outer[Times, k, points]; a =
ListLinePlot[p, Frame -> True, Axes -> False, PlotStyle -> Blue,
PlotRange -> All];
b = ListPlot[Flatten[p, 1], ...
1
phase//{#[[All,1,2]], #[[All,2,2]]}&//Transpose
(* {
{12.73535715316104351, 9.723489861598359832},
{12.43979562050203259, 9.567733383973450101},
{12.32279426102503596, 9.508340658126474139},
{12.28344374937853646, 9.488561086768208567},
{12.27076871646887047, 9.482208331885304556},
{12.26673755236051688, 9.480189699199461710}...
1
The goal is to find the slope where the solution crosses the real or x-axis. The solution is a list of points, and your graph shows their positions, but the points are in an inconvenient order which is apparent with Joined -> True. We can use DerivativeFilter to compute a slope value at each point, but we need to rearrange the points from the solution.
...
1
If you remove AxesStyle -> Opacity[0], you can see that the $z$ axis is shown from approximately -30 to 30. Therefore, the image is squeezed (because your forced the BoxRatios to be {1, 1, 1}), and that is why your normal vector do not look perpendicular (even though they are).
Solution 1
Use PlotRange -> {-10, 10} to fix the range of $z$ axis and then ...
1
works in 12.3.1
Plot3D[x y, {x, y} \[Element] Disk[{0, 0}, 1], ImageSize -> 500, PlotTheme -> "Web"]
1
It is not clear from your question if you want also the points in your ListPlot to be coloured. If this is the case then have a look [here][1]:
If not, maybe something like this
GraphicsRow[{ListPlot[datadd[[All, {1, 2}]]],BarLegend[{Hue, MinMax[datadd[[All, 3]]]}]}]
Only top voted, non community-wiki answers of a minimum length are eligible
