New answers tagged

3

Here is sparse array solution to boost up the performance when the number of your points is very large($>1000$). f[{i_, nonzero_}, {idx_}] := Thread[Thread@{idx, Range[i - 3 + 1, i + 1]} -> nonzero] searchSpan[{deg_, knots_}, u_] := With[{un = knots[[-(deg + 1)]]}, If[u == un, Position[knots, un][[1, 1]] - 2, Ordering[...


3

After permuting the points so that the cusp is the first point (just like in mns's answer), the methods of this answer can be used: airfoil = Flatten[MapAt[Most @* Reverse, DeleteCases[Split[Drop[ Import["http://m-selig.ae.illinois.edu/ads/coord/n64015.dat"], 3], # =!= {} && #2 =!= {} &], {{}}], 1], 1]; (* ...


4

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


7

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


6

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


6

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: path = "http://m-selig.ae.illinois.edu/ads/coord/n64015.dat"; airfoilData = Drop[Take[Drop[Import@path,3], 53], {27}]; upperSide = airfoilData[[1 ;; Length@airfoilData/2]]; lowerSide = ...


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


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

I've decided to be ornery and render the trinomial tetrahedron upside-down for this answer. segmentList[lst_List, prts_] /; VectorQ[prts, IntegerQ] && Total[prts] == Length[lst] := With[{acc = Accumulate[prts]}, Inner[Take[lst, {#1, #2}] &, Prepend[Most[acc] + 1, 1], acc, List]] With[{n = 4}, Graphics3D[{Text[Style[#1,...


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


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


0

It is rather slow, but you can define g[x_?NumericQ] := Module[{e}, MaxValue[{f[x + e], -1/5 <= e <= 1/5}, e]] Plot[{f[x], g[x]}, {x, 0, 10}] giving


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


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


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"}...


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


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


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


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


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


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


11

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


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}, {...


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~


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


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


0

According to solution of Dr. Belisarius I wrote this more convenient code: (* default options needed for error plot *) Options[errListPlot] = { Filling -> {1 -> {2}}, Joined -> {False, False, True}, PlotStyle -> {Black, Black, Directive[Opacity[0.6], Blue]}, FillingStyle -> Black, PlotMarkers -> {Graphics@Line[.04 {{-1, 0}, {...


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]


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


2

The workaround given in comments works. You should set CacheGraphics->False. i.e. Button[ Style[ SetAlphaChannel[ Graphics@Rectangle[], Graphics@Disk[]], CacheGraphics -> False ], Print[1] ] – ihojnicki Jul 13 at 19:59 One can put it in BaseStyle -> {CacheGraphics -> False} too.


14

I would like provide an alternative answer using the method of Simon Woods to extract the contour lines. However, in contrast to his approach I prefer to have them as long as possible. This is achieved by the StreamScale -> Full option. nlines = 30; flist = {-1 - x^2 + y, 1 + x - y^2}; xmn = -3; xmx = 3; ymn = -3; ymx = 3; subint = 3; plot = ...


9

JM commented: If you want to try things out, use Nylander's second snippet, which is using a Beeman integrator. This looks to be faster than native NDSolve[] for this specific case. Paul Nylander's code is here. Below is a modified version of his code which computes all points simultaneously using the fact that all the operations in Beeman's ...


8

I think the problem is sloppy documentation, rather than an implementation bug. A lot of current documentation is incomplete, misleading, or just plain wrong. Here is another example of bad documentation taken from HighlightImage. The following wrappers can be used ... $\qquad$Tooltip[e, label] attach an arbitrary tooltip to the element But ...


10

I don't have any breakthrough ideas, but I am able to cut the computation time in half on my computer by optimizing the usage of NDSolve. My version of your code looks like this: X[1] = 1; X[2] = -(1/2); X[3] = -(1/2); Y[1] = 0; Y[2] = Sqrt[3]/2; Y[3] = -Sqrt[3]/2; Sol[k_, c_, h_, xo_, yo_] := NDSolve[{ x''[t] + k x'[t] + c x[t] - Sum[(X[i] - x[t])/(h^...


2

I finally got home and finished my answer, but there's still one drawback which I strongly suspect as a bug of HighlightImage. So, I'll present you a partial solution now: Clear["`*"]; img = Graphics[{Blue, Disk[{1, 0}, 3/2]}]; mask = {Disk[{0, 0}, 1], Polygon[CirclePoints[{2, 1}, 1/2, 6]]}; range = AbsoluteOptions[img, PlotRange][[1, 2]]; trans[{x_, y_}] :...


4

This answer is split from evolution of the question. In its core, it relies on BoundaryDiscretizeGraphics to create polygons defining holes (note, these may be inside each other), and properties of FilledCurve with polygons inside each other to perform the intended "filling of the outside." Parts of data given to FilledCurve intentionally extend outside ...


2

(All observations apply to version 10.1.0.) ErrorListPlot is written in as a rather straightforward post-processing of ListPlot, with error bar values first assigned to and then retrieved from a definition upon ErrorBarPlots`Private`error (hereafter notated error). A definition is made as a side-effect within a replacement rule: {x_?NumericQ, y_?NumericQ, ...


5

Here is a solution via Epilog and graphic primitive Rectangle[] Plot[{i, 4, 6}, {i, 0, 10}, Epilog -> {Opacity[0.3], Lighter@Red, Rectangle[{0, 0}, {10, 4}], Lighter@Blue, Rectangle[{0, 4}, {10, 6}]}]


27

I think you might be better off creating Graphics directly instead of using the StreamPlot style options. In this example I use StreamPlot just once and extract the coordinates of the arrows, which I use to create Line objects with VertexColors. The animation is made by cycling the vertex colors. plot = StreamPlot[{-1 - x^2 + y, 1 + x - y^2}, {x, -3, 3}, {y,...


6

Check out Plot for reference. Use {} to define multiple functions to be plotted and Filling for the shading. Plot[{i, 4, 6}, {i, 0, 10}, Filling -> {3 -> {2}, 2 -> Bottom}]


0

Since documentation for RegionPlot[] contains no examples nor synopses that describe how RegionPlot should be have on a region or a list of regions/Graphics primitives, I don't think one can say authoritatively that a list of disks is a nonstandard argument. RegionPlot[] does accept a list as a single region to be plotted, and it treats it in a reasonable ...


9

For fun Example DynamicModule[ {fill}, fill = .5; Panel @ Column[{ Slider[Dynamic @ fill, {0, 1}], Graphics[{ {FaceForm @ White, EdgeForm @ {Thick, Black}, Rectangle[{0, 0}]}, {FaceForm @ Black, Rectangle[{0, 0}, {1, Dynamic @ fill}]} }] }, Alignment -> Center] ] Output


10

Graphics[{EdgeForm[Thick], White, Rectangle[], Black, Rectangle[{0, 0}, {1, 0.5}]}] Or indeed, if you want to be able to change the filling dynamically, you can wrap a manipulate around it. Manipulate[ Graphics[{EdgeForm[Thick], White, Rectangle[], Black, Rectangle[{0, 0}, {1, a}]}], {a, 0, 1, 0.05}]


1

Here is another take on solving the problem which doesn't resort to Show. OuterPointList = {{0, 0}, {300, 0}, {300, 500}, {0, 500}}; RegionConcSect = Polygon[OuterPointList]; RebarList = {{{50, 50}, 16}, {{250, 50}, 24}, {{250, 400}, 24}, {{50, 400}, 24}, {{150, 300}, 24}}; RegionRebars = RegionUnion @@ Disk @@@ RebarList RegionPlot[ ...


6

The problem is due to confusion in RegionPlot, since you are providing it a nested list of regions, which is not really standard syntax. You could use Flatten@{RegionConcSect, RegionRebar} as its argument, or alternatively construct separate plots for each region, then combine them with Show. This also has the advantage of allowing you finer control on the ...


11

We can work in 2D and use RegionProduct to extrude into 3D. I've modified your code slightly: hCub = 1.5; W = 5; L = 8; CYLrad = W/20; shellthickness = CYLrad/6; deltah = hCub*0; pitch = 1; xnum = 5; ynum = 6; xinnercylnum = xnum - 2; xpitch = W/(xnum - 1); ypitch = xpitch*Sqrt[3.]/2; firstcylpos = {xpitch, ypitch, 0}; mr = DiscretizeRegion[ImplicitRegion[ ...


1

Here a two ways to save all your notebook graphics to PNG files : 1. Web page with PNG Graphics This is the quick and indirect way to do that and is actually what you tried. But as you said, by default the exported graphics in the folders are in the GIF format. To Export a notebook to a web page with all the graphics in PNG, this seems to work: Export["...


2

The plane, line and points are: eqplano = x + 2 y - 8; linha = Module[ { x = {-10, 10}, y, z }, Transpose[{x, y = 1 - x, z = 3 + 2 x}] ]; ponto1 = {x,y,z} /. Solve[{x + 2 y - z == 8, y == 1 - x, z == 3 + 2 x}, {x,y,z}]; ponto2 = {x,y,z} /. Solve[{x == 0, y == 1 - x, z == 3 + 2 x}, {x,y,z}]; The calculations that cause the plane to appear ...


1

You can also use Labeled and Overlay as follows (using @Jack's example): img = ImageResize[#, {100, 100}] & /@ ExampleData /@ ExampleData["TestImage"][[;; 8]]; img2 = MapAt[Overlay[{#, Style["*", 40, Red]}, Alignment -> Right] &, img, {{1}, {3}, {5}, {6}, {8}}]; Grid[Partition[MapIndexed[Labeled[#, Style[First@#2, 16], {{Top, Right}}] &, ...



Top 50 recent answers are included