Tag Info

New answers tagged

1

Well, I'm certainly not going to promise that the twisty tube is correct, but... r = 1/40; sides = ParametricPlot3D[{ {0, u, v}, {1, u, v}, {u, 1, v}, {u, 0, v} }, {u, 0, 1}, {v, 0, 1}, Mesh -> 7, PlotStyle -> Directive[Purple, Opacity[0.4]], MeshStyle -> Opacity[0.2], Boxed -> False, Axes -> False]; topBot = ...


4

Though I was expecting to need something fancy I stumbled upon a simple solution: ListLinePlot[data, PlotMarkers -> Graphics[{Disk[]}, ImageSize -> 13], PlotLegends -> Automatic ] The only change is enclosing Disk[] in { }. Looking at the InputForm we see that expressions involving Disk have been changed to e.g.: Graphics[{ Hue[0.67, ...


4

You have somehow to segment your data. Here you could use the radius + FindClusters: radius = 14.6; data1 = FindClusters[Select[data, Norm[#] > radius &], 2,Method -> "Agglomerate"]; Show[ ListPlot[data1, PlotRange -> Full, AspectRatio -> 1, PlotStyle -> {Green, Red}], ListPlot[Select[data, Norm[#] < radius ...


3

ints[l1_, l2_] := Module[{rg, x, y, res}, rg = RegionIntersection[l1, l2]; res = {x, y} /. ToRules[Reduce[RegionMember[rg, {x, y}]]]; If[And @@ (NumericQ /@ res), res = res, res = Sequence[]]; res]; pair[dat_] := Subsets[dat, {2}] As the lines have already been paired: li01 = Graphics[{{Hue[RandomReal[]], Thick, #} & /@ lines, {Red, ...


9

If you know all pairs of line segments intersect, then the following is about four times faster than using DiscretizeRegion: points = (Point[{x, y}] /. Solve[{x, y} ∈ #, {x, y}] & /@ RegionIntersection @@@ lines); // AbsoluteTiming // First Graphics[{lines, {Red, PointSize@0.02, points}}, Frame -> True] (* 0.040551 *) Bug? [Tested on beta ...


6

With Mathematica 10 you can use: ps[{l1_, l2_}] := Solve[p ∈ l1 ∧ p ∈ l2, p] and then points2 = Point[p] /. Map[ps[#] &, lines] // Flatten For a large number of lines ParallelMap should give an additional speedup.


1

Your example prints the text with "as it is" with no background. Compare with Graphics[{Thick, Yellow, Disk[{0, 1}], Text[Style["abcdeffsgg", 16, Black, Background -> Red], {0.85, 0.65}]}] To let the text disappear you can use Graphics[{Thick, Yellow, Disk[{0, 1}], Text[Style["abcdeffsgg", 16, Black, Transparent], {0.85, 0.65}]}] Instead of ...


0

Just change the value of LegendMarkerSize to the size that you want. Look more into PlotLegends and SwatchLegend in the documentation. Plot[Sin[x], {x, 0, 10}, Filling -> Axis, FillingStyle -> {Red, Blue}, PlotLegends -> SwatchLegend[{Blue, Red}, {"Sin(x) > 0", "Sin(x) < 0"}, LegendMarkers -> Graphics[Disk[]], LegendMarkerSize ...


2

You can use Export[] when you cannot select outputs in the Front End. Overlay[{p1, Item[Show[p2], Alignment -> {-.7, .6}]}] Export["graphics.pdf",%] saves the graphics as PDF in your current working directory. No rasterization happens. This technique can also be used for output of GraphicsRow, GraphicsColumn, and GraphicsGrid where you cannot select ...


4

Although Overlay preserves unrasterized copies of its constituent Graphics it is rasterized by the Front End for the purpose of display. Therefore I do not believe that you can use Overlay for this purpose. However, I believe you can use Epilog and Inset: p1 = Plot[Sinc[x], {x, 0, 10}]; p2 = BarChart[{{1, 2, 3}, {1, 3, 2}}]; Show[p1, ImageSize -> ...


2

I am still largely mystified by Dataset as database querying is alien to me and the Dataset internals seem rather opaque, but at least for the given example this appears to be a solution: titanic = ExampleData[{"Dataset", "Titanic"}]; panel = titanic[GroupBy[Key["sex"]], GroupBy[Key["class"]], Counts /* KeySort /* (PieChart[#, SectorOrigin -> ...


0

Answer to "Is there an option for a single legend to appear, outside the frame of the Dataset?" res = titanic[GroupBy[Key["sex"]], GroupBy[Key["class"]], Counts /* KeySort /* (PieChart[#, SectorOrigin -> {Automatic, 1}] &), "survived"]; sw = SwatchLegend[{Lighter@Blue, Orange}, {True, False}]; Row[{res, Spacer@10, sw}]


4

This is in theory pretty simple. Think of it as two separated steps. First, you need function that models your extrusion-thickness, which has in the middle always the same value and at both ends it should round up like a circle. You can do this with Piecewise or, as I show here, with a combination of Heaviside functions: thicknessFunc[z_, body_] := ...


1

How about this. Generate a list of 2D points: pts = Table[{Cos[2 \[Pi] k/6], Sin[2 \[Pi] k/6]}, {k, 0, 6}]; ListLinePlot[pts] and we'll use a scaling function to form the caps. Plot[Sqrt[1 - (Abs@z - 1)^2], {z, -1, 1}, AspectRatio -> 1] sfunc[pt_] := Module[{z = Last@pt}, Piecewise[{{pt, -1 < Last@pt < 1}}, {{Sqrt[1 - (Abs@z - 1)^2], ...


1

Here I figured out a rough, primitive solution to get the work done, still looking forward a smarter solution. labels = {"00", "01", "11", "10"}; lab = {"0", "1"}; Clear[a, b, c, x, y, A, B]; elem = {{! a && ! b && ! c, ! a && ! b && c}, {! a && b && ! c, ! a && b && c}, {a && b ...


3

An alternative to manually setting line breaks is to set a label size and then let the label break as needed: Plot[Cos[2 x], {x, -Pi, Pi}, Frame -> True, FrameLabel -> {{Pane["This is a y frame label", {50, All}], None}, {Pane["This is an x frame label", {50, All}], None}}]


9

Try this: Plot[Sin[2 x], {x, -Pi, Pi}, AxesLabel -> {"This is\n an axes label", None}] And here's the same using FrameLabel instead of AxesLabel. Plot[Cos[2 x], {x, -Pi, Pi}, Frame -> True, FrameLabel -> {{"This is\n a y frame label",None}, {"This is\n an x frame label", None}}] This is covered in the documentation under Newlines ...


14

The kite-domino tiling is based the pinwheel tiling which is falls out of a particular decomposition of a right triangle with legs of length 1 and 2. In the code that follows, rt[{a,b,c}] represents such a right triangle and dissect indicates how such a triangle should be decomposed into smaller copies of itself. We simply iterate the dissect function on ...


2

Manipulate[arrX = ConstantArray[0, {2, 4}]; EventHandler[Dynamic[mat = Reverse[Transpose[arrX]]; Show[frame, MatrixPlot[mat, Mesh -> All, ImageSize -> {100, 200}, PlotRangePadding -> 0, FrameTicks -> None, ColorRules -> {1 -> None, 0 -> None}], Epilog -> ...


1

Here is a workaround for this I've been using: p2 = Graphics3D@First@ParametricPlot3D[{Cos[t], Sin[u], Sin[t]}, {u, 0, 2 Pi}, {t, 0, 2 Pi}] Now we discretize: DiscretizeGraphics[Normal[p2 /. (Lighting -> _) :> Lighting -> Automatic]]


4

EDIT As Mr Wizard observed my original code is not self contained. For reasons that I fail to understand this seemed to work with what seemed a fresh session. The code works if you move the gauge marker but to post correct code (I leave the animated gif as it is the same outcome): DynamicModule[{s = 0}, Framed[Row[{VerticalGauge[Dynamic[s], {0, 1}, ...


1

You should prepend to the code of your question << "LevelScheme"` However, this doesn't open with my version of MMA (10.0) As an alternative one could use a = ListPlot[Table[{.1 x, Sinc[.1 x]}, {x, Range@200}], Frame -> True, PlotRange -> {{0, 10}, {0, 1}}, Joined -> False, AspectRatio -> 1.5, PlotLegends -> ...


1

The problem is with your ImageSize->Full option. Try leaving it out or specify your ImageSize to a certain size (e.g. 500) instead of Full. otherOptions = {MaxPlotPoints -> 1000, ColorFunction -> "ThermometerColors", PlotLabel -> Style["Array Plot of Raw Data", 11, Bold, Black], PlotRangePadding -> 0., ImageSize -> Full, ...


0

Here's a bitwise approach, using a two-argument definition like @m_goldberg: xor[str1_String, str2_String] := IntegerString[ BitXor[FromDigits[str1, 2], FromDigits[str2, 2]], 2, StringLength[str1]]; The other functions could be implemented with bitwise operators, too.


1

Perhaps xor[ab : {a_String /; StringFreeQ[a, Except["0" | "1"]], b_String /; StringFreeQ[b, Except["0" | "1"]]}] := StringJoin[ MapThread[Xor, Characters[ab] /. {"0" -> False, "1" -> True}] /. {False -> "0", True -> "1"}] Since xor is limited to two strings in the list it will be convenient to support this form: ...


0

I think it would be simpler to implement the logic directly, with fewer transformations: str2={"11000000","10000001","11111111"}; do[f_]:=StringJoin[ToString/@Boole@MapThread[f,StringSplit[#,""]]]&; not=StringReplace[#,{"1"->"0","0"->"1"}]&; not@str2[[1]] "00111111" or=do[!FreeQ[{##},"1"]&]; or@str2 "11111111" ...


1

First, a small change in your function fun to allow options: funB[str : {__String}, opts : OptionsPattern[]] := Module[{fs, n, timd}, fs = Riffle[#, #]~Append~Last[#] & /@ ToExpression@Characters@str; n = Length@First@fs; timd = Reverse@fs~Append~PadLeft[{0}, n, {0, 1}]; ListLinePlot[MapIndexed[#1 + 2 First@#2 - 2 &, timd], ...


3

For the first question the problem is only in the radius of the small circle. it should be like this: Circle[center[{R, r}, θ], r]


2

I'm not going to do the red lines and the numbers but here's a way to generate the coordinates of the horizontal and vertical lines that make up the graphs and to draw these: drawGraph[str_, width_, height_] := Module[{values, vertical, horizontal}, values = Join[{First@#}, #, {Last@#}] &[ToExpression /@ Characters@str]; vertical = MapIndexed[ ...


6

Edit I found this a very interesting question, and I developed a solution at the Graphics level rather that the Plot level. My implementation approach is classic divide-and-conquer, building up the main function from a number of small ones. This made development straightforward, but also makes the code rather long for answers posted on this site. Component ...


9

In the end this is a bug and I filed that. Now, what is going on: If you extract the coords and polygons from the GraphicsComplex and try to set up a MeshRegion you get a warning: gc = First@ ParametricPlot3D[{Cos[t], Sin[u], Sin[t]}, {u, 0, 2 Pi}, {t, 0, 2 Pi}]; ply = Cases[(gc)[[2]], _Polygon, Infinity] MeshRegion[gc[[1]], ply] ...


3

In version 10.0.0 the PlotStyle -> Thickness method shown by cormullion does not appear to work. Instead we can use the undocumented Extrusion option: ContourPlot3D[x y z == 0.05, {x, -1, 1}, {y, -1, 1}, {z, -1, 1}, Extrusion -> 0.1]


3

As shown by the graphic, the Log is applied on the y-axis, thus you need to apply Log to the y coordinate of your point: LogPlot[Sin[x], {x, 0, π}, Epilog -> {Text["x", {π/2, Log@0.2}]}] For completeness purposes as suggested by rcollyer: LogLinearPlot[Tanh[x], {x, 1, 100}, Epilog -> {Text["x", {Log@10, 0.98}]}] LogLogPlot[ Sum[i/(x^2 - 2 i ...


6

A working way to use Directive: ContourPlot[Cos[x] + Cos[y], {x, 0, 4 Pi}, {y, 0, 4 Pi}, ContourShading -> False, ContourStyle -> Array[Directive[Thick, ColorData[10]@#] &, 10] ] Changing thickness along with color: ContourPlot[Cos[x] + Cos[y], {x, 0, 4 Pi}, {y, 0, 4 Pi}, ContourShading -> False, ContourStyle -> ...


6

You could use BaseStyle to set the Thick lines: ContourPlot[x y, {x, -1, 1}, {y, -1, 1}, ContourShading -> False, ContourStyle -> ColorData[10] /@ Range[10], BaseStyle -> Thick] Alternatively you could Thread Directive over the colour list: ContourStyle -> Thread @ Directive[Thick, ColorData[10] /@ Range[10]] which will give the same ...


0

Use Directive ContourPlot[x+y,{x,-1,1},{y,-1,1},ContourShading->False,Contours->Range[1,10],ContourStyle->Directive[Thick,Red]]


6

Perhaps (as per rm-rf): str = {11011011, 11100110} sig = {#1, #2 + 1.5} & @@ ((IntegerDigits /@ str) /. {1 -> Sequence[1, 1], 0 -> Sequence[0, 0]}); clock = Join @@ Table[{4, 3}, {Length[First@sig]/2}]; plt = ListLinePlot[Join[sig, {clock}], InterpolationOrder -> 0, PlotRange -> {{0, 17}, Automatic}, FrameTicks -> ...


0

How is this? Slider[Dynamic[n, (imgs = Automatic; n = #) &], {0, 5}] imgs = 400; Dynamic[Plot[n (x - n)^2, {x, 0, 5}, ImageSize -> imgs]]


0

Is this what you are looking for? Manipulate[ Plot[n (x - n)^2, {x, 0, 5}, ImageSize -> $size], {n, 0, 1}, {{$size, 550}, 100, 1000}] On my system, Large ~ 550, so I chose that as the starting point.


1

Edit: In order to set initial values in a dynamical system one has to use DynamicModule. Anyway, if you now change slightly your code in the following way: Slider[Dynamic[n], {0, 5}] DynamicModule[{p1 = 200}, Dynamic[Plot[n (x - n)^2, {x, 0, 5}, ImageSize -> Dynamic[p1]]]] the image should remember its size.


8

You can use: HighlightMesh[DiscretizeGraphics[SSSTriangle[3, 4, 5]], Labeled[1, "Index"]] Or, HighlightMesh[ DiscretizeGraphics[SSSTriangle[3, 4, 5]], {Labeled[{1, 1}, 5], Labeled[{1, 2}, 3], Labeled[{1, 3}, 4]}] to get:


4

Kguler solution is much nicer, but here is my attempt. I solve the equation of lines to find the coordinate needed, then superimpose SSSTriangle with Graph using EdgeLabels where the length is put as the Label. Can be made shorter and more functional. The manual part of mapping edges to labels below can be automated more if needed. len = {3, 4, 5}; g = ...


5

coords=Sequence@@(SSSTriangle[3,4,5]); i=1; Graphics[{Yellow, EdgeForm[Black], SSSTriangle[3,4,5], Black, (Inset[Panel[Style[i++,16]],#]&/@Mean/@Transpose[{coords,RotateRight@coords}])}] or CycleGraph[3, VertexCoordinates -> SSSTriangle[3,4,5][[1]], EdgeLabels->{1<->2 ->Panel[1],1<->3 ->Panel[2],2<->3 ...


3

ParametricPlot[ {Re@Sin[u + I v], Im@Sin[u + I v]}, {u, -Pi/2, Pi/2}, {v, -Pi/2, Pi/2}, ColorFunction -> (ColorData["TemperatureMap"][Abs[2 #3/Pi]] &), ColorFunctionScaling -> False, ImagePadding -> 20, ImageSize -> 400, PlotPoints -> 30, Mesh -> Automatic] ParametricPlot[ {Re@Sin[u + I v], Im@Sin[u + I v]}, {u, -Pi/2, ...


2

You could do ParametricPlot[ {Re@Sin[u + I v], Im@Sin[u + I v]}, {u, -Pi/2, Pi/2}, {v, -Pi/2, Pi/2}, ColorFunction -> (ColorData["DarkRainbow"][If[#3 < .5, 1 - #3, #3]] &), ImagePadding -> 20, ImageSize -> 400, PlotPoints -> 30]


22

It is natural to expect that the triangle marker is placed in such a way that its center of mass (center of circumcircle) coincides with the point it marks. That's how it is implemented in all major scientific plotting software, for example Origin: Some time ago I published my own implementation of triangle-based plot markers. Let us check how the new ...


1

Version 10 supports graphs with mixed directed and undirected edges. g = CayleyGraph[DihedralGroup[4]] newEdges = Flatten[ GatherBy[EdgeList[g], Sort] /. {{a_ \[DirectedEdge] b_, _} :> {a <-> b}} ] e = GroupBy[newEdges, Head] g2 = Graph[newEdges, EdgeStyle -> Catenate[Thread /@ {e[UndirectedEdge] -> Red, e[DirectedEdge] -> Blue}]] ...


1

Try this: Show[{ LogLogPlot[x^4, {x, 10^(-10), 10^10}, PlotStyle -> Red], LogLogPlot[x^5, {x, 10^(-10), 10^10}, PlotStyle -> Blue], ParametricPlot[{Log[0.01], Log[y]}, {y, 10^-26, 10^30}, PlotStyle -> Darker@Green] }]


6

I can reproduce the problem described by OP in Mathematica 9.0.1 on Windows 8.1. By using FrontEnd`UndocumentedBoxInformationPacket to check the displayed Boxes' layout in the FrontEnd, I wildly guess that the cause of the problem might be hiding in the FrontEnd layout engine (of only the Windows version maybe?). If it's true, then there might be nothing we ...


3

What if you made a number spiral similar to the prime spiral of Stanislaw Ulam? This transforms the 1D distribution of Hamming numbers into a 2D distribution. Note that kSmoothSpiral generalizes to any k-smooth number. NumberSpiral[n_Integer] := Block[{m = Floor[N[Sqrt[n]]]}, If[ EvenQ[Floor[2.0*Sqrt[n]]], {(-1)^m*((n - m*(m + 1)) ...



Top 50 recent answers are included