New answers tagged

0

You can extract the data from the plot and look for the maximum z value: p = Plot3D[new[α, χ, 0.9] - old[0.9], {α, 0, 2 π}, {χ, 0, π}, MaxRecursion -> 0, AxesLabel -> Automatic, PlotPoints -> 20] Cases[p, GraphicsComplex[pts_, __] :> MaximalBy[pts, Last], -1] (* {{{2.31486, 2.14951, 0.145981}}} *) However be aware that the result depends ...


1

One way of plotting 4d data is with: DensityPlot3D[ Re[new[α, χ, τ] - old[τ]], {χ, 0, π}, {α, 0, 2 π}, {τ, 0.1, 1}, PlotPoints -> 11] To do this with manipulate, it is wise to do all the calculations first, and storing the values in a dataset. data = Table[ Table[{α, χ, Re[new[α, χ, τ] - old[τ]]}, {χ, π/ 16, π, π/8}, {α, 0, 2 π, ...


2

Updated using mem: as suggested by Simon Woods. Perhaps using Plot3D at a couple of intervals of tau will be enlightening. The results seems plausible based on the fact that old is a 1D function. ClearAll["Global`*"] G = 0.01; β = 1; ωc = 50; j = 1; ϕ = 0; θ = π/2; η = Exp[I ϕ] Tan[θ/2]; Clear[ψ] ψ[α_, χ_] := Exp[I α]*Tan[χ/2]; integralgamma[ω_, τ_] := ...


0

The command given before editing the question and before my answer was: Manipulate[ Plot3D[new[α_, χ_, τ_] - old[τ_], {α, 0, 2 π}, {χ, 0, π}], {τ, 0, 1}] My answer is: Manipulate[ Plot3D[Evaluate[new[τ, α, χ]] - Evaluate[old[τ]], {α, 0, 2 π}, {χ,0, π}], {τ, 0, 2}]


2

I was unable to locate the function R[t] so I made one up. I also changed the BoxRatios to make it a bit easier to see. R[t_] := 4 + Cos[\[Pi] t] r[t_, ϕ0_] = {R[t] Cos[ϕ0], R[t] Sin[ϕ0], t} ParametricPlot3D[r[t, ϕ0], {ϕ0, 0, 2 π}, {t, 0, 2}, MeshFunctions -> {#4 &}, Axes -> None, Boxed -> False, BoxRatios -> {1, 1, 1}, ImageSize -&...


0

Let's say data1 and data2 are your imported data data1 = Flatten[Table[{Sin[p] Cos[q], Sin[p] Sin[q], Cos[p]}, {p, 0, Pi, Pi/10}, {q, 0, 2 Pi, Pi/10}], 1]; data2 = Flatten[Table[2 {Sin[p] Cos[q], Sin[p] Sin[q], Cos[p]}, {p, 0, Pi, Pi/10}, {q, 0, 2 Pi, Pi/10}], 1]; ndata = Length[data1]; Now use Graphics3D to plot ...


12

Based on the comment by Szabolcs I came up with a solution. Here it is xyText[str_, scaling_: 1, offset_: {0, 0, 0}] := Module[{ mesh = DiscretizeGraphics[ Text[Style[str, FontFamily -> "Monospac821 BT"]], _Text, MaxCellMeasure -> 1] }, MeshPrimitives[mesh, 2] /. {x_?NumberQ, y_?NumberQ} :> (scaling {x, y, 0} + offset) ...


3

One could override the setting for each polygon group (or GraphicsGroup[]): cp /. p_Polygon :> {Lighting -> {{"Ambient", White}}, p} cp /. gg_GraphicsGroup :> {Lighting -> {{"Ambient", White}}, gg} Update: Addendum. While Lighting shows up in Options@ChromaticityPlot3D, it is not listed among the options in the docs for ChromaticityPlot3D....


5

If you look at the InputForm of ChromaticityPlot3D[{"WideGamutRGB", "sRGB"}] you'll find several spots where it says Lighting -> "Neutral" So if you want to change that, you'll have to modify the output of ChromaticityPlot3D using a replacement rule. Here is an extreme example, one that totally ruins the plot but shows how to change the lighting, ...


4

Actually I think what you need is ColorFunction and ColorFunctionScaling. In ColorFunction you can set the color in different regions according to the points' {x,y,z} coordination. And I think what you need is just setting some part in a color (in my code, Bed) and the other in another color(in my code, Blue). Then, simply create a function discribing this ...


3

A recommendation to the question poser: Pose your question in the absolute simplest terms, limiting to the minimal example that addresses your point. There is no need here, for instance, for the community to have to download a complicated data set in order to see how to color one part of a plot differently from others. Why do we need to incorporate text ...


4

Introduction Previously, I have done some similar work. Here is how I would approach it. Please bear in mind, there might be a better solution out there and I would give it some time for the community to respond Example RegionPlot3D[ RegionDifference[cub, cyl2], PlotPoints -> 100, PlotStyle -> Directive[Red] ] Note: cub and cyl12 are as in ...


2

The only way I could find to add the ellipse you are asking for to your graphic was to compute a set of points along the ellipse and make line segments from them. Here is how I did it. The following generates the graphic you show int the question. origin = Point[{0, 0, 0}]; cone1 = Cone[{{0, 0, 1}, {0, 0, 0}}]; transform = {{0.3, 0, 0.15}, {0, 0.35, 0}, {0....


2

Or just keep the original definitions of test1 and test2 and use the PlotRange option: Show[test1, test2, PlotRange -> Automatic] Why is Automatic not the default option? I'm not sure. Why does the default PlotRange result in an insane range for the 3rd coordinate? Charting`get3DPlotRange@Show[test1, test2] (* {{-1.95773, 1.06036}, {-0.0206875, ...


1

Try this: test1 = Graphics3D[{ Arrow[{{1/10, 3/Sqrt[10], -(Sqrt[(5/2)]/3)}, {-3 Sqrt[2/5], 1, 0}}]}]; test2 = ParametricPlot3D[{x, Sqrt[1 - x], 0.1/x}, {x, 0, 1}, BoxRatios -> {1, 1, 1}, PlotRange -> {{-2, 1}, {-1, 1}, {-0.5, 1}}, AxesLabel -> {x, u, t}]; Show[{test2, test1}] yielding this:


1

The options given to the final Graphics3D object are generally taken to be those specified in the first object passed to Show. In This case, you didn't specify an explicit PlotRange argument in test1, and that specified in test2 is not used, so that Mathematica chooses it automatically. You will notice that just changing the order of the arguments of Show, ...


6

Update AxesEdge does what you want. Graphics3D[Cylinder[], Axes -> True, AxesEdge -> {{-1, 1}, {1, -1}, {1, -1}}] The following shows more specifically how each of the edges are selected: p1 = Graphics3D[Cylinder[], Axes -> True, AxesEdge -> {{1, 1}, None, None}, ViewPoint -> Left, PlotLabel -> "x {1,1}"]; p2 = Graphics3D[...


3

In v10.1 under Windows x64 I experience no "z-fighting" in this example when using the "BSPTree" rendering method. This method may be individually using BaseStyle data = {{1, 1, 1, 1}, {1, 0, 3, 1}, {2, 0, 0, 1}}; plot = ListPlot3D[data, Mesh -> None, InterpolationOrder -> 0, Filling -> Bottom, FillingStyle -> {Opacity[1]}, ColorFunction -&...


3

I can think of no solution to the color streaking problem other than perturbing the size of one the two coinciding cones. I choose to perturb projcone2. origin = Point[{0, 0, 0}]; cone1 = Cone[{{0, 0, 1}, {0, 0, 0}}]; transform = {{0.3, 0, 0.15}, {0, 0.35, 0}, {0.1, 0, 0.5}}; cone2 = GeometricTransformation[cone1, transform]; projcone2 = Scale[cone2, {2.99, ...


10

In at least this case, Method -> {"RelieveDPZFighting" -> True}, which is useful when you have nearly coplanar polygons in your plot, removes the observed jitter and streakiness. I picked this up from Brett. {ListPlot3D[data, ColorFunction -> "SolarColors", Filling -> Bottom, FillingStyle -> {Opacity[1]}, InterpolationOrder -> ...


3

Since the mesh for the picture in the OP was not provided, I'll use this example from an FEM tutorial, but with altered boundary conditions: bcs = InitializeBoundaryConditions[vd, sd, {{DirichletCondition[u[t, x, y, z] == 2, ElementMarker == 1], DirichletCondition[u[t, x, y, z] == 0, ElementMarker == 2]}}] Using the corresponding interpolating ...


0

As shown in How to plot vectors in Mathematica, the desired graphics primitive is Arrow with a list of two vectors, one the origin and one the head of the vector. If A is your matrix, this expression builds the list of Arrow primitives. In[1]:= A=Array[a,{2,3}]; Map[Arrow, Transpose[{0 A, A}, {2, 3, 1}]] Out[2]:= {Arrow[{{0, 0}, {a[1, 1], a[2, 1]...


4

With version 10.4.1 I get the plot rasterized (but not the legend) with your code. As a workaround you can use the Jens' trick: Export["myFig2.eps", Graphics[Inset[pl, Automatic, Automatic, Scaled[1]]]]; Here is how the exported EPS file looks when opened by Adobe Acrobat 11 (I have selected a number on the frame in order to show that it is a selectable ...


6

It took quite a while, but I've finally come up with a way to generate discretized tubes. This again is based on work in this previous answer (from the thread mentioned earlier by Michael). In the interest of keeping things short, I will not be repeating the definitions of orthogonalDirections[], extend[], and crossSection[] from that answer. Here, then, is ...


6

The answer can be found here: Change The Lighting Of Plots in the official How Tos. For "Standard"/Automatic: Graphics3D[Sphere[], Lighting -> {{"Ambient", RGBColor[0.4, 0.2, 0.2]}, {"Directional", RGBColor[0, 0.18, 0.5], ImageScaled[{2, 0, 2}]}, {"Directional", RGBColor[0.18, 0.5, 0.18], ...


3

Example Description This can be achieved using PlotRange -> {{xmin,xmax},{ymin,ymax},{zmin,zmax}}, you can use Automatic as an argument to let Mathematica decide what is min or max. For example, PlotRange -> {Automatic, Automatic , {1,Automatic}} Code m = 1; q = 5/2; K = Sqrt[4 m/(3 - q)]; \[Xi] = (q - 1)^2/4 K^2; A = Pi/Sqrt[\[Xi]]; Plot3D[ 1/A (...


2

The problem is plot quality, not the code. The answer is MaxRecursion ParametricPlot3D[{I01[x, y], I11[x, y], I02[x, y]}, {x, 0, 8 \[Pi]}, {y, 0, 8 \[Pi]}, MaxRecursion -> 5]


0

This should work: g = {g0, g1, g2, g3, g4}; s = {S0, S1, S2, S3, S4}; Animate[Labeled[Graphics3D[g[[i]], ViewPoint -> Front], s[[i]],Top], {i, 1, 5, 1}, AnimationRunning -> False,PreserveImageOptions -> False]


0

I think what you are asking is a default feature. For example ListAnimate[Table[Graphics3D[{Hue[x], Cuboid[]}], {x, 0, 1, .01}]] If you pause it, rotate the Cuboid and then play again, you will see that it will resume its initial position.


0

Marsaglia's method: uniform on disk (here rejection method), transform by Lambert azimuthal equal-area projection: http://mathworld.wolfram.com/SpherePointPicking.html uniformDisk[n_] := Take[Select[Table[RandomReal[{-1, 1}], {3 n}, {2}], #.# <= 1 &], n]; diskToSphere[p_] := {2 p[[1]] Sqrt[1 - Dot[p, p]], 2 p[[2]] Sqrt[1 - ...


0

You could use ListDensityPlot3D for visualization purposes instead. This also has the useful option "OpacityFunction"... IMO, you could also use Image3D and rescale the data only for display purposes. You can work with Image3D's with colors that are out-of-0-1-range just fine, they just don't display correctly. (*Data*) normalizedVolumeData = {{{0, 0, 0}, {...


5

You could create a region using DiscretizeGraphics and find points within a certain distance of the surface using RegionDistance g = Normal @ Plot3D[x^2 - y^2, {x, -1, 1}, {y, -1, 1}]; f = RegionDistance @ DiscretizeGraphics @ g; data = Array[f[{##}] &, {60, 60, 60}, {-1.1, 1.1}]; Image3D[Clip[data, {0.05, 0.05}, {1, 0}]]


0

For Graphics3D -> Image3D: This answer: http://mathematica.stackexchange.com/a/33277/6804 gives an approach that rasterizes individual 2D slices at different heights and stacks them into a 3d image. Of course you need to select a resolution, the conversion will not be lossless in general (and I don't know what would happen when the Graphics3D object is a ...


0

This answer: http://mathematica.stackexchange.com/a/33277/6804 gives an approach that rasterizes individual 2D slices at different heights and stacks them into a 3d image.


6

For an approximately even distribution of points on any surface with cylindrical symmetry, we can use the Golden Angle, the same way that the sunflower uses it on the plane. To place N points on the surface of a sphere, define an axis. Divide the surface into N equal area strips perpendicular to the axis. For k in 0 to N-1, on the kth strip, place a point ...


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

With[{n = {3, 4, 5, 6, 7, 20}}, Partition[show[points[#]] & /@ n, 3]] // GraphicsGrid With the code below, with piecewise spring forces (exclusively repulsive) and Cartesian vectors. A different model for force and switch to spherical vectors would probably be wise. show[points_] := Graphics3D[{ Opacity[.5], Sphere[], Opacity[1], PointSize[...


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}]


10

Aha~ I suppose this question is created while solving this. Am I correct @yode :P So here's an easy solution, simple, elegant, and may I say even quite fast after some optimization? pt = With[{p = Table[{x[i], y[i], z[i]}, {i, 80(*number of charges*)}]}, p /. Last@ NMinimize[ Total[1/Norm[Normalize[#1] - Normalize[#2]] & @@@ ...


13

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[...


5

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] ...


25

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 ;;]]; ...


14

If more ad hoc, inexact approaches are welcome, one way to generate relatively uniform density of points on a sphere is to use Monte Carlo Lloyd's algorithm (modified for the spherical case): With[{points = 200, samples = 40000, iterations = 20}, Nest[With[{randoms = Join[#, RandomPoint[Sphere[], samples]]}, Table[Normalize@Mean@Extract[randoms, ...


8

Correct me if I'm wrong... but I suppose, pedantically speaking, there are only five solutions defined by Platonic solids, and trivial solutions for 0-3 points (extension of CirclePoints). Thus: ClearAll[spherePoints]; spherePoints[r_: 1, n_ /; 0 <= n < 4] := {##, 0} & @@@ CirclePoints[r, n]; (spherePoints[r_: 1, PolyhedronData[#, "VertexCount"]...


2

For points uniformly spaced in angular variables, you can use CirclePoints. spherepoint[m_, n_] := Union@Flatten[Table[Join[{Cos[q]}, Sin[q] #] & /@ CirclePoints[n], {q, 0, Pi, Pi/m}], 1] ListPointPlot3D[spherepoint[20, 30], BoxRatios -> 1] For uniformly spaced in Cartesian coordinates, things would be complicated. The ...


4

Here is an answer to this question derived from its comments. Currently there is no way to preserve the interactive capabilities of a 3D plot when using Export. If it is not possible to do the presentation with Mathematica itself, perhaps by using its slideshow capability, the next best recourse is to put the 3D plot in a CDF document and present it with ...



Top 50 recent answers are included