Hot answers tagged

16

I'm going to take the interpretation that you want to apply the transverse Mercator projection to an image you have to produce something like the one in the Wolfram page you linked to. One only needs to make a few changes to the code in that link. I will be using a different image, since the one in the OP is awkwardly cut off, which will mess with the ...


13

A natural and simple way to approach this problem, assuming that your SiPyramid function has been defined, is as follows: g = SiPyramid[1, {1, 1, 1}]; vertices = Union[g /. Tetrahedron[{vv__}] -> vv]; edges = Flatten[g /. Tetrahedron[vv_] :> UndirectedEdge @@@ Subsets[vv, {2}]]; Graph3D[vertices, edges, VertexCoordinates -> vertices] ...


13

I guess something like this: With[{n = 7}, BlockRandom[SeedRandom["triangles"]; Graphics[Table[{RandomColor[], Polygon[TranslationTransform[{Sqrt[3] (j + i - 1), 3 j + Boole[EvenQ[i]]}/2] @ ...


11

With GeoGraphics: GeoGraphics[{GeoStyling@Opacity@1, RandomColor[], CountryData[#, "SchematicPolygon"]} & /@ Join[CountryData["Continents"], CountryData[]], GeoBackground -> Hue[0.56, .8, .8, .5], GeoRange -> "World", GeoProjection -> "Robinson", Background -> White]


10

This question is not a bit hard: mat = {{1, 0}, {1/2, Sqrt[3]/2}}; draw[n_] := Graphics[Table[{RandomColor[], Triangle[{{i + n + 1 - #, j + n + 1 - #}, {i, j + 1}, {i + 1, j}}.mat]}, {i, n}, {j, # - i}] & /@ {n, n + 1}]; draw[8] Code is easy, check it by yourself~


10

This should do it: Plot[Tan[x], {x, -2 π, 2 π}, Exclusions -> Range[-3 π/2, 3 π/2, π], ExclusionsStyle -> Directive[Gray, Dashed, Arrowheads[{}]], PlotStyle -> Arrowheads[0.04 {-1, 1}], Ticks -> {Range[-2 π, 2 π, π/2], Automatic}] /. Line -> Arrow


9

Here's my take: lbl = {"Construction Foreman", "Tile & Marble Setter", "Bricklayer", "Stonemason", "Apprentice Tile & Marble Setter", "Apprentice Bricklayer", "Apprentice Stonemason", "Helper/Finisher"}; ef[pts_List, e_] := {Arrowheads[{{0.05, RandomReal[{0.5, 0.7}]}}], Arrow[pts]} vc = ({2, 1}*#) & /@ {{6, 9}, {3, 6}, {6, 6}, {9, ...


8

There may be a simpler way to do this, but this function works for any object composed of Tetrahedron objects. I also made it work for MeshRegion objects of dimension 3. Expanding this to work with Polygon, Line, and Point objects should be straightforward. tetGraph[tet3D_, graphOpts : OptionsPattern[]] := With[{list = Cases[tet3D, Tetrahedron[a__] ...


8

I am late to see this question but here is a solution closely based on my answer to Creating a Sierpinski gasket with the missing triangles filled in. tri[n_] := Table[{2 j - i, Sqrt[3] i}, {i, 0, n}, {j, i, n}] // Partition[Riffle @@ #, 3, 1] & /@ Partition[#, 2, 1] & Example of use: Map[{RandomColor[], Polygon@#} &, tri[5], {2}] // ...


6

Anothor way by NestList randomTriPlot[n_] := Module[{next}, next[polys_] := Join[Map[# + {-1, -Sqrt[3]} &, polys, {2}], {MapAt[# - 2 Sqrt[3] &, polys[[-1]], {1, 2}], # + {1, -Sqrt[3]} & /@ polys[[-1]]}]; (*get coordinate of the next layer by translate this layer*) Flatten@ Map[Polygon, NestList[next, N@{{{0, 0}, {...


5

You can also change Lines to Arrows using PlotStyle as follows: Plot[Tan[x], {x, -2 π, 2 π}, Exclusions -> Range[-3 π/2, 3 π/2, π], ExclusionsStyle -> Directive[Gray, Dashed], PlotStyle -> ({Arrowheads[{-.05, .05}], Arrow @@ #} &), Ticks -> {Range[-2 π, 2 π, π/2], Automatic}]


5

Use Table old[τ_] := Sin[τ] new[α_, χ_, τ_] := Sin[α τ]^2 + Cos[χ τ]^2 result = Table[Plot3D[ new[α, χ, τ] - old[τ], {α, 0, 2 π}, {χ, 0, π}, MaxRecursion -> 0, AxesLabel -> Automatic] , {τ, 1/10, 1, 1/10}] Export["result.gif", result] Or use Animate Animate[Plot3D[ new[α, χ, τ] - old[τ], {α, 0, 2 π}, {χ, 0, π}, MaxRecursion -> 0, ...


5

VertexCoordinateRules apply to elements in the absolute order given, so by leading with 2 in 2 -> 1 you need to give its coordinate first. titles = {"Construction Foreman", "Tile & Marble Setter", "Bricklayer", "Stonemason", "Apprentice Tile & Marble Setter", "Apprentice Bricklayer", "Apprentice Stonemason", "Helper/Finisher"}...


5

Something quick and dirty like this, rotateAndRescaleGraphics[g_Graphics, scale_, angle_] := Module[{xr, yr}, {xr, yr} = Charting`get2DPlotRange@g; g /. {x_?NumericQ, y_?NumericQ} :> ({Rescale[#1, xr, scale xr], Rescale[#2, yr, scale yr]} & @@ (RotationMatrix[angle].{x, y})) ]; Show[tp, ...


4

As your own title says, you should use Scale instead of Magnify as follows: tp = Plot[{Sin[x], -Sin[x]}, {x, 0, 1 Pi}, AspectRatio -> Automatic, Axes -> None, PlotStyle -> {Black, Black}, Filling -> Axis]; tprs = Graphics[Scale[Rotate[tp[[1]], 45*Degree], 0.5]]; Show[tp, tprs] To be able to apply Scale, I first extract the Graphics ...


4

In an airfoil you probably want a sharp trailing edge and a rounded leading edge. Therefore I would choose the trailing edge as first and last point for your spline: airfoilData = Drop[Take[ Drop[Import["http://m-selig.ae.illinois.edu/ads/coord/n64015.dat"], 3], 53], {27}]; upperSide = airfoilData[[1 ;; Length@airfoilData/2]]; lowerSide = ...


4

J.M.'s answer is the best and he helped me figure out the correct parametric equations from here, but the method I've been working on is very fast (<0.5 sec) and doesn't include any white-space where the slices connect. img = Import["http://i.stack.imgur.com/jteWq.jpg"]; gore = 12; tex = First @ ImagePartition[img, Scaled[{1/gore, 1}]]; ImageAssemble[...


3

Your idea is to pick a value to the left if the function is decreasing and a value to the right if the function is increasing because then you'll get a value that's slightly larger. In order to get the flat line over the tops you might instead look for the maximum value in the neighborhood of the current position, it will be the same for the increasing and ...


3

From its doc Graphics[{Hue[ 2/3 Sqrt[ 1 - (CountryData[#, "IndependenceYear"] /. {DateObject[{y_}] :> y, _Missing -> First[DateList[]]})/First[DateList[]]]], CountryData[#, "SchematicPolygon"]} & /@ CountryData[]] which makes it plot countries color coded by the length of their claimed independence. You can plot by any ...


3

Here's my take. The idea is similar to Mark's, except that I use ClusteringComponents[] to identify duplicate vertices, and VertexContract[] to merge those vertices together: tetpts = N[PolyhedronData["Tetrahedron", "VertexCoordinates"], 20]; tet = Tetrahedron[tetpts]; tr = TranslationTransform /@ (tetpts/2); makeEdge = Function @@ {MeshCells[...


2

An alternative method using pure graphics. form = Module[{top, btm}, top = N @ Table[{t, Sin[t]}, {t, Subdivide[π, 20]}]; btm = Reverse[{1, -1} # & /@ top]; {EdgeForm[Black], FaceForm[LightGray], FilledCurve[Line[top~Join~btm]]}]; Graphics[{Opacity[.7], form, Rotate[Scale[form, 0.5, {0, 0}], 45*Degree, {0, 0}]}]


2

It does seem possible to change a bond cutoff length using built-in functions, as mentioned by Szabolcs in comments, via something like Import["ExampleData/caffeine.xyz", "XYZ", "InferBondsMinDistance" -> #] & /@ {10000, 15000, 20000} But I have no idea what units those are supposed to be. They aren't ångströms (which the "XYZ" files are ...


1

Here's my code, using Table[] Manipulate[ Graphics[Table[{EdgeForm[Thin], FaceForm[White], Rectangle[{a i, b j}, {(i + 1) a, (j + 1) b}]}, {i , 0, ni}, {j , 0, nj}]], {a, 0.1, 2, 0.1}, {b, 0.1, 2, 0.1}, {ni, 1, 10, 1}, {nj, 1, 10, 1}]


1

For is highly inefficient in Mathematica; I recommend something else. For instance: Manipulate[ GraphicsGrid[ConstantArray[, {ly, lx}], Frame -> All, ImageSize -> {(d + 1) lx + 1, (d + 1) ly + 1}], {{lx, 3}, 1, 10, 1}, {{ly, 3}, 1, 10, 1}, {{d, 10}, 1, 100, 1}]


1

Most probably not the simplest solution, but here is a way using Graphics to plot the data and EventHandler and Tooltip to do the dynamic highlighting: listPlotWithHighlight[data_] := With[{ colors = ColorData["Rainbow"] /@ (1/Range@Length@data), points = MapIndexed[{First@#2, #1} &] /@ data, initPointSizes = 0.02 ConstantArray[1, Length@First@...



Only top voted, non community-wiki answers of a minimum length are eligible