Tag Info

New answers tagged

4

I nest the right turns with # + Normalize@Cross[#] &. Since 2012rcampion has rather solved the coloring, here's a version using a close match from one of Mathematica's gradients. cf = Lighter[ColorData["AvocadoColors", 1. - #], (1. - #)^8] &; With[{npts = 87}, Graphics[ GraphicsComplex[ NestList[# + Normalize@Cross[#] &, {1., 0.}, npts - ...


0

Your issue appears to be the related to the Thickness of the edges of the polygons. It shows up most when adjacent colours are dark. By increasing the thickness of the edges using Thickness and setting the colour of the edges to the colour of the polygon using EdgeForm you can make the edges overlap slightly and remove the white lines. I would also use the ...


0

There are several mistakes in your code. Please compare: Manipulate[ Graphics[{Circle[{10*t, 10}, 10], PointSize@0.02, Point[{0, 0}]}, PlotRange -> {{-20, 200}, {-20, 200}}], {t, 0, 2 \[Pi]}]


10

I tried to do this without looking at the previous answers... let me know if I accidentally plagiarized! With[{n = 87}, Module[{radii = Sqrt[Range[n]], angles, coords}, angles = Accumulate @ Most[ArcCot[radii]] ~Prepend~ 0; coords = radii * Transpose @ Through[{Cos, Sin}[angles]]; Graphics[{ EdgeForm[Black], Reverse @ MapIndexed[{ ...


6

Module[{data, range}, data = TimeSeries[#, ResamplingMethod -> {"Constant", 0}] &@{{1891, 1}, {1892, 1}, {1897, 1}, {1898, 1}, {1903, 1}, {1904, 1}, {1905, 1}, {1908, 4}, {1909, 6}, {1910, 6}, {1911, 16}, {1912, 33}, {1913, 35}, {1914, 43}, {1915, 39}, {1916, 31}, {1917, 42}, {1918, 52}, {1919, 44}, {1920, 53}, {1921, 33}, ...


9

Michael Seifert's answer is the easiest for curves that can be plotted parametrically, but there is a slightly more general method that can be use to construct an extrusion of any curve that can plotted in 2D. First, note that one can always extract the points from a 2D plotted curve, because Mathematica never forgets. For instance, with the curve provided ...


1

As it is a polynomial family, here is an algebraic approach: family = x/a + y/b - 1 // Together // Numerator; constraint = a + b - 2; envsys = Flatten@{family, D[family, {{a, b}}] - λ D[constraint, {{a, b}}], constraint} (* {-a b + b x + a y, -b + y - λ, -a + x - λ, -2 + a + b} *) env = First@GroebnerBasis[envsys, {λ, a, b}] (* 4 - 4 x + x^2 - 4 y - 2 x ...


2

For the second part of your question (finding the envelope) we can use the argument from page 5 of these lecture notes. Basically the envelope is where two very close strings intersect each other. We can parameterize the string by: $$ \{x,y\} = \{x_1(t),y_1(t)\}(1-s) + \{x_2(t),y_2(t)\}s $$ Where the $\{x_i,y_i\}$ represent the two endpoints, $s\in ...


2

The second part of your question can be resolved as follows. First find the equation for any given line. y = k x + y0. Solve[{b == k * 0 + y0, 0 == k * a + y0, a + b == 2}, {k, y0, a}] {{k -> b/(-2 + b), y0 -> b, a -> 2 - b}} It is clear enough, that the bottom and leftmost boundaries are the x and y axes. Let's find the boundary on top. We ...


8

You could create parametric plots for the endcaps as well: tube = ParametricPlot3D[{R6[θ] Cos[θ], R6[θ] Sin[θ], z}, {θ, 0, 2 π}, {z, -2, 5}, Axes -> False, Boxed -> False, Mesh -> None] endcap1 = ParametricPlot3D[{r R6[θ] Cos[θ], r R6[θ] Sin[θ], 5}, {θ, 0, 2 π}, {r, 0, 1}, Mesh -> False]; endcap2 = ParametricPlot3D[{r R6[θ] ...


1

The first part of your question can be done using Plot f[a_, x_] := 2 - a - (2 - a) x/a Plot[Table[f[a, x], {a, .001, 2, .03}], {x, 0, 3}, PlotRange -> {{0, 2}, {0, 2}}, AspectRatio -> 1, Evaluated -> True] or Graphics with Line primitives: Graphics[Table[{Hue[RandomReal[]], Line[{{a, 0}, {0, 2 - a}}]}, {a, 0, 2, .03}], AspectRatio -> ...


1

list = {1, 2, 3, 4} ; keys = {7, 8, 9, 10}; styleddata = Style[#, {Black, Red}[[Mod[#2, 2, 1]]]] & @@@ Transpose[{list, keys}]; Or styleddata = Style[#, If[OddQ@#2, Black, Red]] & @@@ Transpose[{list, keys}]; styleddata = Style[#, #2 Black + (1 - #2) Red] & @@@Transpose[{list, Boole@OddQ@keys}]; ListPlot[styleddata, BaseStyle -> ...


3

Just use a color function that you can map over your keys keyList = {1, 2, 3}; keys = RandomChoice[keyList, 10];(*Dummy keys*) pts = RandomInteger[100, {Length@keys, 2}];(*Dummy Points*) colors[key_] := Hue[key/Length@keyList];(*A color function that you can modify*) ListPlot[ Transpose@{pts}, PlotStyle -> colors /@ keys ]


5

p[t_,t1_] := Transpose@{{-7 t, 8 + 17 t, 8 + 17 t, 8, 8, 0, -3 t, -7 t, -7 t}, Array[20 t1 &, 9], {-8-3 t,-8-3 t, 0, 0, 20 t, 20 t, 0, 0, -8-3 t}}/20 Manipulate[ Graphics3D[{FaceForm[Transparent], Polygon@p[h,0], Polygon@p[h,h], Line /@ Transpose[{p[h,0], p[h,h]}]}, Boxed -> True, PlotRange -> {{-12, 12}, {0, 12}, ...


2

For a graphical study I would solve the two equations independently. First one gives you one up to three x-solutions with y as additional parameter. Second one give one up to three y-solutions with x as additional parameter. Next I would plot the solutions as ParametricPlot[] with different colors on top of each other. So something like solx=Solve[(rA-rB) ...


1

I know it's been more than two years since the question was asked but please allow me to answer nevertheless for future reference. According to Wikipedia articles on Mollweide and equirectangular projections, the function mollweidetoequirect that converts the former to the latter can be constructed as follows: lat[y_, rad_:1] := ArcSin[(2 theta[y, rad] + ...


5

Circle Let's create circle3D that is something you would expect from Circle but with an extra argument for its normal vector. With circle3D[centre_: {0, 0, 0}, radius_: 1, normal_: {0, 0, 1}, angle_: {0, 2 Pi}] := GeometricTransformation[#, RotationTransform[{{0, 0, 1}, normal}, centre]] &[ Map[Append[#, Last@centre] &, #, {3}] &[ ...


2

I've found this useful on a number of occasions: use a BezierCurve, which can be a 3D object, to approximate a circle. bezierarc[xc_, a_, b_ , r_: 1, n_: {0, 0, 1}] := (* Bezier approximation to an arc *) (*Excellent approximation for included angle b-a < Pi/2 *) (* "pretty good" approximation for b-a< Pi *) Module[{rstar, del, p, c, ...


6

Another take based on @rasher's comment: Graphics[{Thickness[.02], Arrowheads[{{-.1, 0, Graphics[{Thickness[.02], CapForm["Round"], Line[{{-1, 0}, {0, 0}}]}]}, {.2, 1}}], Arrow[BSplineCurve[{{0, 0}, {4, 7}, {2, 11}, {10, 10}}, SplineWeights -> {3, 5, 4, 5}], .05]}] Update: What if the arrow is dashed or dotted? Overlaying ...


1

Here's a rough version of comment: ah = Graphics[{Line[{{{-1, 1/2}, {.04, .2}}, {{-1, -1/2}, {.04, -.2}}}], Circle[{.01, 0}, .2, {-4/9 Pi, 4/9 Pi}]}] Graphics@{Arrowheads[{{Automatic, Automatic, ah}}], CapForm["Round"], Thick, Arrow[ BSplineCurve[{{0, 0}, {4, 7}, {2, 11}, {10, 10}}, SplineWeights -> {3, 5, 4, 5}], .05]}


4

You can also use Exclusions with ParametricPlot3D: ParametricPlot3D[{Cos[u] Sin[v], Cos[u] Cos[v], Sin[u]}, {u, -π, π}, {v, -π/2, π/2}, Mesh -> None, PlotStyle -> Opacity[.25, Blue], PlotPoints -> 80, MaxRecursion -> 4, Exclusions -> {Cos[u] Cos[v] == .7}, ExclusionsStyle -> ({Directive[Opacity[1], Thick, Red]})]


5

You can also plot two partial spheres and highlight where they meet smallSphere = ParametricPlot3D[ {Cos[θ] Sin[ϕ], Cos[θ] Cos[ϕ], Sin[θ]}, {θ, -π, π}, {ϕ, -π/2, π/2}, Mesh -> None, PlotStyle -> {LightBlue, Opacity[0.4]}, BoundaryStyle -> Directive[Thick, Red], RegionFunction -> (#2 > .6 &) ]; bigSphere = ...


4

One can get a sort of array plot with ParametricPlot, MeshShading and an appropriate Mesh that seems equivalent to the Matlab plot: n = 20; r = Range[40.]/20; theta = Pi Range[40.]/20; m = Table[r1 Cos[2. theta1], {theta1, theta}, {r1, r}]; colorFn = ColorData["Rainbow"]; ParametricPlot[r {Cos[t], Sin[t]}, {r, 0, 1}, {t, 0, 2 Pi}, Mesh -> ...


5

draw[sphere : {sC_, sR_}, circle: {ctr_, pt_}] := ParametricPlot3D[sR {Cos[u] Sin[v],Sin[u] Sin[v],Cos[v]}+sC, {u,0,2 Pi}, {v,0,2 Pi}, MeshFunctions -> (Norm[{##}[[1;;3]]-ctr] - Norm[ctr-pt] &), Mesh -> {{0}}] SeedRandom[42]; sCenter = {1, 1, 1}; sRadius = 1; cs = Map[Plus[Normalize[#], sCenter] &, RandomReal[{-1, 1} sRadius, {10, 2, 3}], ...


14

center = Normalize@{1, 2, 3}; point = Normalize@{0, 2, 1}; with minimum of algebra: Show[ ParametricPlot3D[ Evaluate[ N[center + RotationMatrix[t, center].(point - center)]], {t, 0, 2 Pi}], Graphics3D[{Sphere[], Blue, Sphere[{center, point}, .05]}] , PlotRange -> 1.1 ]


7

circle is 2D and sphere is 3D. Hence you are missing one dimension to make them both show together. i.e. you need orientation for the circle. This should get you started. You can approximate a circle with Cylinder of very small length. Graphics3D[{ {Red, Cylinder[{{1, 0, 0}, {1.01, 0, 0}}, 1]}, Sphere[{0, 0, 0}, 1] }, Boxed -> False]


12

Let me use this as example data instead (your m is too big): m = RandomReal[1, {4, 24}]; Crude Attempt polararrayplot[array_, colourfunc_] := SectorChart[ Map[Style[{1, 1}, colourfunc[#]] &, array, {2}], SectorSpacing -> None ]; polararrayplot[m, ColorData["Rainbow", #] &] Finer Attempt The code is fairly self-explanatory. I'm sure ...


3

Something like this? polygon = CountryData["World", "SchematicPolygon"]; image = ExampleData[{"TestImage", "Lena"}]; GeoGraphics[{GeoStyling[{"GeoImage", image}], polygon}, GeoBackground -> LightBlue, GeoRange -> "World", GeoProjection -> "Bonne"]


1

Let me update Simon's code for Mathematica 10. We no longer need to explicitly load TetGenLink. tetrahedra = Level[MeshPrimitives[DelaunayMesh[data3D], 3], {-3}]; radius[p_] := Sqrt[Area[Circumsphere[p]]/(4 Pi)]; radii = radius /@ tetrahedra; alphashape[rmax_] := Pick[tetrahedra, radii, r_ /; r < rmax] faces[tetras_] := Flatten[ tetras /. {a_, b_, c_, ...


1

You need to set the size of the elements of the scorecard. Have a look at Histogram's ImageSize option. Also you can set your tables in Grid or TableForm wrapped in a Pane or Panel to get them the size you want as well. They have ImageSize options as well. To help with the ImageSize parameters make use of UnitConvert to convert from your know dimensions in ...


8

I just finished blog post about the creation of nice graphics from Mathematica Graphics3D using the Blender render framework: http://wolfig-techblog.blogspot.de/2015/04/blender-as-shader-for-mathematica.html Maybe you can find some inspiration there for your own graphics. I managed to generate a reasonable Klein bottle with glass shading: Note: the ...


2

The fundametal problem is here: Pnt = Append[Pnt, {X, Y}] && Break[] The Break is evaluated and exits before the assignment. Just do this: Pnt = Append[Pnt, {X, Y}] ; Break[] That said Reap/Sow is a better way to go: Bleh[n0_] := Module[{iteration = 1000, error = 10^(-10), denominator = 10^(-10)}, Last@Reap[ Table[ X = ...


1

Better if both images have the same dimensions. Anyway. p = CountryData["World", "Polygon"]; rose = Import["ExampleData/rose.gif"]; mask = Graphics[{EdgeForm[Black], p}]; blueOcean = ColorReplace[mask, White -> Blue]; ImageAdd[ImageMultiply[rose, ColorNegate@mask], blueOcean]


1

Here's my attempt to plot the Mandelbrot set with Monte Carlo randomization: mand = Compile[{{z0, _Complex}, {imax, _Integer}}, Module[{z = z0, i = 0}, While[i < imax && Abs[z] <= 2, z = z^3 - 2 z + 2; i++]; i], Parallelization -> True, RuntimeAttributes -> Listable(*, CompilationTarget->"C"*)]; n = 10^6; range = 2; ...


3

Given line1 = {p1, p2}; line2 = {p3, p4}; you could define two points on these lines: l1 = {1 - u1, u1}.line1; l2 = {1 - u2, u2}.line2; and just solve for the intersection: l1 /. Solve[l1 == l2, {u1, u2}] Alternatively (and more elegantly) you could use projective geometry, where Cross[p1,p2] is the line between two points p1 and p2 and ...


2

Here's a quick&dirty&buggy solution for your two wishes, although I strongly suggest you to do you works the way as the notebook interface designed to. Cls := (SelectionMove[InputNotebook[], All, Notebook]; FrontEndExecute[FrontEndToken["Clear"]]); $Post = (If[Head@$outputNB == Symbol, $outputNB = CreateNotebook[]]; If[# === Null, 1;, ...


4

Another explanation is, that Circle is a graphical primitive, not a pure mathematical function in itself, and therefore does not accept units. When one uses a mathematical object, units can be used throughout. Example: The circle centered on $(xc,yc)$ with radius $r$ $$(x-xc)^2+(y-yc)^2=r^2$$ can be drawn with units in Mathematica using ContourPlot: ...


4

Quantity itself can't be used as its own value. You need to extract the numerical value itself, like this x = Quantity[3, "Meters"]; y = Quantity[2, "Meters"]; r = Quantity[5, "Meters"]; Graphics[Circle[{QuantityMagnitude[x, "Meters"], QuantityMagnitude[y, "Meters"]}, QuantityMagnitude[r, "Meters"]] ] You can think of Quantity ...


4

Using the option Exclusions->None fixes the issue in both plots: ContourPlot[L, {x, 0, xmax}, {y, 0, ymax + 1}, Contours -> 50, ColorFunction -> Function[{x, y, z}, Hue[x]], Exclusions -> None] Plot3D[L, {x, 0, xmax}, {y, 0, ymax + 1}, ColorFunction -> Function[{x, y, z}, Hue[z]], Mesh -> None, ClippingStyle -> {Blue, Red}, ...


2

To ensure that this does not remain unanswered, this was fixed for 10.1. So, now it returns an FE error, as expected: Fix is confirmed on Mac OS, Windows, and Linux.


1

You could add set back to your EdgeShapeFunction: EdgeShapeFunction -> (If[#[[1]] != #[[-1]], {Arrowheads[ If[#2[[1]] == chr, {{0.04, 1}}, {{0.02, 0.2}, {0.02, 0.8}}]], Arrow[BSplineCurve[{#[[1]], {0, 0}, #[[-1]]}, SplineWeights -> {2, 1, 2}], .025]}, Opacity[0]] &)


1

-1 < orientation < 0 -> Blue, 0 < orientation < 1 -> Red Since your orientiation values appear to be between -1 and 1 this requirement translates to Sign[orientation] /. {-1 -> Blue, 1 -> Red} so: Visualization = Graphics[{Thickness -> 0.0025, SampleData /. {({centroidx_, centroidy_, orientation_, majordiameter_, ...


-1

This seems perfectly legible to me: Arrowheads[If[#2[[1]] == chr, {{0.04, .98}}, {{0.02, 0.2}, {0.02, 0.8}}]]


1

You can also use Epilog: img=ExampleData[{"TestImage", "Mandrill"}]; pnts={1, 10, 20, 30, 40, 50}; NumberLinePlot[pnts, ImageSize->600, Epilog -> (Inset[Show@Thumbnail[img, 50], #]&/@ Thread[{pnts, 1}])] Or post-process Point primitives into Insets: NumberLinePlot[pnts, ImageSize->600]/. Point[x_]:>(Inset[Show@Thumbnail[img,50], ...


2

im = Import["ExampleData/lena.tif"]; Show[ NumberLinePlot[{1, 10, 20, 30, 40, 50}], Graphics[ {Inset[im, {1, 1}], Inset[im, {20, 1}], Inset[im, {40, 1}] } ] ] You'd have to adjust the sizes and scale things to make it look ok


5

ClearAll[cyclesF, edgesF] cyclesF = Map[FromCharacterCode, 64 + PermutationCycles[ToCharacterCode@# - 64][[1]], {-1}] &; edgesF = Developer`PartitionMap[DirectedEdge @@ # &, #, 2, 1, {1, 1}] & /@ cyclesF[#] &; str = "AJDKSIRUXBLHWTMCQGZNPYFVOE"; colors = {Red, Green, Blue, Orange, Cyan, Yellow}; vl = cyclesF@str; el = ...


4

Not going to win a beauty contest, but you might get some ideas: string = "AJDKSIRUXBLHWTMCQGZNPYFVOE"; rules[cycle_] := Thread[DirectedEdge[cycle, RotateLeft[cycle]]]; edges = MapIndexed[Style[#1, Thick, ColorData[2][#2[[1]]]] &, rules /@ PermutationCycles[LetterNumber /@ Characters[string], Identity], {2}]; verts = ...


5

s = "AJDKSIRUXBLHWTMCQGZNPYFVOE"; pc = PermutationCycles[ToCharacterCode@s - 64] // First; Graph[Flatten[Thread[# -> RotateRight@#] & /@ pc], VertexLabels -> Table[i -> FromCharacterCode[i + 64], {i, Flatten@pc}], ImagePadding -> 12] Perhaps better: pc = (PermutationCycles[ToCharacterCode@s - 64] // First) /. ...


2

uuhahh, there is an important big difference. Grid returns a Grid object whereas GraphicsGrid returns an Image. Therefore you will be able to apply all Image functions to GraphicsGrid as a whole, whereas this is not possible on a Grid as a whole. Here an example to illustrate, try to use ImageRotate in both cases and see what is happening : Case 1: ...


1

xB = {0.00, 0.076, 0.164, 0.300, 0.479, 0.638, 0.854, 0.941, 1.00}; pP = {44.0, 42.2, 39.5, 36.4, 30.4, 27.6, 22.4, 12.9, 0.00}; pT = {44.0, 66.4, 84.0, 99.8, 105.8, 108.4, 109.0, 104.5, 94.4}; iP = Interpolation[{xB, pP}\[Transpose]]; iT = Interpolation[{xB, pT}\[Transpose]]; Show[ Plot[{iP[x], iT[x]}, {x, Min[xB], Max[xB]}], ListPlot[{{xB, ...



Top 50 recent answers are included