New answers tagged

0

Clear["Global`*"] font = 18; DensityPlot[LogTQ + LogA, {LogTQ, -2, 1}, {LogA, 2, 6}, PlotLegends -> BarLegend[{"SunsetColors", {0, 7}}, LegendLabel -> StringForm["``(``)", Subscript[log, 10], Subscript[P, C]]], FrameTicksStyle -> Directive[font], FrameLabel -> (StringForm["``(``)", Subscript[...


0

Plot3D creates a plot using a function and two variables. Essentially, for Plot3D the function generates the z coordinate and you supply the x and y coordinates. For ParametricPlot3D you supply 3 functions, where each function controls how that one axis is spanned. For example ParametricPlot3D[{Sin[x],Cos[x],x},{x,1,10}] the x axis is spanned using Sin[x], ...


3

Clear["Global`*"] $Assumptions = a > 0 && ρ > 0; z[ρ_, ϕ_, a_ : 1, nmax_ : 40] := 50 + 200/Pi + Sum[(ρ/a)^(2 n + 1) Sin[(2 n + 1) ϕ]/(2 n + 1), {n, 0, nmax}]; Plot3D[z[ρ, ϕ], {ρ, 0, 1}, {ϕ, 0, Pi}, WorkingPrecision -> 20, PlotPoints -> 75, MaxRecursion -> 5] // Quiet If the number of terms is infinite f = z[ρ,...


0

j1 = Table[{i, Sin[2^2 + i]}, {i, 0, 3, 0.05}]; k1 = ListLinePlot[j1] Extract the line and convert it to 3D y0 = 2; line = Cases[k1, Line[pts_] :> Line[{#[[1]], y0, #[[2]]} & /@ pts], Infinity][[1]]; s1 = Table[{i, j, Sin[j^2 + i]}, {i, 0, 3, 0.1}, {j, 0, 3, 0.1}]; Combine the line with the ListPointPlot3D Show[ ListPointPlot3D[s1], ...


3

Here's my trial: SeedRandom[2020]; data = Flatten[Table[{th, phi, RandomReal[100]}, {th, 0, 45, 3}, {phi, 0, 90 Degree, 2 Degree}], 1]; func = Interpolation[data]; {{rmin, rmax}, {phimin, phimax}} = func["Domain"]; radian = 32; dphi = 15 Degree; Legended[ParametricPlot[r {Cos[phi], Sin[phi]}, {r, ...


0

Try this: {yL, yR} = {-1, 1}; colorfunc = "Rainbow"; ParametricPlot[{x, x^2 + 6 y^(3/2)}, {x, -4, 4}, {y, yL, yR}, ColorFunction -> Function[{xaxis, yaxis, x, y}, ColorData[colorfunc][y]], AspectRatio -> 1/GoldenRatio, PlotLegends -> BarLegend[{colorfunc, {yL, yR}}]] Do notice this visualization won't work well on those functions ...


2

Here is just a draft that needs to be updated later since I am not so familar with Physic. The code has some bugs :-( Accoring to Kepler's Equation : $M=E-\mathrm{e}\sin E$ Clear["`*"]; a = 5; b = 3; c = Sqrt[a^2 - b^2]; e = c/a; p = b^2/c; ρ[θ_] = (p*e)/(1 + e*Cos[θ]); fig = PolarPlot[ρ[θ], {θ, 0, 2 π}]; angle[M_] := 2 (π + ArcTan[Sqrt[(1 + e)/...


9

28 characters: Image@Array[(-1)^+## &, {8, 8}] 12 key strokes: =chess board


1

This use of ImagePadding works on a simple example: pTop = Plot[Sin[x], {x, 0, 2 Pi}, Frame -> True, Axes -> False, ImagePadding -> {{All, All}, {0, All}}]; pMid = Plot[Sin[x], {x, 0, 2 Pi}, Frame -> True, Axes -> False, ImagePadding -> {{All, All}, {0, 0}}]; pBot = Plot[Sin[x], {x, 0, 2 Pi}, Frame -> True, ImagePadding -> ...


7

Try Image[Array[Mod[#+#2,2]&,{8,8}]]


1

Here is one way where you can control the size along x and y of each subfigure plot1 = With[{XZ = 210, YZ = 70}, Plot[Sin[x], {x, -2 \[Pi], 2 \[Pi]}, Frame -> True, ImageSize -> Automatic -> {XZ, YZ}, ImagePadding -> 80, PlotStyle -> Red, Axes -> False]]; Grid[{{plot1}, {plot1}, {plot1}}, Spacings -> {-12, -12}] and you ...


0

What do you mean by "plot the nonlinear difference equations"? I assume that you want, analogously to differential equations, to get a "velocity field". Towards this aim, you need to calculate the difference between x/y at n and n+1. Therefore you must not include the first x and y. In addition, your code has several syntax errors, I ...


0

WolframAlpha["plot vector(1,1)+vector(2,3)", {{"Result", 1}, "Content"}] To see the code behind you can take the first Part: WolframAlpha["plot vector(1,1)+vector(2,3)", {{"Result", 1}, "Content"}][[1]] To get the main graphics, use WolframAlpha["plot vector(1,1)+vector(2,3)", {{"...


2

Here's an approach based on the fifth argument of Inset: Graphics[ { Inset[ Graphics[{}, Frame -> {{True, False}, {True, False}}, FrameTicksStyle -> (FontOpacity -> 0), PlotRange -> {{0, 1}, {0, 1}} ], {0, 0}, {0, 0}, {1, 1}, {{1, 0.5}, {0.5, 1}} ] }, Frame -> {{True, False}, {True, False}}, PlotRange -> {{0, ...


4

Simply use Column: pl = Plot[Sin[x], {x, 0, 2 Pi}]; Column[{pl, pl}, Frame -> All, Spacings -> 0]


4

https://resources.wolframcloud.com/FunctionRepository/resources/PlotGrid ResourceFunction[ "PlotGrid"][{{Plot[Sin[x], {x, 0, 1}, Frame -> True, FrameLabel -> {None, x}]}, {Plot[Cos[x], {x, 0, 1}, Frame -> True, FrameLabel -> {None, x}]}}, FrameLabel -> {2 Pi t, None}]


0

Here is a first try. I do not claim that it is perfect, but it may serve as a starting point.: skeweaxes[{{xmin_, xmax_}, {ymin_, ymax_}}, phi_] := Module[{nxti = 20, nyti = 20, xtlen = (ymax - ymin)/100, ytlen = (xmax - xmin)/100}, rot0 = RotationTransform[phi]; rot1 = RotationTransform[-phi]; t0 = {rot0 /@ {{xmin, ymin}, {xmax, ymin}}, rot1 /...


2

Clear["`*"]; equ = Sqrt[t1^2 + u1^2] + Sqrt[t2^2 + u2^2] <= 1 && x == 2 t1 - u1 + 2 t2 + u2 && y == 2 u1 + t1 + 2 u2 - t2 && Element[{t1, u1, t2, u2}, Reals] reg = ImplicitRegion[equ, {x, y, t1, u1, t2, u2}] Resolve[Exists[{t1, u1, t2, u2}, {x, y, t1, u1, t2, u2} ∈ reg], Reals] The result is (y == -Sqrt[5] &...


2

The Moiré effect is exacerbated by the NormalsFunction. If you get rid the normals, the aliasing disappears around PlotPoints -> 800. With the normals, you probably have to go higher, doubling the plot points a few times perhaps. However, the plot below is already quite large and difficult to work with. It seems more sensible to me to reduce L to ...


2

There is so long post, but answer very short. At first step we define 3 function: r0[u_?NumericQ, v0_?NumericQ] := 2 (1 + LambertW[(u^2 - v0^2)/E]); z[u_?NumericQ, v0_?NumericQ] := NIntegrate[ Sqrt[2 (Exp[r/2] - v0^2)/(r*Exp[r/2] - 2*(Exp[r/2] - v0^2))], {r, r0[0, v0], r0[u, v0]}, AccuracyGoal -> 2, PrecisionGoal -> 2] wh[v0_?NumericQ] := ...


1

Perhaps the logarithmic spiral is a suitable curve. $$ a(\mathrm{e}^{bt}\cos t,\mathrm{e}^{bt}\sin t)$$ Solve[{({a*Exp[b*t] Cos[t], a*Exp[b*t] Sin[t]} /. t -> 0) == {300, 0}, ({a*Exp[b*t] Cos[t], a*Exp[b*t] Sin[t]} /. t -> π/2) == {0, 480}}, {a, b}, Reals] ParametricPlot[{a*Exp[b*t] Cos[t], a*Exp[b*t] Sin[t]} /. %, {t, 0, π/2}]


1

ω^2/c^2 ρ^2 + z^2=ρ^2 + z^2,so Sinc[ρ^2 + z^2] can be write by Sinc[t^2],t^2=ρ^2 + z^2,It means the graph is only depend on the distance from z-axis, so we can rotate Sinc by z-axis to get the plot. RevolutionPlot3D[Sinc[t^2], {t, -25, 25}, ColorFunction -> "Rainbow", Mesh -> None, PlotPoints -> 100, Boxed -> False, ViewPoint -> {...


4

Your differential equation describes a vector field (velocity field) that you may display e.g. using SliceVectorPlot3D: SliceVectorPlot3D[{2 x1^2, -2 x2^2, 3 x3^2}, "CenterPlanes", {x1, -.1, .1}, {x2, -.1, .1}, {x3, -.1, \ .1}, PlotTheme -> "Scientific"] You see, that e.g. a particle coming from below from {0.1,-0.1,-0.1} with ...


1

You need to set ColorFunctionScaling to False, otherwise the x coordinate will be rescaled to lie between 0 and 1 before it is passed to the color function. Plot[ {Cos[x], Sin[x]}, {x, 0, Pi}, ColorFunction -> Function[ {x, y}, If[ Abs[Cos[x]] > Abs[Sin[x]], Red, Blue ] ], ColorFunctionScaling -> False ]


4

q := 1.6*10^-19; me := 9.1*10^-31;(*Free electron rest mass in kg*)h := 6.63*10^-34;(*Reduced Planck's constant in J.s*)kb := 1.38*10^-23;(*Boltzmann constant in J/K*) Jschottky[V_, T_] := (2 q*(2 \[Pi] me)^0.5 kb^1.5)/h^2*(0.3)^0.5* Exp[-0.18/((kb*T)/q)] (Exp[(q*V)/(kb*T)] - 1); p1 = LogPlot[Abs[Jschottky[V, 77]], {V, -0.5, 0.5}, PlotRange -> All, ...


2

you can also use the buiilt-in (but undocumented) chart element function System`BarFunctionDump`TextureBar with your custom textures: ClearAll[texture] texture[ms_: {Black, White}, m_: 100] := Texture @ RegionPlot[True, {x, 0, 1}, {y, 0, 1}, MeshFunctions -> {# - #2 &}, Mesh -> m, MeshStyle -> None, MeshShading -> ms, Frame -> ...


3

In HatchFilling[θ, r, d], the $r$ and $d-r$ is the wide of the filling color and the blank. Here we using $r=10$ and $d-r=4$ Since I don't know how to handle the Light color when we using HatchFilling, I had to set Opacity by hand. We use Directive to combine the options of HatchFilling and Opacity and color. fill = HatchFilling[Pi/4, 10, 10 + 4]; BarChart[{{...


3

You can do it as follows (using the hack from here Two-color HatchFilling): ClearAll[wthack] wthack[clr_:Blue][{d___,h_HatchFilling}]:=PatternFilling[ColorReplace[Graphics[{d,h,Rectangle[]}],White->clr],ImageScaled[1]] BarChart[ {{Style[0.408808,Black], Style[0.0944349,Purple], Style[0.132875,Blue], Style[0.203982,Green], Style[0.1599,Red]},{ Style[...


0

Since the question has already be answered, let me present a variation of cvgmt's answer which might be more readable: With[{plane = InfinitePlane[{{1/2, 0, 0}, {1/2, 1, 0}, {1/2, 0, 1}}], sphere = Sphere[{5, 0, 0}, 10], xAxis = InfiniteLine[{{0, 0, 0}, {1, 0, 0}}], yAxis = InfiniteLine[{{0, 0, 0}, {0, 1, 0}}], zAxis = InfiniteLine[{{...


3

Based on @Szabolcs, It seems by increasing the size and change the resolution, Magnify[ Rasterize[ Graphics[ {Thickness[0],Line[#] & /@ ({po[[1 ;; -2]], po[[2 ;;]]}\[Transpose])}, ImageSize -> 10000], ImageResolution -> 100], 0.1] we can find desire fine structure, I suggest Opacity also may be useful in some case, ...


11

tet = Tetrahedron[{{-1, -1, -1}, {1, 1, -1}, {-1, 1, 1}, {1, -1, 1}}]; Graphics3D[{tet}, Axes -> True] We can use RegionPlot3D with the options Mesh and MeshShading to subdivide tet into 8 tetrahedra and style the faces differently: SeedRandom[12] RegionPlot3D[tet, PlotPoints -> 90, BaseStyle -> Opacity[.9], Mesh -> 1, MeshShading -> ...


5

Not really a mathematica problem but here is something to get you going in the Wolfram Language. eqn = x''[t] + (2 π 100)^2 x[t] == f[t]; ic = {x'[0] == 0, x[0] == 0}; f[t_] := Sin[110 2 π t]; sol = NDSolve[Join[{eqn}, ic], {x}, {t, 0, 0.2}]; Plot[Evaluate[x[t] /. First[sol]], {t, 0, 0.2}] Here I have made an oscillator with a natural frequency of 100 Hz ...


3

Clear["Global`*"] f[ℓ0_Integer?NonNegative] := f[ℓ0] = Module[ {ne = 2 ℓ0 + 2, vars, cons, mtablep, M, ene}, vars = Array[Symbol["x$" <> ToString[#]] &, ne]; cons = Apply[And, Thread[0 <= vars <= π/2]]; mtablep = Riffle[Range[0, -ℓ0, -1], Range[ℓ0]]; M[ℓ_, p1_, p2_, pp1_, pp2_] := If[mtablep[[p1]] + ...


2

Clear["Global`*"] You need to reposition the labels MyLegendre = Table[LegendreP[v, x], {v, 0, 4}]; Plot[MyLegendre, {x, -1, 1}, Frame -> True, PlotLabels -> Placed[{"v=0", "v=1", "v=2", "v=3", "v=4"}, {{Scaled[0.5], Above}, {Scaled[0.385], Above}}]]


2

You can design a ColorFunction so that a standard color function is used in most cases, except for some values. Here is a possiblity. Case 1: The standard "rainbow" function h = Table[Sin[j^2 + i], {i, 0, Pi, Pi/4}, {j, 0, Pi, Pi/4}]; l1 = ListDensityPlot[h, ColorFunction -> ColorData["Rainbow"], Axes -> False, Background -> ...


0

Let us start with reading the question. The given function is (x^3 y^5 E^(-2*z*n))/(x^2 + y^2) this is dependent on x, y, z and n. So the function has to reflect this four parameters: g[x_,y_,z_,n_]:=(x^3 y^5 E^(-2*z*n))/(x^2 + y^2) The polynomial in the denominator has no zeros on the Reals. The multinomial in the nominator has a coefficient functions ...


2

You may try the option"RegionFunction" of ListDensityPlot. Here is an example: dat = Table[t1 = RandomReal[{-1, 1}]; t2 = RandomReal[{-1, 1}]; If[t1^2 + t2^2 < .5, Nothing[], {t1, t2, t1^2 + t2^2}], 1000]; ListDensityPlot[dat, RegionFunction -> ((#1^2 + #2^2 >= .6) &)] But note, RegionFunction together with ListDensity plot is a ...


4

Clear["Global`*"] g[x_, y_, z_, n_] := (x^3 y^5 Exp[-2*z*n])/(x^2 + y^2) Manipulate[ Module[{x, func, t, var}, If[plt == 1, var = "z"; func = g @@ Rationalize[{x, y, t, n}], var = "y"; func = g @@ Rationalize[{x, t, z, n}]]; Plot3D[func, {x, -10, 10}, {t, -10, 10}, WorkingPrecision -> 20, MaxRecursion -> ...


3

Maybe use the SliceContourPlot3D to display the level sets of g[x,y,z,n] is easy and faster. Clear["`*"]; g[x_, y_, z_, n_] := (x^3 y^5 E^(-2*z*n))/(x^2 + y^2); Manipulate[ SliceContourPlot3D[ g[x, y, z, n], {"CenterPlanes"}, {x, -10, 10}, {y, -10, 10}, {z, -10, 10}, Contours -> 50, PerformanceGoal -> "Quality", ...


2

Using the Mesh option, as indicated in the link only works fur cuts parallel to a coordinate plane. For arbitray intersections: You can get the cut of your two regions by: "RegionIntersection[plane, sphere]". However, what you get is not a graphical primitive. So, you can not simply use it in Graphics3D. To turn it into something that Graphics3D ...


2

This is also possible in v11.0+ with ImageMesh and Rasterize. The RasterSize ends up affecting mesh quality here: RegionBoundary@ImageMesh@ColorNegate@Rasterize["любо",RasterSize->400] You could also just get the edge by using a FillingTransform to ignore the interior of shapes: RegionBoundary@ImageMesh@FillingTransform@ColorNegate@Rasterize[&...


4

We use the implicit exprssion of plane. The normal of plane is Cross[b-a,c-a] ({x, y, z} - a).Cross[b - a, c - a]==0 And we also use the implicit expression of sphere,here {5,0,0} is the sphere center and 10 is radius. Norm[{x, y, z} - {5, 0, 0}] - 10==0 Norm[{x, y, z} - {5, 0, 0}] - 10 as MeshFunction x = InfiniteLine[{{0, 0, 0}, {1, 0, 0}}]; y = ...


2

An alternative approach to remove the legend: Take the first Part of Plot output: plot = Plot[Sin[x] - 1, {x, -3, 3}, PlotRange -> {-3, 1}, PlotTheme -> "Detailed", PlotStyle -> Automatic, AxesLabel -> Automatic, Frame -> True, FrameLabel -> {Style["x", FontSize -> 22, Bold], Style["V(x)", FontSize -...


0

Indeed, as CA Trevillian stated, this whole code should work, and it does. An example is fA[r_, θ_, ϕ_] = ((4/3 r^0 )* LegendreP[0, 0, Cos[θ]]) + ((-r^1 )* LegendreP[1, 0, Cos[θ]]) + ((1/6 r^2 )* LegendreP[2, 0, Cos[θ]]); fB[r_, θ_, ϕ_] = ((8/3 r^(-(0 + 1)))* LegendreP[0, 0, Cos[θ]]) + ((-8 r^(-(1 + 1)))* LegendreP[1, 0, Cos[θ]]) + ((...


2

The formula that you provided does not appear to correspond to the diffraction figures that you provided. I have provided an interactive plot for the formula that you provided. Clear["Global`*"] Manipulate[ Module[{plt}, d[λ_, f_, R0_, α_, ΔT_] := 1.22 λ f/(Quantity[R0, "Millimeter"] Sqrt[1 + 2 α ΔT]); Switch[calc, 1, α = 8.6*...


5

Use RealAbs instead of Abs since Abs is a Complex function. And the Sqrt is also a Complex function, sometimes we use Surd instead of Sqrt or Power if we assume x is a real numbers,we can use ComplexExpand to observe the expression of Abs[Sqrt[x - 1] + 5] Abs[Sqrt[x - 1] + 5] // ComplexExpand (* Sqrt[(5 + ((-1 + x)^2)^(1/4) Cos[1/2 Arg[-1 + x]])^2 + ...


5

The problem you are running into is that the ListPlot is cropping the plot-region in an unlucky way. Put PlotRange->All as final option into the ListPlot call and you should be fine. You could have found this issue yourself by inspecting the plots separately.


4

GraphComputation`$GraphThemes // Column themestyles = "GraphStyle" /. GraphComputation`$GraphThemes {"BackgroundBlack", "BackgroundBlue", "BackgroundGold", "BackgroundGreen", "BasicBlack", "BasicBlue", "BasicGold", "BasicGreen", "DiagramBlack", "...


2

You can look at the contextual menu (as you enter the option PlotTheme -> ), in the documentation for PlotTheme, and in the documentation for LayeredGraphPlot Manipulate[ LayeredGraphPlot[{"John" -> "plants", "lion" -> "John", "tiger" -> "John", "tiger" -> "deer&...


0

DiscretePlot3D is not appropriate for what you want to do, but with some work ListPointPlot3D can do it. First, we have to put your data in a form ListPointPlot3D can understand. Module[{given, data}, given = {{0.25, 0.25, 0.25, 0.5, 0.5, 0.5, 1, 1, 1}, {0.377821, 0.349883, 0.340228, 0.34147, 0.32781, 0.320258, 0.319791, 0.307732, 0.30451}, {...


Top 50 recent answers are included