Tag Info

New answers tagged

1

Double the width: f[{{xmin_, xmax_}, {ymin_, ymax_}, {zmin_, zmax_}}, ___] := Cuboid[{xmin, ymin, zmin}, 2 {xmax, ymax, zmax} - {xmin, ymin, zmin}]; Histogram3D[N@{Data1, Data2, Data3, Data4, Data5}, 10, Boxed -> False, FaceGrids -> {Bottom, Front, Left}, ChartStyle -> "Pastel", ChartElementFunction -> f, Ticks -> {Automatic, None, ...


3

Significant manual cleaning was required for block of data in post. The data: data = {{{"ID", "Day", 1., 2., 3., 4., 5., 6., 7., 8., 9., 10., 11., 12., 13., 14., 15., 16., 17., 18., 19., 20., 21., 22.}, {"H. sapiens", 1., 145.7, 153.2, 164.6, 161.1, 170.8, 191.7, 179.2, 178.5, 198.5, 169.9, 135.8, 182.8, 205.3, 210.3, 197.3, 238.4, ...


1

reorgdata = GatherBy[data[[1]], #[[2]] &][[2 ;;, All, 3 ;;]]; variances = Thread[Variance /@ reorgdata]; means = Thread[Mean /@ reorgdata]; Row[{ListPlot[means, PlotLabel -> "means", ImageSize -> 300], ListPlot[variances, PlotLabel -> "variances", ImageSize -> 300]}]


0

Image[RegionPlot[{Cos[x^2 y] > 0, Sinc[x y + x y^2] <= 0.3}, {x, -1, 1}, {y, -1, 10}]] Then you can deal with a image object instead of a graphics object


5

Here is a very simple, step-by-step way to go about solving your problem. z[t_] := {1, t^2, t^3} Norm[z[t]] Sqrt[1 + Abs[t]^4 + Abs[t]^6] Those absolute values are going to give us trouble, so lets get rid of them. You want to plot over the range 0 to 5, so we can assume t ≥ 0. nz[t_] = Simplify[Norm[z[t]], Assumptions -> t >= 0] Sqrt[1 + ...


10

You're running into two issues. We'll start with the one that is causing the messages. By default Plot avoids symbolic evaluation of your function, and uses numeric evaluation instead. For example, it may evaluate at t=1.23: D[D[z[1.23],1.23],1.23] and then D complains that 1.23 isn't a valid variable and returns D[D[{1, 1.5129, 1.8608669999999998}, ...


3

You could set up a dynamic VertexRenderingFunction that allows you to change the colors of your vertices with a click. colorClickVRF[colors_List] := Function[{pos, name}, Module[{i, len}, i = 1; len = Length[colors]; DynamicModule[{ backColor = Lighter[First[colors]], frameColor = Darker[First[colors]]}, ...


1

The plots you are producing by adding PlotLegends all have Head of Legended. So the closest to what you already have would be to do the following: Legended[ ContourPlot[ Cos[x]+Cos[y],{x,0,4 Pi},{y,0,4 Pi}, ContourShading->None ], Placed["example",{0.8,0.1}] ] This produces an output that is of the same type as your plot with contour shading ...


6

One easy way is to replace the style of the specific nodes in the final tree. Let's make a function for it: colorize[tree_, nodes_List] := With[{patt = Alternatives @@ nodes}, tree /. Framed[p : patt, style_, r2___] :> Framed[p, style /. c_RGBColor :> Darker[c], r2] ] Now you can do t = Plotting[S, u, d, 4]; colorize[t, {S, d^2 S*u^2, d^3 ...


3

I don't think this is entirely unexpected since PlotLegends is meant to depict what the colours mean. You switch off the colours and the plot legend disappears. The canonical way to leave the "example" in place is to use an epilog: p = ContourPlot[Cos[x] + Cos[y], {x, 0, 4 Pi}, {y, 0, 4 Pi}, ContourShading -> None, Epilog -> Text["example", ...


2

Plot[{x^-2, UnitStep[1 - x], Boole[x > 1] x^-2}, {x, 0, 4}, PlotStyle -> Blue, Filling -> {3 -> {{2}, {Purple, Red}}}]


1

Another workaround is to create the plot as normal and then delete all the Polygon expressions: ContourPlot[Cos[x] + Cos[y], {x, 0, 4 Pi}, {y, 0, 4 Pi}, PlotLegends -> Placed["example", {0.8, 0.1}]] // DeleteCases[#, _Polygon, -1] &


6

Another variation, using ConditionalExpression: Plot[{ ConditionalExpression[x^-2, x <= 1], ConditionalExpression[x^-2, x > 1], ConditionalExpression[1, x <= 1]} , {x, 0, 4}, PlotStyle -> Blue, Filling -> {2 -> {Axis, Red}, 3 -> {Axis, Purple}}]


2

Let me give a workaround myself after some attempts. It is only a workaround thus other answers are appreciated! ContourPlot[Cos[x] + Cos[y], {x, 0, 4 Pi}, {y, 0, 4 Pi}, PlotLegends -> Placed["example", {0.8, 0.1}], ColorFunction -> (White &)] This works. In other words, here the contour shading is not turned off, but instead colored as ...


7

One Plot can do too: Plot[{If[x < 1, 1/(x^2)], If[x > 1, 1/(x^2)]}, {x, 0, 4}, AspectRatio -> 1, Filling -> {2 -> {Axis, Red}}, Epilog -> {Purple, Rectangle[]}]


8

Show[Plot[1/(x^2), {x, 0, 4}, PlotStyle -> Blue, AspectRatio -> 1], Plot[1, {x, 0, 1}, FillingStyle -> Purple, Filling -> Bottom, PlotStyle -> Blue], Plot[1/(x^2), {x, 1, 4}, PlotStyle -> Blue, Filling -> Axis, FillingStyle -> Red, PlotRange -> {Full, {0, 1}}]]


0

I guess this could be solved by defcol[n_] := ColorData[1, "ColorList"][[n]]; Legended[Plot[{Sin[x], Sin[x]^2, Cos[x]}, {x, -2 \[Pi], 2 \[Pi]}], Placed[LineLegend[ {defcol[1], defcol[2], defcol[3]}, {"S", "S2", "C"}, LegendLayout -> "Row"], {0.5, -0.1}]] The position of Legend is defined by option {0.5, -0.1} This could be applied for any ...


4

What you see is Moiré pattern Closely related topic with 2D case: Using high RasterSize changes contour pattern Worth to add that the patterns does not seem to have a translation symmetry because the projection is not parallel. You can compare it with distant ViewPoint case: ListPointPlot3D[ Table[{n, s, (Prime[n]^s/(Prime[n]^s - 1))}, {n, 1, 2000}, {s, ...


3

It looks to me like you've got some inconsistency in your VertexNormals. This can certainly happen with numerically generated functions though, as others have rightly pointed out, it's hard to say for sure without some more specific info. Here's a simple way to force this sort of thing to happen. (* A list of vertices to feed to Polygon *) pts = ...


1

There seem to be at least two issues here: You are not resetting ExtractionCon = {} inside the outer Do loop, therefore Divided1 grows longer than Partition1 With (1) corrected you will get a different error (repeated): Set::setraw: Cannot assign to raw object 3. >> because the x* Symbols now have values, and they evaluate before the assignment is ...


2

Short Answer Clear[Derivative] first. Long Answer OK, it's surprising that there seems to be no regular answer to this common problem for beginners, let me elaborate my comment into an answer. If you restart your Mathematica and run your code again then you'll find your problem no longer exists anymore! Then, why? Because Mathematica is unstable? Of ...


2

Based on the discussion in chat among Kuba halirutan and Michael Hale: trajnormal = RandomFunction[PoissonProcess[1], {0, 100}]["PathFunction"]; trajdiscount = RandomFunction[PoissonProcess[5], {0, 100}]["PathFunction"]; Clear[show] show[1, t_, step_] := ListLinePlot[ {#, 50 - trajnormal[#]}\[Transpose] & @ Range[0, t, step], ...


1

I can't make heads or tails of above, but perhaps this will get you started. Read the documentation - it's your best source of information. First, let's get some solution from NDSolve : sol = NDSolve[{u''[t] + u[t] == 0, u[0] == 0, u'[0] == 1}, u, {t, 0, \[Pi]}] (* {{u->InterpolatingFunction[{{0.,3.14159}},<>]}} *) So, NDSolve has given us a ...


0

You can simply make a graphics with the needed lines, and combine both with Show. For example, if you stored your plot in myplot, you could do Show[myplot, Graphics[{Line[{{1,1},{4,1}}], Line[{{1,-1},{4,-1}}], Line[{{-5,-5},{-3,-5}}], Line[{{-5,-7},{-3,-7}}]}]]


6

One option would be to restrict the function from funky regions with a Condition liks this f[x_, y_] /; Abs[x - y] > 5 := (Sin[x] - Sin[y])/(x - y); Plot3D[f[x, y], {x, -10, 10}, {y, -10, 10}] Out: One can easily see that Plot3D will also sample points in the region which is "forbidden", the points are just not drawn due to the RegionFunction. ...


3

If I understand you correctly you want to show the label "0.2" at the $z$-value 5. The option Ticks allows you to do this. Here is an example: Plot3D[ 5 Sin[x y], { x, 0, π}, { y, 0, π}, Ticks -> { Automatic, Automatic, {-5, -3, 0, {5, "0.2"}}}]


4

Like noted in the comments the problem is that Manipulate[ListLinePlot[{OutputResponse[discLowPass[T, τ], dataNoise]}], {{T, .1}, .005, 25}, {{τ, .005}, .001, .025}] doesn't work while the following works: Manipulate[ListLinePlot[OutputResponse[discLowPass[T, τ], dataNoise]], {{T, .1}, .005, 25}, {{τ, .005}, .001, .025}] ...


1

What is going on? By Trace-ing the ContourPlot3D, I found the warning (on my MMA) comes from a function System`ProtoPlotDump`findextreme (Hereafter, the context System`ProtoPlotDump` will be omitted for readability): findextreme[{f_, {x_, xmin_, xmax_}, {y_, ymin_, ymax_}, {z_, zmin_, zmax_} }] := ...


0

I got a result using Mathematica 9.01 . It is possible that you have an older version or missing libraries. Install flash in your computer to see if this might have to do with the graphic diver.


4

To answer your main question, I generated the coords as specified: coords = Flatten[ Array[(Characters@"abc")[[#]] <> ToString@#2 -> {#, #2} &, {3, 4} ], 1] {"a1" -> {1, 1}, "a2" -> {1, 2}, "a3" -> {1, 3}, "a4" -> {1, 4}, "b1" -> {2, 1}, "b2" -> {2, 2}, "b3" -> {2, 3}, "b4" -> {2, 4}, "c1" -> {3, 1}, "c2" ...


2

I solved more general system linked by @SjoerdC.deVries in the comments reproducing figure 3 and 4 - to prove it is correct. You can simplify this to version you need. Clear["Global`*"] al = 2; a = 2/1000; k = 600; b = 1/10; g = 46/10^5; c = 1/100; m = 1/100; E1 = 1; q1 = 2/10; E2 = 813/1000; q2 = 2/100; Tf = 300; eqs = { x'[t] == al x[t] (1 - ...


1

I really don't understand why Show behaves this way with LogPlots. Anyway a way out is to manually extract the the ticks from the plots: logShow[a__Graphics, opts : OptionsPattern[Show]] := With[{ft = (FrameTicks /. #[[2]])[[1, 1]] & /@ {a}}, Show[{a}, FrameTicks -> {All, Join @@ ft}, Evaluate[opts]] ] and although this is probably easy ...


2

I can't think of a way to do this without indexing the data. If that's not a problem, the following will do: With[{ indexed = MapIndexed[ {Sequence @@ #2, #1} &, Sin[0.5 Range@100] /. {a_?Negative -> Missing[]} ] }, ListPlot[ SplitBy[ indexed, NumericQ@Last@# & ], Joined -> True, InterpolationOrder -> 2 ...


1

You could just do without Missing: ListPlot[Cases[{#, Sin[0.5 #]} & /@ Range[100], {_, _?NonNegative}], Joined -> True]


3

You can display zero crossing using MeshFunctions. Here is a clumsy exploitation from created graphic. The half-periods (difference between consecutive points) are displayed below with mean in red. x1plot = ListPlot[x1data, AxesLabel -> {"t", "x1"}, Joined -> True, MeshFunctions -> (#2 &), Mesh -> {{0.}}, MeshStyle -> {Red, ...


1

You can use an appropriately defined MeshFunction as per your constraint equation. For every t you should then get a line on the sphere. If you don't want the sphere to be visible you can change the opacity to zero in the relevant option. Here I've chosen the constants a, b, c so that the constraint equation has a solution: Manipulate[ Module[{a = 1, b = ...


0

As you have one constraint equation, your surface $\vec{x}(\theta,\phi,t)$ is in fact parametrized by two parameters only. In this simple case you could solve $$ \cos\theta+a(\phi+bt)^2+c=0 $$ and get $$ \theta=\arccos(-a(\phi+bt)^2-c) $$ Then, by inserting it in $\vec{x}$ you see that $\vec{x}=\vec{x}(\phi,t)$, which can now be readily plotted.


2

Alternate answer, this is an exact analytic approach to the nearest point problem: (not i think precisely what @martin was after, but its an interesting problem and others may find it useful) lb = -1;ub = 1; pts0 = Select[Flatten[ Table[ {i, j}, {i, 2 lb, 2 ub , .2}, {j, 2 lb , 2 ub , .2}], 1] ,Norm[#] < 1 &]; intv[ p_, pn_] := If[(pn[[1]] != ...


2

By adding up lots of closely spaced contributions, you are effectively approximating an integral. Just evaluate the integral analytically instead: f[x_, y_] := Evaluate[Integrate[1/Sqrt[x^2 + (y + t)^2], {t, -5, 5}, Assumptions -> {x, y} \[Element] Reals]] The assumptions are helpful because otherwise Mathematica assumes ...


4

To save a PNG of a plot or graphics expression, I avoid Export. I select the displayed output and click on the Save Selection As ... item on the File menu. This will save the selected output exactly as it appears on the display.


9

What is stored in variable x is different from rotated object you have in output cell. You rotated - so you changed the properties. Many ways to do this - so in addition to comments' methods... 1) In-Export rotation 2) Seeing options Export["test.png", Show[x, opts]]


1

I think @rasher's comment is correct and you can plot the points you need by truncating the list. You can make a function that does that. I named mine (ironically) economicListPlot but it took a lot of copy-pasting to account for different values of the options so it could do with a tidy up economicListPlot[data_ /; VectorQ[data], opts : ...


4

L = 10; First of all you could get Booolian array simply as (thx. to @Kuba) RandomInteger[1,{L,L,L}] But if you are interested in thresholding: M = RandomReal[{0, 1}, {L, L, L}]; First of all do not binarize procedurally, use functional style, say: bM = M /. x_ -> UnitStep[x - .5]; or image processing: bM = ImageData[Binarize[Image3D[bM], ...


3

The ragged edges were caused by the fact that the parametrization of the surface in terms of height over the equatorial plane is singular at the equator, as you can also see in the increased distance between mesh lines on the plotted surface. So the main part of the solution is to choose a better parametrization, and the most common one is of course some ...


1

This is what I'd do, the idea is to use ParametricPlot[{b^y, y}] for Log[b, x]. So we can use Solve to make it a little bit more general: Block[{x, y}, With[{notimportantoptions = Sequence[PlotStyle -> Thick, PlotRange -> {All, {-25, 6}}, AspectRatio -> 1, AxesStyle -> Arrowheads@.05, ...


4

Here you are with the bands -- note also an (I think) improvement over the brute force fine discretization of the line: (I'm Not sure if that improved performance, but it didn't hurt and it looks cleaner) caveat I think my little trick thinning down the lndat list is not guaranteed to find all of the strictly nearest points. It seems to work for the ...


0

I'll write down what I've found after experimenting a little more with the code, in the hope that someone wants to take a look. The original code was a little different from the one I posted in the question (my fault, I really didn't imagine the problem would be in the part I left out... Well, lesson learned). The potential was written in this way ...


10

So you guys know - quasicrystals are cool structures that can consist of finite number of parts which can be arranged in never repeating - aperiodic - pattern. Thing here is called projection method from a regular lattice. http://www.nature.com/nmat/journal/v3/n11/fig_tab/nmat1244_F3.html Interestingly if you know Fibonacci rabbits problem - that is also ...


2

Try this: ClearAll[discretePlot]; SetAttributes[discretePlot,HoldAll]; discretePlot[args___]:= Block[{System`DiscretePlotDump`flatTable}, SetAttributes[System`DiscretePlotDump`flatTable,HoldFirst]; System`DiscretePlotDump`flatTable[expr_,eval_,{var_},{vals_}]:= ParallelTable[expr,{var,vals}]; ...


1

Edit I now have a better understanding of what you are looking for. To get plot centered at the origin defined in terms of the radius and height, then you can use SphericalPlot3D as Kuba suggested. It would go like this. theta[r_, h_] /; 0 < h < r := π/2. - ArcTan[Sqrt[r^2 - h^2], h] With[{r = 5, h = 3, zScale = .3}, SphericalPlot3D[r, {θ, ...



Top 50 recent answers are included