Tag Info

New answers tagged

5

There are some place which can be optimized in your animation. When I see this right, then your function Outer[(-Mod[#1, #2]/#2) &, # + k, #] & is similar to Outer[(-Mod[#1+k, #2]/#2) &, #, #] & but the latter has the big advantage, that the calculation of your Outer does not rely on k. It is even better than that, because now we can ...


4

The fastest way to plot large data in my experience is Image, as I do here: Animate[Prime[Range[400]] // Outer[(-Mod[#1, #2]/#2) &, # + k, #] & // Column@{Style[k, Large], Colorize[Image[Transpose@Rescale@#, ImageSize -> 600], ColorFunction -> "LakeColors"]} &, {k, 1, 1000, 1}, AnimationRate -> 1]


2

I would work purely on the list of points. You have the radius r, so you can easily identify connected regions with points = {{27, 38}, {31, 50}, {33, 56}, {34, 38}, {39, 51}, {39, 63}, {40, 31}, {42, 45}, {42, 55}, {47, 27}, {47, 50}, {48, 35}, {48, 65}, {49, 43}, {52, 57}, {54, 50}}; data = ReplacePart[ConstantArray[0., {96, 145}], points -> ...


3

Here is a graph based solution. However the result (the pixels) will be dependent on resolution, and this solution currently uses the lowest resolution possible. withinRange[range_][pt1_, pt2_] := Norm[pt1 - pt2] <= 2 range adjacencyMatrix = Boole@Outer[withinRange[3.5], points, points, 1] -IdentityMatrix@Length@points; Some work may be saved by only ...


0

A number of things can be done to improve the responsiveness of Manipulate here. First, do not compute the same quantity more than once; see q1 and theta1. Second, set SynchronousUpdating -> False, so that calculations are not performed until a Slider stops moving. (See SynchronousUpdating documentation.) Finally, increase the speed of ...


5

f[x_] := Abs@Sin@x/(x x + x + 1) a[t_] := NIntegrate[f[x], {x, t, t + 2 Pi}] tabA = Table[{t, a[t]}, {t, -3 Pi, 3 Pi, 6 Pi/100}]; opc = Sequence[ImageSize -> 400, Ticks -> {Array[- 4 Pi + # Pi &, 6], Automatic}]; Animate[Column[{ Show[Plot[f[x], {x, -3Pi, 3Pi}, AspectRatio->1/4, Evaluate@opc, PlotRange->{{-3 Pi, 3 Pi}, All}], ...


2

It took me few minutes to figure what it is doing. But here is a Manipulate. I did not know the code is there and did not look at original one yet. I am sure it is done better than my attempt here: Manipulate[ tick; If[state == "RUN", tick = Not[tick]; a = a + 0.1; If[a > 4 Pi, state = "RESET"; a = -4 Pi; cArea = {} ] ]; ...


2

colorRules = Thread[DeleteDuplicates[f] -> {Blue, Red, Orange}]; mm = RandomChoice[{0, 1}, {5, 5}]; GraphPlot3D[mm, VertexRenderingFunction -> ({f[[#2]] /. colorRules, Sphere[#1, 0.05]} &)] or cF[1] = Blue; cF[2] = Red; cF[20] = Orange; GraphPlot3D[mm, VertexRenderingFunction -> ({cF[f[[#2]]], Sphere[#1, 0.05]} &)] gives ...


0

Case of explicit functions: ParametricPlot3D[Evaluate[Table[{ww, zz, Exp[-(ww - 0.5 zz)^2/zz^2]}, {zz, {0.2, 0.4, 0.6, 0.8, 1.0, 1.2}}]], {ww, -2, 2}, PlotStyle -> {{Black, Thick}, {Blue, Thick}, {Red, Thick}, {Yellow, Thick}, {Green, Thick}, {Magenta, Thick}}] Case of Interpolating functions: mmax = 4; tm = Table[m, ...


1

Firstly, no need to use Show, simply remove the ; from the end of your Graphics3D expressions. Secondly, try evaluating: Graphics3D[ Table[Cuboid[{{a + (l - 1) dx, 0, 0}, {a + l*dx, +.01, f[startpos[3, l]] + .01}}], {l, 1, 50, 1}], AxesLabel -> {x, y, z}, Axes -> True, BoxRatios -> 1, Ticks -> None, AxesOrigin -> {0, 0, 0}, Boxed ...


2

I would switch approach to something like: Show[ RevolutionPlot3D[2 Cos[Floor[x, (Pi/10)]], {x, 0, 9 Pi/2 + .2}, Exclusions -> None, PlotPoints -> 100, MeshStyle -> Thick], RevolutionPlot3D[0, {x, 0, 9 Pi/2}, Exclusions -> None, PlotPoints -> 50, MeshStyle -> Thick] ...


2

Edit I've included another method for creating the crystal structure which should be useful for pedagogical purposes, but assumes that MoS2 behaves ideally. Short Answer It can't be done with ChemicalData alone, (as of 2014) since there is important information missing. We are not given any information about the crystal structure, and therefore need to ...


0

Fixed in 10.0.2 . On windows 7, 64 bits Graphics3D[{CapForm["Butt"], Tube[{{0, 0, 0}, {1000, 0, 0}}, 30], Tube[{{0, 300, 0}, {1000, 300, 0}, {1000, 300, 100}}, 30]}, Boxed -> False, PlotRange -> All]


0

If you want to indicate the value of X on the graph itself and change some colors: Manipulate[ Plot[{-3.56 + 2.222 x - .22 x^2, If[x > X, -3.56 + 2.222 x - .22 x^2], 0}, {x, 0, 10}, PlotRange -> {{0, 10}, {0, 5}}, PlotLabel -> "Blanch", AxesLabel -> {"time", "run"}, Ticks -> {{{X, ToString[X], {.5, 0}}}, None}, TicksStyle -> ...


2

A terser way to use Graphics[] arguments: pts = {{19.4, 12.4, 6.2}, {15.9, 4.6, 12}, {18.64, 10.52, 7.51}, {20.3, 3.1, 4.1}}; cols = {Green, Blue, Orange, Purple}; Manipulate[ Graphics3D[{Opacity[.1], Sphere[{18.64, 10.52, 7.51}, 2.93], Opacity[.5], AbsolutePointSize[6], Thread[{cols, Point /@ pts}]}, PlotRange -> If[fixedPltRng, {{-20, 20}, ...


2

Opacity should be in the range 0-1, and the elements must be in a list of elements: Manipulate[ Graphics3D[{ {Opacity[.1], Sphere[{18.64, 10.52, 7.51}, 2.93]}, {Opacity[.5], Green, AbsolutePointSize[6], Point[{19.4, 12.4, 6.2}]}, {Opacity[.5], Blue, AbsolutePointSize[6], Point[{15.9, 4.6, 12}]}, {Opacity[.5], Orange, AbsolutePointSize[6], ...


13

image = Import["http://i.stack.imgur.com/6YRfK.jpg"]; If you want to use your f, uRange and vRange as the arguments to ParamatricPlot3D, you need to wrap each with Evaluate: f = {u, Sin[v]*(u^3 + 2 u^2 - 2 u + 2)/5, Cos[v]*(u^3 + 2 u^2 - 2 u + 2)/5}; uRange = {u, -2.3, 1.3}; vRange = {v, 0, 2 Pi}; ParametricPlot3D[Evaluate@f, Evaluate@uRange, ...


1

In practice, the output form of Rule is effective for combinations of graphics and other expressions. For example, see: My answer to Temporal database reconstruction (note existing rules in Association and Dataset) Try kguler's graphics with g1 -> g2 -> g3 Can be used to quikly make legends for figures from Associations. Given data = <| "a" -> ...


3

gF = Graphics[{#[[1]], #[[2]], Black, Text[Style["\[RightArrow]", 72, Bold], Scaled@{.5, 1/2}], #2[[1]], Translate[#2[[2]], {3., 0}]}, ImageSize -> 500] &; gF[{Blue, Disk[]}, {Red, Polygon[{{1, -1}, {0, Sqrt[3] - 1}, {-1, -1}}]}] gF[{Blue, Polygon[Table[{Cos[2 \[Pi] k/6], Sin[2 \[Pi] k/6]}, {k, 0, 5}]]}, {Red, Polygon[Table[{Cos[2 ...


3

Try this: Manipulate[Show[{ Graphics[{Blue, Disk[{0, 0}, 1]}], Graphics[{Red, Polygon[{{4, -1}, {3, Sqrt[3] - 1}, {2, -1}}]}], Graphics[{Darker@Green, Thickness[0.007], Arrow[{{x1, y1}, {x2, y1}}]}] }], {{x1, 1}, 0, 3}, {{y1, 0.1}, 0, 3}, {{x2, 2.5}, 0, 3}] and play with the sliders. You should see the following: Have fun!


1

plotA = plotB = ContourPlot[Cos[x] + Cos[y], {x, 0, 4 Pi}, {y, 0, 4 Pi}, ImagePadding -> {{Automatic, Automatic}, {None, None}}]; GraphicsRow[{plotA, plotB}, Spacings -> 0] Or plotA = ContourPlot[Cos[x] + Cos[y], {x, 0, 4 Pi}, {y, 0, 4 Pi}, ImagePadding -> {{Automatic, Automatic}, {None, None}}]; plotB = ContourPlot[Cos[x] ...


1

If you take the problematic plot and normalize the arrows dimensions by brute force, the issue becomes clear! plot = (* copy-paste Manipulate's graphic *) Reap[plot /. Arrow[pts : {pt0 : {__}, {__}}] :> Sow[Line[{pt0, pt0 + .2 Normalize@First@Differences@pts}]]]; Graphics@%[[2, 1]] %%[[1]] The vectors are correct, but then displayed ...


0

Clear["`*"]; ang[n_] := Sum[ArcCot@Sqrt@i, {i, n}]; p[n_] := Sqrt[n + 1] {Cos@ang[n], Sin@ang[n]} poly[n_] := {{0, 0}, p[n], p[n + 1]}; Graphics[Table[{Hue[i/16], EdgeForm@Hue[i/16], Polygon@poly[i]}, {i, 0, 15}]]


2

Manipulate[ tick; If[n < (m - 1), n++; tick = Not[tick]]; Pause[pause]; Show[ Graphics[{ {Red, Disk[bob[[n]], .2]}, line, {Red, Thick, Arrow[{bob[[n]], bob[[n + 1]]}]}, }, Axes -> True, ImagePadding -> 5, ImageSize -> 400, PlotRange -> {{-1, 10}, {0, 10}}], bobl ], Button["run", n = 0; tick = Not[tick]], ...


9

With labels k = 1; angles = NestList[# - ArcTan[1./Sqrt[k++]] &, Pi, 15]; pts = Table[Sqrt[n]* {Cos[angles[[n]]], Sin[angles[[n]]]}, {n, 15}]; Graphics[{ Line[pts], Line[{{0, 0}, #}] & /@ pts, k = 2; Text["1", Sqrt[k++] {Cos[#], Sin[#]}] & /@ Mean /@ Most@Partition[angles, 2, 1], k = 1; Text[ToString[Sqrt[ToString[k]], ...


2

An alternative approach would be to use MapThread, which avoids one Transpose. I also created the titles a different way using Array, purely for didactic purposes of showing how to automate these things. Note that you can avoid using Directive in this way by setting BaseStyle. datamatrix = RandomInteger[{1, 9}, {20, 3}]; colors = {Red, Green, Blue}; ...


4

datamatrix = RandomInteger[{1, 9}, {20, 3}]; styles = {Directive[Thick, Red], Directive[Thick, Green], Directive[Thick, Blue]}; titles = ToString /@ {title1, title2, title3}; ListLinePlot[#, PlotStyle -> #2, PlotLabel->#3] & @@@ Transpose[{Transpose[datamatrix], styles,titles}] ListLinePlot[#, PlotStyle -> Directive[Thick, ...


22

One way to approach is to calculate the basic triangle (with sides of lengths Sqrt[n], Sqrt[n+1] and 1) and then rotate it the correct amount so that they all fit together. sumAng[n_] := Sum[ArcTan[1/Sqrt[i]], {i, 1, n}]; poly[n_] := {{0, 0}, {Sqrt[n + 1], 0}, {Sqrt[n + 1], 1}}; Graphics[Table[Rotate[{Opacity[1], Hue[RandomReal[]], Polygon[poly[i]]}, ...


4

The reason is because Show only use the options from the first graphic. Therefore, if you put tplot before splot, the range would be taken as that of tplot (2 to 10.3), and you would not be able to see the {1,0.2} point from splot. Conversely, if splot is in front, the plot follows the y range of splot, which only goes up to 0.33. Therefore, you would not ...


4

No, the Plot Ranges aren't similar. You need to force them: pr[n_] := {Min@#, Max@#} &@({t, Transpose[{Range@Length@s, s}]}[[All, All, n]]) tplot = ListLinePlot[t, PlotRange -> {pr@1, pr@2}]; splot = ListLinePlot[s, PlotStyle -> Red, PlotRange -> {pr@1, pr@2}]; GraphicsRow[{Show[splot, tplot], Show[tplot, splot]}]


5

With a hue disk as you suggested (but slightly tweaked to get the colours in the right spot): hueDisk = With[{sectors = 360}, angle = 2 Pi/sectors; Table[{Hue[1 - i/sectors], EdgeForm[{Thick, Hue[1 - i/sectors]}], Disk[{0, 0}, 0.6, {\[Pi]/2 + i angle, \[Pi]/2 + (i + 1) angle}]}, {i, 0, sectors - 1}]]; Then we can use the FilledCurve technique to ...


1

On the Documentation pages both for Graphics and Button only the two-argument form of Button is mentioned as a wrapper allowed inside of Graphics. So I would not say that the behavior you describe contradicts the Documentation. From the other side, for what purpose may you need a knowingly inoperative Button inside of Graphics? This approach looks like a ...


5

One way is to use your code for the snowflake, and turn it into an image. Then use the code for the colored circle and turn it into an image. Then multiply: f[{a : {x1_, y1_}, b : {x2_, y2_}}] := Partition[{a, (2 a + b)/3, {3 (x1 + x2) + \[Sqrt]3 (y1 - y2), \[Sqrt]3 (x2 - x1) + 3 (y1 + y2)}/6, (a + 2 b)/3, b}, 2, 1]; pts = Join @@ Nest[Join @@ f ...


0

quick fix is to use EdgeShapeFunction. My function here is not very sophisticated so it may happen that you cross different vertices somewhere some day, so be careful :) : Graph[{1 \[UndirectedEdge] 2, 1 \[UndirectedEdge] 4, 2 \[UndirectedEdge] 3, 2 \[UndirectedEdge] 5, 1 \[UndirectedEdge] 5, 3 \[UndirectedEdge] 4}, VertexLabels -> {1 -> ...


0

To calculate the ratio of mean intensities between the two regions of the cell (cytoplasm and nucleus). 1) I have used the code provided by bill s above as a starting point: 2) Next I subtracted the nucleus region from each cell using ImageSubtract. 3) I then use ComponentMeasurements to calculate the mean intensity of each cell sans the nucleus. ...


3

One way to approach this is to binarize the image twice: first to find the outer parts of the cells and then to try and locate the inner (nucleus) of the cells. img = Import["http://i.stack.imgur.com/0ULvT.jpg"]; imgBin1 = Binarize[Dilation[img, 1]]; imgBin2 = Binarize[Dilation[img, 1], 0.6]; ColorCombine[{imgBin1, imgBin2, imgBin2}] The final command ...


8

You have to add the index for the colors to LineLegend Legended[Grid[{{Show[oniplot], Show[cpplot]}}], LineLegend[97, {"factor = 2", "factor = 3", "factor = 4", "factor = 5"}]] In order to have the legend above the plots and with markers: Legended[GraphicsGrid[{{Show[oniplot], Show[cpplot]}}], Placed[LineLegend[97, {"factor = 2", "factor = 3", ...


3

I would use Grid, and transform your list in a matrix with empty strings where you do not want something to be shown, for example as follows: list = {{0, 1, 1, 0}, {1, 0, 1}, {1, 1}, {0}}; n = Length[list]; Grid[ Table[ With[{i = n - Length[d]}, RotateLeft[PadLeft[Riffle[d, ""], 2 n + 1, ""], i]], {d, list}]] (* 0 1 1 0 ...


2

vertices[n_Integer?Positive] := ({Cos[2 Pi #/n], Sin[2 Pi #/n]} & /@ Range[n]) Manipulate[ Module[ {vert = vertices[n]}, Graphics[{ Line[{{0, 0}, #}] & /@ vert, LightBlue, Opacity[.5], EdgeForm[Black], Polygon[vert]}]], {{n, 17}, Range[3, 20]}]


0

I wrote the original timeline answer. Your code does not work because in Mathematica For function does not produce output. Show function expects Graphics[] or List[Graphics[]] as input. I assume arrival and departure are strings events = {{0, "arrival", 1, 1}, {0.35749, "departure", 1}, {6, "arrival", 2,3}}; Table is a function that can loop through ...


4

You can't get what you want with EdgeForm[Thickness[.03]], that's not what EdgeForm meant for (that is, styles for the 1-dimensional edges). Here is a quick solution based on post-processing: Manipulate[ Normal[PolyhedronData["OctahedronThreeCompound", "Faces"]] /. p : Polygon[__] :> ( p /. pts : {{_?NumericQ, _, _}, ...


1

You can sort of achieve it with RegionDiscretize and BoundaryMesh regn = BoundaryMesh@DiscretizeRegion@ RegionDifference[Rectangle[{-2, -2}, {2, 2}], Disk[{0, 0}, 1]] Show[regn, Graphics@Line[{{0, 0}, {3, 1}}]] MeshRegions (what DiscretizeRegion generates) have many styling options.


20

Your comment raises interesting question: I got everything simply faded and flat, while in the example - its all bright and sharp I think the problem is related to the fact that Mathematica's graphical functions always work in linear colorspace. Starting from Pickett's solution with better resampling method, in version 10.0.1 we obtain: ...


6

You tried to decrease the width of the lines to below the minimum width. In order to achieve the same effect you can increase the size of the image instead. x = RandomReal[1, 10000]; y = RandomReal[1, 10000]; Show[ImageResize[Rasterize@ListLinePlot[{Thread@{x, y}}, ImageSize -> 10000], 300], ImageSize -> 300]


9

On-screen, lines are always at least 1 pixel wide in Mathematica, regardless of the thickness setting. Not sure what you tried with Opacity, as it seems to be possible to achieve the same effect: PlotStyle -> Directive[AbsoluteThickness[1], Opacity[.05]]


2

It seems you need more points, not recursion. If you increase the number of PlotPoints and add PerformanceGoal -> "Quality", the wiggles disappear! bicone = ParametricPlot3D[{(1 - Abs[z]) Cos[t], (1 - Abs[z]) Sin[t], z}, {z, -1, 1}, {t, 0, 2 \[Pi]}, Mesh -> None, Boxed -> False, Axes -> None, PlotStyle -> {Specularity[White, 15], ...


1

Actually, the problem is with Mathematica's export, at least with Version 10. I have been saving a file wit MatrixPlot (using Save As...-> PDF), and have encountered the same problem. Turns out, MatrixPlot (and similar) data is being exported as a bitmap, which gets blurred in Adobe Reader 9 (which I have), even if "Smooth line art" and "Smooth images" is ...


3

polys = {Polygon[{{989, 1080}, {568, 1080}, {834, 711}}], Polygon[{{1184, 1080}, {989, 1080}, {834, 711}, {958, 541}}], Polygon[{{1379, 1080}, {1184, 1080}, {958, 541}, {1082, 370}}], Polygon[{{1470, 1080}, {1379, 1080}, {1082, 370}, {1140, 291}}], Polygon[{{1665, 1080}, {1470, 1080}, {1140, 291}, {1263, 120}}], Polygon[{{1756, 1080}, {1665, ...


3

your plot is ok. actually all polygons are plotted but because the EdgeForm & FaceForm, the plot is not clear. check this: poly = {Polygon[{{989, 1080}, {568, 1080}, {834, 711}}], Polygon[{{1184, 1080}, {989, 1080}, {834, 711}, {958, 541}}], Polygon[{{1379, 1080}, {1184, 1080}, {958, 541}, {1082, 370}}], Polygon[{{1470, 1080}, {1379, 1080}, ...



Top 50 recent answers are included