Tag Info

New answers tagged

4

The following works for your curve: points = {{1, 4}, {.5, 6}, {5, 4}, {3, 12}, {11, 14}, {8, 4}, {12, 3}, {11, 9}, {15, 10}, {17, 8}}; deg = 3; pointsCLOSE1 = Join[points, points]; n = Length@pointsCLOSE1; knotsCLOSE1 = Range[0, 1, 1/(n + 1)]; ParametricPlot[deBoor[pointsCLOSE1, {deg, knotsCLOSE1}, t], {t, deg/(n + 1), 1}, Axes ...


1

Here are the modifications that need to be done on your plots h1 and h2 in order to flip them over the line y == x. If you look "under the hood" at the structure of these two plots by executing, for instance, FullForm@Normal@h1 you find that really there are only two objects, a Line and a Polygon. Both of these Heads take inputs which are lists of {x, y} ...


1

It turned out that for some reason the image got re-sized to a slightly different pixel width and height. Fixing the width explicitly to the original value removed the artifacts: Gimg1 = Graphics[Inset[img1, {0, 0}, {199.5, 141.5}, 400], PlotRange -> {{-199.5, 199.5}, {-141.5, 141.5}}, ImageSize -> 400]; Gimg2 = Graphics[Inset[img2, {0, 0}, {199.5, ...


14

data = Import["orbit3d.out", "Table"]; (* Your Table is not needed; you can use [[...]] instead *) (*d=Table[{data[[i,2]],data[[i,3]],data[[i,4]]},{i,1,Length[data]}];*) d = data[[All, 2 ;; 4]]; l = Line[d]; (* Projections on bounding box *) lz = l /. {x_, y_, z_} -> {x, y, -5.5}; ly = l /. {x_, y_, z_} -> {x, 5.5, z}; lx = l /. {x_, y_, z_} -> ...


1

I've stumbled a workaround by specifying a "direction vector" through the Text function instead of through Rotate: Show[Plot[x, {x, 0, 1}], Graphics[{Text["test", {0.5, 0.5}, Automatic, {1, 0.5}]}]] Export["~/tmp.pdf", %]


2

Manipulate[{ m = {{a, b}, {c, d}}; Column[{r = Thread[m.{x, y} == {f, g}], s = LinearSolve[m, {f, g}]}], ContourPlot[Evaluate@r, {x, -5, 5}, {y, -5, 5}, PlotLabel -> s]}, {{b, 3}, 0, 3}]


1

Here is an approach using Annulus. In this approach element {1,1} starts from horizontal axis and I have not adapted but to start of vertical axis downward but this could be adapted. The ticks have been made to match example and I use m from @Taiki answer. Coloring could be modified and generalized as required. elem[r_, t_, m_, col_] := If[r > 1, {col, ...


4

Using the sector[] function from here (replaceable with Annulus in version 10.2), we can generate a plot that looks like, but is smoother, than the result of MATLAB's pcolor(): n = 20; r = N[Range[0, n]/n]; θ = N[π Range[-n, n]/n]; m = Table[r1 Cos[2 θ1], {r1, r}, {θ1, θ}]; jet[u_?NumericQ] := Blend[{{0, RGBColor[0, 0, 9/16]}, {1/9, Blue}, {23/63, Cyan}, ...


3

Expanding on comment from Guess who it is, I think he pretty much had it nailed but instead of mapping onto pts I believe you need to use Range[Length[pts]]. GraphicsComplex will use the point number to indicate the position of the graphic object. With[ { pts = {{1, -1, 1}, {0, 0, 0}, {1, 1, 1}, {0, 0, 2}, {-1, 0, 1}} }, Graphics3D[{ Opacity[0.5], ...


7

I consider this question pretty much answered by @MarcoB, as follows: Mathematica 10 apparently forces rasterization by default when exporting 3D graphics to PDF, even when one adds the option "AllowRasterization" -> False to Export. The only way to disable it is to use the Inset workaround suggested by Jens: Export["PDFTestExport.pdf", ...


6

There seem to be a few problems, first, country data returns Quantities, so strip those off. cDat = (QuantityMagnitude /@ {CountryData[#1, "BirthRateFraction"], CountryData[#1, "AnnualDeaths"], CountryData[#1, "GDP"]} &) /@ CountryData["Countries"]; Then you need to get rid of all the Missing[NotAvailable] entries. cDat = Cases[cDat, ...


4

Another trick you can do: Graph[Join[Table[1 -> 2, {10}], Table[2 -> 3, {5}], Table[3 -> 1, {5}]], EdgeShapeFunction -> {1 \[DirectedEdge] 2 -> (a = 0; {a++; ColorData[35, "ColorList"][[a]], Arrow[#]} &), 2 \[DirectedEdge] 3 -> (b = 0; {b++; ColorData[55, "ColorList"][[b]], Arrow[#]} &), 3 ...


2

The trick is to render both a directed and an undirected edge with the same arrow EdgeShapeFunction. Alas, the full graph representation will retain the different classes of edge, so functions such as FindKClan, VertexOutDegree, VertexInDegree, and others that distinguish between different classes of edge will give incorrect answers. Graph[{1, 2}, ...


4

Filling is not an option for Graphics, One approach is to use a PieChart as a background. angles[t_] := Module[{o = {0, 0}, p = {Cos[t], Sin[t]}, rot}, rot = If[TrueQ[Pi/2 < Mod[t, 2 Pi] < 3 Pi/2], t + Pi, t]; {{Opacity[0.3], Line[{o, p}]}, Rotate[Inset[Style[Row[{t}], FontSize -> 18], p/2], rot]}]; ang = {52, 0, 220, 180, 132, 282, ...


4

I think using circular sectors generated with Disk may be easier: SeedRandom[3] Clear[sector, angles] sector[color_, angle_List] := {color, Disk[{0, 0}, .995, {angle[[1]], angle[[2]]} Degree]} angles[t_] := Module[ {o = {0, 0}, p = {Cos[t], Sin[t]}, rot}, rot = If[TrueQ[Pi/2 < Mod[t, 2 Pi] < 3 Pi/2], t + Pi, t]; {{Opacity[0.3], Line[{o, p}]}, ...


5

I thought I would show you what I meant in my comment, together with the end product of my proposed modification, so you can decide if that's acceptable for your application. I am using all your definitions from the original questions. I calculated the path as a Line object generated from a series of points calculated by your outputAngle function over the ...


4

You need a region of dimension 3: t = 1; VectorPlot3D[{x, y Cosh[t] + z Sinh[t], y Sinh[t] + z Cosh[t]}, {x, -5, 5}, {y, -5, 5}, {z, 0, 5}, RegionFunction -> (( #1^2 + #2^2 - #3^2 < -1) &)] Or you could try something more "manual" to capture the vectors on your region of interest only : field[x_, y_, z_, t_] := {x, y Cosh[t] + z Sinh[t], ...


4

Although I strongly suggest you just create and use your own formatting function if possible, e.g. form[Red], the question of modifying the internal behavior is interesting. You can either turn off the automatic color directive formatting and define your own MakeBoxes rules on e.g. RGBColor to take its place, or you can modify the internal function used to ...


2

Just as a complementary and extended comment and as was recently observed in a related post, you get exactly the same problem if, not surprisingly, you use geometric transformation functions instead: Given the initial object to transform: circles = {Circle[{0, 0}, 1], Circle[{0, 0.5}, 0.5]}; the OP transformation: t1 = Rotate[Scale[circles, 12], -45 ...


4

You will really need to roll your own color bar, which isn't too difficult. Here is an example of making a highly customized color bar. With[{n = 24}, Graphics[ Table[{Hue[i/n], Translate[Rectangle[{0, 0}, {1, 1}], {i, 0}]}, {i, 0, n - 1}], ImageSize -> 550, PlotRangePadding -> None, AspectRatio -> 3/n, Frame -> True, FrameTicks ...


1

You should be able to use the code here: Making Formulas… for Everything—From Pi to the Pink Panther to Sir Isaac Newton See the function, pointsListToLines, a third of the way down the page. Here is a copy of the code from the CDF: pointListToLines[pointList_, neighborhoodSize_: 6] := Module[{L = DeleteDuplicates[pointList], NF, \[Lambda], lineBag, ...


2

I think your problem is that you have coordinates that have been projected onto a cartesian system, I'm guessing a US state-plane system. Mathematica can deal with these, you just have to tell it what it's looking at. So suppose these are from NY, in the eastern section. Then test2 = test /. coords : {__?NumberQ} :> GeoPosition @ GeoGridPosition[coords, ...


4

tr[x_] :=Abs[TriangleWave[x 2^-(Floor[Log[2, 1 - x]] + 1)]/(Floor[Log[2, 1 - x]])] Visualizing: Plot[tr[x], {x, 0, 1}, GridLines -> {1 - PowerRange[1/2, 1/128, 1/2], Table[1/j, {j, 7}]}, Frame -> True]


5

Untested Just tested: With[{n = 20}, Plot[Sum[UnitTriangle[(x - 1) 2^(k + 1) + 3]/k, {k, n}], {x, 0, 1}]] Here is a solution that is entirely equivalent to ubpdqn's: Plot[Abs[TriangleWave[#1]/(#2 - 1)] & @@ MantissaExponent[1 - x, 2], {x, 0, 1}]


3

Actually there is nothing much wrong with your approach. You generate the coordinates for vertices you want to plot, but that's not enough. Graphics requires graphic primitives such as Line (the one to use in this case), so you need to wrap your coordinates in that primitive. pts[max_Integer?EvenQ] := Table[ {Boole[Mod[i, 2] == 0]*(1 - 2^(-i/2)) + ...


8

GeometricTransformation is an efficient graphics tool for drawing many affine transforms of a figure. Graphics[{ LightGray, EdgeForm[Lighter@Blue], GeometricTransformation[ Polygon[{{0, 0}, {1/2, 0}, {1/4, 1}}], ScalingTransform[{2^(1 - #), 1/#}, {1, 0}] & /@ Range[100] ]}, Frame -> True ]


9

Another approach would be to consider the triangles as graphics primitives. The first triangle would be constructed manually with Triangle[{{0, 0}, {1/4, 1}, {1/2, 0}}] and each other triangle would be constructed by translating and scaling properly the first triangle. A set of triangles would be obtained with myTriangles[number_] := NestList[ {Scale[ ...


0

It seems needlessly complex to write If[Boole[IntegerQ[x/10000]] == 0, N[x/10000], IntegerPart[x/10000] when If[IntegerQ[x/10000], IntegerPart[x/10000], N[x/10000] ] would do. (Notice that the arguments are reversed because you are now checking if IntegerQ is true, not false.) I do not have the customticks package, but I suspect your problem is that ...


5

heights = Table[1/(k 2^(k + 1)), {k, 1, 15}]; widthpositions = Partition[Accumulate@Prepend[NestList[#/2 &, 1/2, 14], 0], 2, 1]; Plot[MapThread[#1 PDF[TriangularDistribution[#2], x] &, {heights, widthpositions}], {x, 0, 1}, Filling -> Axis]


6

Here is another couple of takes on the same problem. Both attempts construct a list of base points (in red in the plot below), and a separate list of apex points (in blue), then they Riffle the two lists together to get a list of points to plot with ListPlot. The first approach uses MovingAverage to determine the $x$ position of the apex points: nmax = 10; ...


5

g[n_] := Sum[1/2^i, {i, 1, n}]; f[n_] := (- 1/2^(n + 1) + g[n] ) t1 = Table[{f[n], 1/n}, {n, 1, 20}]; t2 = Table[{g[n], 0}, {n, 0, 20}]; t3 = Sort[Union[t1, t2]] ListPlot[t3, Joined -> True, Filling -> Axis, PlotRange -> All] You can try also with your code: linelist = Table[{Boole[Mod[i, 2] == 0]*(1 - 2^(-i/2)) + Boole[Mod[i, 2] == 1]*(1 ...


8

num=100 p = Partition[Accumulate@Prepend[NestList[#/2 &, 1/2, num - 1], 0], 2,1]; ListLinePlot[Join @@ MapThread[{{#1[[1]], 0}, {Mean[#1], #2}, {#1[[2]], 0}} &, {p, 1/Range@Length@p}], PlotRange -> All]


4

Your lat/long data pairs look like {523679., 632989.} which appear to be in some form of DMS form (ddmmss., ddmmss.}. However, I believe that these are being interpreted as decimal degrees. Converting to decimal degrees (simplified conversion used assuming longitude is even number of digits consistent with your data): data = test /. x_?NumericQ :> ...


2

The answers received made me cogitate a lot these last two days and I came up with a solution based on Riffle: All the graphics directives are stored in a table, each entry in that table corresponding to a path of the figure drawn . These paths are in a table supplied to the unique built-in drawing the figure (ie Line, Polygon....) here BezierCurve. The ...


1

If I understand correctly, you are looking for a weighted average. Something like this, where a value of 10 is the best value possible rating =.7 (10 - y) + .3 x; You can then plot it to see how "good" different (x,y) values are: Plot3D[.7 (10 - y) + .3 x, {x, 0, 10}, {y, 0, 10}, ColorFunction -> Hue]


1

You can use the Text graphics primitive to place a ScientificForm expression anywhere in a graphics pane without resorting to string conversion. For example, Graphics[{ Circle[], Text[Style[ScientificForm[N[Pi 1*^10], 8], 14, Bold, Red], Scaled @ {.5, .9}]}] produces I didn't bother to introduce Epilog here, but Text expression like this one are ...


3

Borrowing from @march's answer (and non-CelluarAutomaton)... pos = Subsets[{2, 4, 5, 6, 8}] /. x_Integer :> {x}; list = (Partition[#, 3] & /@ (ReplacePart[ConstantArray[0, 9], 1, #] & /@ pos)); GraphicsRow[ Framed[ArrayPlot[#, Frame -> False, Axes -> False, Epilog -> {Line[{{1, 0}, {1, 3}, {2, 3}, {2, 0}, {1, 0}}], Line[{{0, 1}, ...


4

If you generate a list of 9-element lists of 0's and 1's using CellularAutomaton, then you can do the following: GraphicsRow[ Framed[ ArrayPlot[ # , Frame -> False , Axes -> False ] ] & /@ list ] For instance, if list = CellularAutomaton[30, {0, 1, 0, 1, 1, 1, 0, 1, 0}, 5]; then the code above generates You ...


2

You can use something like {Black, Text[Style[vn, 16, Bold], {x + .3 Cos[(θ0 + θ1)/2], y + .3 Sin[(θ0 + θ1)/2]}]}} to print vn in font Bold with fontsize 16, located near $(x,y)$, at distance $0.3$ in direction $(\theta_0+\theta_1)/2$. For instance: EVDisk[vec_, vn_, x_, y_, θ0_, θ1_] := Graphics[{Which[Sign[vec[[vn]]] == 1, RGBColor[228/255, ...


7

Similar comments on recursion. The expression you create looks like this: TreeForm[orig, VertexLabeling -> None] Building it, e.g., like this gives you a flat structure: new = Table[ Rotate[ Line[AnglePath[{{-0.7, -0.7}, (-Pi/6)}, {{2, (7 \[Pi])/8}, {2, \[Pi]/8}, {2, (7 \[Pi])/8}, {2, \[Pi]/8}}]], i*Pi/5, {0, 0}], {i, 10}]; Such ...


4

In your examples you choose one color to begin with and then you pass that color onwards to each of the following leaves through recursion. Just like you have to apply Rotate in each step to change the angle, you also have to apply an operator that changes the color. For example: next[{_, leaf_}] := {RandomColor[], Rotate[leaf, Pi/5, {0, 0}]} g1 = ...


7

Since there is really something wrong with the BezierCurve, I made this work-around: Clear[bezierCurve]; bezierCurve[pts_] := First@ParametricPlot[ BezierFunction[pts, SplineDegree -> Length[pts] - 1][t], {t, 0, 1}] Manipulate[ Graphics[{bezierCurve[pts], Dashed, Green, Line[pts]}, PlotRange -> {{-.5, 1.5}, {-.5, 1.5}}, Frame -> ...


2

This is not an answer, but an extended comment on @beliarius's answer which I much admire. Notwithstanding my admiration, I have some nits to pick. The simulation should be parameterized by the number of steps to run, the number of dice, and the delay between histograms. oneCycle should not flatten news twice. For a million steps, as proposed by the OP, ...


2

(* First we calc the ways to add up n with two dice *) alts[x_] := Union[Join @@ Map[{#, Reverse@#} &, IntegerPartitions[x, {2}, Range@6]]] ways = alts /@ Range[1, 12]; (* an initial dice config *) m1 = RandomVariate[DiscreteUniformDistribution[{1, 6}], 300]; (* the "collision result" function*) oneCycle[m1_] := Module[{p1, s1, news}, (* form the ...


6

Here is some code I used, which may partially answer your question. The key is to calculate efficiently points near the border of the Mandelbrot set. These points have large iteration counts which, when iterated, produce the Buddhabrot form. The algorithm linked to in the question uses an adaptive mesh of squares to locate border points. The alternate code ...


9

The main issue is simply that your constraint should not be imposed after the integration of the field lines, but beforehand. This means that we should choose the starting points from which the differential equations of the field lines are integrated to lie on the desired cylinder right from the beginning. Then, all you have to do is to impose the ...


2

I found the solution. Here is the source code: (* Create the Euler rotation matrix *) yawRotationInv = RotationTransform[\[Psi], {0, 0, 1}]; pitchRotationInv = RotationTransform[\[Theta], {0, 1, 0}]; rollRotationInv = RotationTransform[\[Phi], {1, 0, 0}]; EulerRotate[\[Phi]_, \[Theta]_, \[Psi]_] = Composition[yawRotationInv, pitchRotationInv, ...


2

Taking into account the new information from your edit, I propose the following: Function to produce the edge labels according to multiplicity indicated in the adjacency matrix. edgeLbl[multipliciy_] := Style[StringJoin @ ConstantArray["+", multipliciy], Background -> White] Function to style the edges according to multiplicity. ...


1

Something like ListPlot3D just that I want it to show those cuboids. If you need to place the same shape at multiple points either in 2D or 3D, the best solution is Translate. It can take more than one translation vector as the second argument. Example: pts = RandomReal[10, {20, 3}]; Graphics3D[ Translate[ Cuboid[], pts ] ]


4

Its difficult to work with your question since you don't define your functions and variables but hopefully this example will be enough. Let's first make a table of cuboids with different z values (but using the same z-value within each cuboid so they are still rectangles). This examples uses the same x and y values for every Cuboid for simplicity, but you ...



Top 50 recent answers are included