New answers tagged plotting
2
Change the last part to the following:
...
Joined -> {True, True, True, True, True, True, True, True, True, True},
LegendLayout -> "Row",
LegendFunction -> "Frame",
LegendMargins -> {{10, 10}, {10, 10}},
ImageSize -> {600, 15}
]
Curiously, it says that ImageSize is not an option for the LineLegend (at least on v12.2.0)...
6
Please post plain text code so one can copy it. Hard to copy code from images. Unless one uses AI to scan the image and have it convert to Mathematica code.
Try this
ClearAll[f, x, y];
f[x_?NumericQ] := Piecewise[{{x + 2, x <= -1}, {-x, -1 < x < 1}, {x - 2, x >= 1}}]
VectorPlot[{100*(y - f[x]), -x/100}, {x, -3, 3}, {y, -3, 3}]
You needed to add ?...
2
Update Arbitrary positioning of labels
Using Inset they can be positioned anywhere by adjusting the values of position.
position = {0.75, 0.9}
labeled =
MapThread[
Show[{#1},
Epilog ->
Inset[Graphics[{Text[Style[#2, Blue, Bold, 25]]}],
Scaled[position]]] &, {images, labels}]
labeled // Partition[#, UpTo@3] & // Grid[#, ...
1
Not quite there yet, but this may give you (and others) an approach to the problem.
plotImages = (paste image here)
plotLabels = GraphicsGrid[{
{"Plot 1", "Plot 2", "Plot 3"},
{"Plot 4", "Plot 5", "Plot 6"},
{"Plot 7", "Plot 8", "Plot 9"}
},
Spacings ...
2
Something like this maybe?
mtx = ArrayReshape[Range[35], {7, 5}];
{w,h} = Dimensions@mtx;
coords = Reverse@Transpose@CoordinateBoundsArray[{{1,h},{1,w}},1]-.5;
bubbs = Flatten[MapThread[Append,{coords,mtx},2],1];
Show[
MatrixPlot[mtx, PlotTheme -> "Marketing"],
BubbleChart[bubbs, PlotTheme -> "Marketing"]
]
6
You can use the option Joined -> True in DiscretePlot:
DiscretePlot[x Sin[1/x]^2, {x, π/4, π, π/80},
PlotStyle -> EdgeForm[{Thin, Gray}],
ColorFunction -> "Rainbow",
ExtentSize -> Full,
Joined -> True]
4
One way is to combine stylized outputs from DiscretePlot and Plot:
Show[
DiscretePlot[
x Sin[1/x]^2,
{x, π/4, π, π/80},
BaseStyle -> EdgeForm[Directive[AbsoluteThickness[0.75], GrayLevel[0.25]]],
ColorFunction -> "Rainbow",
ExtentSize -> Full,
PlotStyle -> AbsoluteThickness[0.75]
],
Plot[
x Sin[1/x]^...
2
Show[Plot3D[3 x + y, {x, -10, 10}, {y, -10, 10},
PlotStyle -> Opacity[.75]],
ContourPlot3D[
x^2 + y^2 == 10, {x, -10, 10}, {y, -10, 10}, {z, -10, 10}]]
3
What can I do to have a sequences of j and n in Plot function without
specifying paticular numbers
If I understand you right, you can first generate the j,n data first
Clear["Global`*"]
data = Flatten[Table[{j, n}, {j, 3}, {n, 3}], 1]
Now generate the functions for each j,n above
f[j_, n_, x_] :=
Piecewise[{{0, j/2^n <= x && x <= (...
1
Add the option ColorFunctionScaling -> False to BarLegend:
Plot[{}, {x, 0, 1},
PlotLegends ->
Placed[BarLegend[{Blend[{{0, Hue[0., 0.1, 1]}, {1,
Hue[0., 0.8, 1]}, {1.01, Hue[0.3, 0.1, 1]}, {2,
Hue[0.3, 0.8, 1]}, {2.01, Hue[0.7, 0.1, 1]}, {3,
Hue[0.7, 0.8, 1]}}, #] &, {0, 3}}, "Ticks" -> {0, 1, 2, 3},
...
2
Use PlotMarkers rather than PlotStyle
Show[
ListPlot[
{{{0.7, 0.12}}, {{0.8, 0.2}}, {{0.5, 0.4}}},
PlotMarkers -> {Style[●, Blue, 20],
Style[●, Blue, 20], Style[○, Black, 20]},
PlotRange -> {{0.3, 1}, {0, 3}}],
Plot[{1/(Pi x^2), 1 - 2 x}, {x, 0.3, 1},
PlotStyle -> {{ColorData[97][1], Thick}}],
AxesOrigin -> {0.3, 0},
ImageSize -&...
7
SeedRandom[1]
data = RandomReal[ParetoDistribution[3, 4], {2, 100}];
bwc = BoxWhiskerChart[data,
{{"Whiskers", Thick},
{"Outliers", Style["○", Red]},
{"MedianMarker", Directive[Thick, Yellow]},
{"Fences", Thick}},
ChartStyle -> {EdgeForm[{Black,Thickness[.007]}],
{RGBColor[{178, 34, 34}/...
4
pts = {{0, 0.141026}, {1, 0.141026}, {2, 0.140424}, {3, 0.140424}};
ListLogPlot[{
pts,
Table[{x, 0.1405}, {x, 5, 9}]
},
Joined -> {False, True},
PlotStyle -> {
{Red, PointSize[0.02]},
{Black, Thickness[0.01]}
},
PlotRange -> {{0, 25}, {0.12, 0.16}},
Frame -> True,
FrameLabel -> {"n", "M (GeV)"},
...
3
This problem is one of those things that comes up a lot, but each question has slight differences that make agreement about being a duplicate is hard to reach. Here is a solution that can achieved by a slight tweak to one line in
@Szabolcs' answer:
cleanRegionPlot@RegionPlot[..]
For instance:
Export[FileNameJoin[{$TemporaryDirectory, "clean.pdf"}],...
6
As a workaround we can express the Polygon complex through its boundary representation:
plot = RegionPlot[x^2 + y^3 < 2, {x, -2, 2}, {y, -2, 2}];
Export["/Users/ghurst/Desktop/plot.pdf", plot];
gcps = Position[plot, gc_GraphicsComplex, ∞];
breps = BoundaryDiscretizeGraphics /@ Extract[plot, gcps];
faceform = Append[ColorData[97, 1], 0.3];
...
4
ClearAll[f, functions]
f[u_] := {u, (1 - u) Sin[10 u], (1 - u) Cos[10 u]/3};
plotrange = 4;
padding = .5;
Construct three additional functions replacing $i^{th}$ coordinate of f[u] with a constant corresponding to the plane of projection:
functions[u_] := Prepend[f[u]][
MapThread[ReplacePart[f[u], # -> #2 (plotrange + padding)] &,
{{1, 2, 3}, ...
1
This can be done as follows.
a = VectorPlot[{-y, x}, {x, -3, 3}, {y, -3, 3}, VectorColorFunction -> None,
VectorStyle -> Blue, VectorSizes -> {0, 1/2}];
b = VectorPlot[{-2 y, 2 x}, {x, -3, 3}, {y, -3, 3},VectorColorFunction -> None,
VectorStyle -> Red, VectorSizes -> {0, 1}];
Show[{b, a}]
5
A starting point.
annulus = RegionDifference[Disk[{0, 0}, 2.3], Disk[{0, 0}, 2]];
regint[r_] := RegionDifference[Disk[{0, 0}, 2.3], Disk[{0, 0}, r]];
ani = Animate[
Show[Region[regint[r],
BaseStyle -> {Blend[{LightYellow, Orange}, .15],
EdgeForm[Directive[Thick, Black]]}],
Region[annulus,
BaseStyle -> {Gray, EdgeForm[Directive[...
11
{minradiusa, radiusb, radiusr} = {.2, .85, 1};
Labeled arrow annotations:
labeledArrows[r_] := {PointSize[Medium], Point[{0, 0}],
MapThread[{
Arrowheads[{{.025, 1},
{Automatic, .5, Graphics[{Text[Style[#, 16], {0, 0}, {0, -1.2}, #2]}]}}],
Arrow[{{0, 0}, #3 {Cos[#4 Pi/4], Sin[#4 Pi/4]}}]} &,
{{#<>"(t)", ##2}&...
4
Use Plot3D with $z = x + iy$.
Plot3D[Arg[x + I y], {x, -1, 1}, {y, -1, 1}, ColorFunction -> "Rainbow"]
1
table = {{"", "1/Viscosity", "Permeance", "Error"},
{"EG", 2.22`*^10, 2.57`, 0},
{"DMSO", 8.7`*^10, 14.09`, 1},
{"Ethanol", 3.03`*^11, 53.67`, 2},
{"UP", 3.6`*^11, 67.5`, 5},
{"Methanol", 6.12`*^11, 110.33`, 16},
{"Toluene&...
1
Without solving your homework, I will try to help you resolve the problem you have at the moment.
Let's say the following command is executed. It gives you the time required for calculations and the results.
AbsoluteTiming[FactorInteger[2^200 - 1]]
{0.0296725, {{3, 1}, {5, 3}, {11, 1}, {17, 1}, {31, 1}, {41, 1}, {101,
1}, {251, 1}, {401, 1}, {601, 1}, {...
2
SeedRandom[1]
data = RandomInteger[10, {4, 3}];
n = Last @ Dimensions[data];
Looks like RadialAxisPlot does not allow user specified ticks.
A work-around: Construct the axes with desired ticks using AxisObject:
ticks = {{0, 7, 15}, { 2, 8, 10}, { 2, 8, 10}};
axes = MapThread[AxisObject[Line[{{0, 0}, #}], {0, #2},
TickPositions -> {{#3}, {0, #2, 1}}...
2
show = Show[
Legended[p1, LineLegend[{Directive[Thickness[0.006], Dashed, Black]}, {"p1"}]],
Legended[p2, LineLegend[{Directive[Thickness[0.006], Dotted, Black]}, {"p2"}]],
Legended[p3, LineLegend[{Directive[Thickness[0.006], Black]}, {"p3"}]]];
Process show to get the main plot and legends and construct a new ...
0
JimB's answer is great, I wish I'd found it years ago. That said, sometimes I have data where the contours are very irregular, and I don't want a break in the contour line. Below is a simple version of the solution I use. This also gives control on label placement, one of the original concerns.
Considering the graphic used above;
cPlot = ContourPlot[x y, {...
1
Clear["Global`*"]
$Version
(* "12.3.1 for Mac OS X x86 (64-bit) (June 19, 2021)" *)
Use the option Prolog (or Epilog)
VectorPlot[{{y, -x}}, {x, -4, 4}, {y, -4, 4},
Prolog -> ({AbsoluteThickness[0.7], Gray,
Circle[{0, 0}, #] & /@ Range[5]})]
1
From the docs: (under Possible Issues)
Contours f(x,y)==0 for functions where f(x,y)>=0 are always poorly
detected
f[x_?NumberQ, y_?NumberQ] :=
Boole[RealAbs[x + 1/y] + RealAbs[10/3 - x + y] == 10/3 + y + 1/y]
Giving a value in between allows for easy contouring:
ContourPlot[f[x, y] == 0.5, {x, -5, 5}, {y, -5, 5}, PlotPoints -> 50]
2
VectorPlot[{{y, -x}}, {x, -4.1, 4.1}, {y, -4.1, 4.1},
StreamPoints -> {{1, 0}, {2, 0}, {3, 0}, {4, 0}},
StreamStyle -> Black, StreamColorFunction -> None,
StreamScale -> None, PlotRange -> All]
2
Try
Show[{VectorPlot[{{y, -x}}, {x, -4, 4}, {y, -4, 4}],
Graphics[Table[Circle[{0, 0}, i], {i, 1, 5}]]}]
7
You are trying to visualize the relation
$$
|f(x,y)| + |g(x,y)| = f(x,y) + g(x,y)
$$
where $f(x,y) = x+1/y$ and $g(x,y) = \frac{10}{3} - x + y$. In the above form, it is fairly evident that this relation is satisfied if and only if $f(x,y) \geq 0$ and $g(x,y) \geq 0$. In other words, this equation does not define a contour; it defines a region:
RegionPlot[...
2
SeedRandom[1];
systolic = ReverseSort /@ RandomInteger[{70, 180}, {24, 2}];
diastolic = ReverseSort /@ RandomInteger[{40, 120}, {24, 2}];
We can use PairedBarChart and post-process the output to get a 3D look as in the example in OP:
barspacing = {0, 2, 0};
pbc = PairedBarChart[systolic, diastolic,
BarOrigin -> "XAxis",
BarSpacing ->...
3
An alternative using Tube
Clear["Global`*"]
SeedRandom[1234];
values[{x, z}] = Table[{i, 0, RandomInteger[{10, 15}]}, {i, 0, 10}];
values[{x, y}] = Table[{i, RandomInteger[{1, 10}], 0}, {i, 0, 10}];
Graphics3D[{
CapForm["Square"],
Tube[{ReplacePart[#, 3 -> 0], #}, 1/4] & /@ values[{x, z}],
Tube[{ReplacePart[#, 2 -> 0], #...
4
For a start:
valxz = Table[{i, 0, RandomInteger[{10, 15}]}, {i, 0, 10}];
valxy = Table[{i, RandomInteger[{1, 10}], 0}, {i, 0, 10}];
Graphics3D[{PointSize[0.03],
Point[valxy], Point[valxz], Thickness[0.01],
Line[{{{1, 0, 0} #, #}}] & /@ valxy,
Line[{{{1, 0, 0} #, #}}] & /@ valxz
}, Axes -> True, Boxed -> False, AxesOrigin -> {0, 0, 0}...
3
ClearAll[data, time];
SeedRandom[21];
data = RandomReal[{1, 100}, {24, 12}];
time = Transpose@{{2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017,
2018, 2019, 2020, 2021}};
data1 = PrependTo[data, time // Flatten] // Transpose;
plot[n_] := Labeled[
ListLinePlot[
Transpose[data1][[{2 n, 2 n + 1}]],
PlotLegends -> Placed[{2 n, 2 n + 1}, Above],
...
1
You can add rectangles representing excluded regions. Modify P1 as follows:
P1 = ListPlot[Abs[Tab1], Frame -> {True, True, True, True},
PlotRange -> {0.02, 0.04},
FrameLabel -> {\[Delta], Subscript[R, \[Nu]]},
BaseStyle -> {FontSize -> 14},
Epilog -> {
Lighter@Blend[{Blue, Cyan}, 0.4],
Opacity[0.4],
Rectangle[{-10, 0....
2
Clear["Global`*"]
$Version
(* "12.3.1 for Mac OS X x86 (64-bit) (June 19, 2021)" *)
Subscript[
R, ν][δ_, θ12_, θ13_, ϵ_] := (2 \
ϵ)/(1/
64 Sec[θ12 Degree]^4 Sec[
2 θ12 Degree]^4 Sec[θ13 Degree]^10 (16 Cos[
2 θ12 Degree]^4 Cos[θ13 Degree]^8 (1 +
Cos[2 θ12 Degree] Cos[θ13 Degree])^2 Sin[
2 ...
0
Not an answer, but an essential warning !
For t->1500 you have more than 300 oscillations of x[t]. Even at best Workingprecision numerical NDSolve will give total wrong result for higher t. See examples. A workaround could be solutions with DSolve (but my MMA version doesn't find any.)
sol1 = NDSolve[{v'[t] ==
0.320 x[t] - 1.65 x[t]^3 - 0.005*v[t] + 0....
2
surf1[a_, b_] =
ContourPlot3D[
y^2/a^2 + z^2/b^2 == 1, {x, -5, 5}, {y, -5, 5}, {z, -5, 5},
RegionFunction ->
Function[{x, y, z},
z^2/b^2 + x^2/a^2 >= 1 && z >= 0 && Abs[x] <= Min[a, b] &&
Abs[y] <= Min[a, b]], PlotPoints -> 50,
RegionBoundaryStyle -> None, Mesh -> None];
surf2[a_,...
1
$Version
(*12.3.0 for Microsoft Windows (64-bit) (May 10, 2021)*)
Try this:
dots[x_, y_, z_] := {{MaterialShading["Plastic"]}, EdgeForm[None],
Sphere[{x, y, z}, 0.105], Lighting -> "ThreePoint"}
With[{Aa = {0, 1, 0}, Bb = {1, 0, 0}},
Graphics3D[Table[dots @@ (Aa j + Bb k), {j, 1, 20}, {k, 1, 20}],
Boxed -> False, ...
2
Maybe you can try this:
ListPointPlot3D[plotting]
EDIT
Show[ListPointPlot3D@plotting, Graphics3D@Line@plotting,
PlotRange -> All]
2
One possible method.
section =
ContourPlot3D[({x, y, z} - B) . Cross[A - B, C1 - B] == 0, {x, -20,
20}, {y, -20, 20}, {z, -.1, .2},
RegionFunction -> Function[{x, y, z}, 0 <= z <= r1[x, y]],
PlotPoints -> 80, ContourStyle -> Blue, Mesh -> None,
RegionBoundaryStyle -> Directive[Opacity[.2], Yellow],
BoundaryStyle -> ...
3
Note your plane is perpendicular to the x/y plane. Therefore, the y value only depends on x. We can define a function y[x] by requesting that the line goes through A and C1:
eq = {A[[1]] cx + c0 == A[[2]], C1[[1]] cx + c0 == C1[[2]]};
y[x_] = cx x + c0 /. Solve[eq, {cx, c0}][[1]]
We may now plot the surface of r1 and combine it with a plot of the ...
3
Clear["Global`*"]
$Version
(* "12.3.1 for Mac OS X x86 (64-bit) (June 19, 2021)" *)
Manipulate[
Plot[x*Sin[x], {x, xint[[1]], xint[[2]]},
PlotRange -> {yint[[1]], yint[[2]]},
ImageSize -> 360],
{{xint, {0, 2 Pi}, "x interval"},
0, 2 Pi, Pi/50.,
ControlType -> IntervalSlider,
Method -> "Push", ...
3
One approach:
Manipulate[
Manipulate[Plot[Sin[x (1 + x)], {x, 0, 6}],
{a, 0, 2},
ControlPlacement -> Bottom,
Paneled -> False],
{y, 0, 6},
ControlPlacement -> Left,
ControlType -> VerticalSlider,
Alignment -> Bottom,
Paneled -> False]
Also, building up what you want to do from Dynamic may give you additional control over ...
0
Something like this?
Manipulate[Plot[Sin[x (1 + a x)], {x, 0, 6}], {a, 0, 2},
ControlPlacement -> Bottom]
('ControlPlacement' is the thing that may help. Compare with
Manipulate[Plot[Sin[x (1 + a x)], {x, 0, 6}], {a, 0, 2},
ControlPlacement -> Top]
Depends you your code.)
Looks like one of your controls wants to be a VerticalSlider.
DynamicModule[...
2
the animation of the 3D plot doesn't show the top most part of the
generated surface
Add PerformanceGoal -> "Quality" It was not showing it all before, because default is Speed
Animate[
Plot3D[f[a, b, 2, 200, 1, k, \[Pi]/2], {a, -10, 10}, {b, -10, 10},
PlotRange -> All, LabelStyle -> Directive[Bold, Medium],
Mesh -> None,
...
2
Here we have made some changes of your code.
eq = ϕ''[t] +
3*ϕ'[t]*
Sqrt[(8*Pi*G/3)*(0.5*ϕ'[t]^2 +
0.5*m^2*ϕ[t]^2)] + ϕ[t]*m^2 == 0;
sol = ParametricNDSolve[{eq /. {G -> 1, m -> 0.5}, ϕ'[0] ==
a, ϕ[0] == b}, {ϕ, ϕ'}, {t, 0, 1}, {a, b}];
ParametricPlot[
Flatten[Table[{ϕ[a, b][t], ϕ'[a, b][t]}, {a, -1,
1, .25}, {b, -1, ...
1
Clear["Global`*"]
$Version
(* "12.3.1 for Mac OS X x86 (64-bit) (June 19, 2021)" *)
f[δ_, θ12_, θ13_, θ23_] =
2 E^(-I δ) Sec[θ12]^2 (-(1/4) E^(2 I δ) (7 +
Cos[8 θ12]) Cos[θ23]^2 Sec[2 θ12]^2 +
8 E^(2 I δ) Cos[δ] Cos[θ12] Cos[θ23] \
Sin[θ12] Sin[θ13] Sin[θ23] -
Sin[θ13] ((1 + 4 E^(2 I δ) + 2 E^(4 I δ) +
...
0
Try this:
sol = Table[
NDSolve[{\[Phi]''[t] +
3*\[Phi]'[t]*
Sqrt[(8*Pi*1/3)*(0.5*\[Phi]'[t]^2 +
0.5*0.5^2*\[Phi][t]^2)] + \[Phi][t]*0.5^2 ==
0, \[Phi][0] == RandomReal[{-1, 1}], \[Phi]'[0] ==
RandomReal[{-1, 1}]}, \[Phi], {t, 0, 1}], 50];
ParametricPlot[Evaluate[{\[Phi][t], \[Phi]'[t]} /. sol], {t, 0, 1},
...
8
You can change the order and use the options for plot in Show. That is, use
Show[plan, plot, Options[plot]]
Top 50 recent answers are included