Tag Info

New answers tagged

3

First, create a matrix for shape positions: a = ArrayPad[ ArrayPad[DiamondMatrix[2], 1] + DiamondMatrix[3], {{1, 1}, {3, 2}}] Then, apply geometric transformations to appropriate positions. Graphics[{LightGray, MapIndexed[Which[ #1 == 0, Scale[Rectangle[#2, #2 + 1], .8], #1 == 2, GeometricTransformation[ ...


3

According to documentation Epilog is applied after Axes even with Method->"AxesInFront" (and it seems after GridLines too) so you can use it to set layers as you need: Plot[Sin[x], {x, -1, 1}, GridLines -> {{0}, {0}}, Frame -> True, Axes -> False, GridLinesStyle -> Directive[Red, AbsoluteThickness@9], ...


1

PrettyPoint /: MakeBoxes[PrettyPoint[e___], TraditionalForm] := With[{mb = MakeBoxes[#, TraditionalForm] & /@ {e}}, RowBox[{"(", Sequence @@ Riffle[mb, ","], ")"}] ] PrettyPoint[Log[x/y], Log[1 + y/x]] // TraditionalForm


0

ToString[{Log[x/y], Log[1 + y/x]}, TraditionalForm]


1

MatrixForm[{Log[x/y], ",", Log[1 + y/x]}, TableDirections->Row, TableSpacing->0.3] // TraditionalForm The spacing around the comma is not perfect but the parentheses look good.


2

There are couple other ways to visualize 3D images, one of which is new in V10. (Note: The links to the original data are no longer valid.) The new features, ClipPlanes and IntervalSlider, are useful here. Something like this was demonstrated at WTC 2014. knee = Raster3D[ RawArray["Byte", ImageData[ExampleData[{"TestImage3D", "MRknee"}], ...


8

You could use an image representation of the plot and map it onto the modified cylinder that I defined in the answer linked here. Just copy the definition of cyl from that answer, which includes the ability to add textures as follows: img = Image@StreamPlot[{y, -Sin[x]}, {x, -5, 5}, {y, -3, 3}, Frame -> None, PlotRange -> {{-5, 5}, {-3, 3}}, ...


11

plot = StreamPlot[{y, -Sin[x]}, {x, -Pi, Pi}, {y, -3, 3}, Frame -> None, Epilog -> {PointSize -> Large, Point[{{0, 0}, {π, 0}, {-π, 0}}]}, StreamPoints -> Fine, AspectRatio -> 0.8] Try this: First[Normal@plot] /. a_Arrow :> ( a /. {x_Real, y_Real} :> {Cos[x], Sin[x], y} ...


3

Good question. I believe it is the result of an incomplete attempt to optimize conversion of Raster objects to Image objects; a bug in other words. Note that when the axes are included the output is correct: Image @ Graphics[myraster, Axes -> True] (* v10.0.1 *) Trace of the correct conversion Running a Trace with option TraceInternal -> True ...


1

If you don't know a priori the function ranges you could use something like this: makePlots[list_] := Module[{vals = {}, ss}, plot[n_, scale_, mode_] := ListContourPlot[n, InterpolationOrder -> 3, ColorFunctionScaling -> False, ImageSize -> 300, ColorFunction -> Function[{z}, If[mode == 0, vals = Join[vals, {z}]]; ...


2

You can use the same color scale in both plots together with the option ColorFunctionScaling -> False: data1 = RandomReal[{10, 25}, {10, 10}]; data2 = RandomReal[{40, 100}, {10, 10}]; bl = BarLegend[{"Rainbow", {0, 100}}, 50]; lcp1 = ListContourPlot[data1, InterpolationOrder -> 3, ImageSize -> 300, ColorFunctionScaling -> False, ...


3

One can smooth the graph by averaging the position of each degree 2 vertex with its neighborhoods. In addition, if the vertex's original position is included in the average, the vertex will be pulled slightly toward it. (Thus four points are being averaged, hence the 0.25 below.) If one iterates this procedure, nice "curved" paths develop. coords = ...


4

Here is a solution which combines kguler's and MichaelE2's approaches: ParametricPlot[{x, y}, {x, y} ∈ blob, Mesh -> 20, MeshFunctions -> {#1 - #2 &}, MeshStyle -> Black, BoundaryStyle -> Black, PlotStyle -> None, Axes -> False] Note however that the syntax form ParametricPlot[{x, y}, {x, y} ∈ region] seems to be undocumented. ...


4

Firstly, Manipulate[ Plot3D[2 a1 x + 2 a2 y + a1^2 + a2^2, {x, -5, 5}, {y, -10, 10}], {a1, -10, 10}, {a2, -10, 10}] Then you canuse the Table Show[ Table[ Plot3D[2 a1 x + 2 a2 y + a1^2 + a2^2, {x, -5, 5}, {y, -10, 10}], {a1, 0, 10, 5}, {a2, 0, 10, 5}]]


12

Update: Using MeshFunctions and Mesh in RegionPlot: RegionPlot[Evaluate[Region`RegionProperty[Rationalize /@ blob, {x, y}, "FastDescription"][[1, 2]]], {x, -3, 3}, {y, -3, 3}, Mesh -> 50, MeshFunctions -> {#1 + #2 &, #1 - #2 &}, MeshStyle -> White, PlotStyle -> Directive[{Thick, Blue}]] With settings MeshStyle -> ...


3

Edit 2: Updated with a non-convex polygon reg = With[{pts = RandomReal[{-3, 3}, {15, 2}]}, Polygon@SortBy[pts, Apply[ArcTan, # - Mean[pts]] &]]; You could make a texture and use RegionPlot: RegionPlot[ reg, PlotStyle -> Texture[ExampleData[{"ColorTexture", "MultiSpiralsPattern"}]]] Update Vector graphics through ContourShading: ...


8

For the part I would need to identify the relevant segments automatically. you can use vd2 = ConnectedComponents@Subgraph[g0, VertexList[g0, x_ /; (VertexDegree[g0, x] == 2)]] {{36, 43, 49, 48, 55, 63}, {41, 42, 47, 54, 62}, {39, 40, 46, 53}, {94, 95, 96}, {82, 92, 99}, {77, 78, 84}, {38, 45, 52}, {13, 17, 18}, {9, 10, 11}, {104, 105}, ...


4

Needs["ErrorBarPlots`"] myplot = ErrorListPlot[{ {{20, 0.75}, ErrorBar[{0.5 - 0.75, 0.9 - 0.75}]}, {{10, 0.7}, ErrorBar[{0.5 - 0.7, 0.97 - 0.7}]}}]; myplot2 = ErrorListPlot[{ {{20, 0.85}, ErrorBar[{0.5 - 0.85, 0.9 - 0.85}]}, {{10, 0.8}, ErrorBar[{0.6 - 0.8, 0.91 - 0.8}]}}, PlotStyle -> Red]; Show[ myplot /. {x_?NumericQ, ...


3

Not the fastest but the most general way is to learn how to use Overlay, very useful function. With[{ opt = Sequence[PlotRange -> {.4, 1}, FrameTicks -> {{10, 20}, Automatic}, BaseStyle -> AbsolutePointSize@10] }, myplot = ErrorListPlot[{{{20, 0.75}, ErrorBar[{0.5 - 0.75, 0.9 - 0.75}]}, {{10, 0.7}, ErrorBar[{0.5 - ...


0

try this if it help: myplot = ErrorListPlot[{{{20, 0.75}, ErrorBar[{0.5 - 0.75, 0.9 - 0.75}]}, {{10, 0.7}, ErrorBar[{0.5 - 0.7, 0.97 - 0.7}]}}, FrameTicks -> {{10, 20}, Automatic}, PlotRange -> All, Frame -> True, PlotStyle -> Black, PlotRangePadding -> 1]; myplot2 = ErrorListPlot[{{{20, 0.85}, ErrorBar[{0.5 - 0.85, ...


6

I changed tri to List of your code. d = 9; x = {}; For[t = 1, t <= d, t++, If[t < d, AppendTo[x, {t, 1, 1} <-> {t + 1, 1, 1}]]; For[r = 2, r <= d, r++, If[t < d, AppendTo[x, {t, r, 1} <-> {t + 1, r, 1}]]; For[i = 2, i <= r, i++, If[t < d, AppendTo[x, {t, r, i} <-> {t + 1, r, i}]]; AppendTo[x, {t, r, i - 1} ...


5

points = {{0, 1}, {1, 0}, {1, 1}, {4, 4}, {0, 4}, {3, 0}}; interp[points_] := Module[{d}, d = Prepend[Accumulate[Norm /@ Differences@points], 0]; Interpolation[Transpose@{List /@ d, points}, InterpolationOrder -> 1] ] f = interp[points]; Animate[ ParametricPlot[f[t], {t, 0, time}, PlotRange -> {Min @ points[[All,1]], Max @ ...


3

Uniform displacement by arc-length reparametrization - Some code stolen from @Mark McClure points = {{0, 0}, {.5, 4}, {1, 0}, {4, 4}} f = Interpolation[points, InterpolationOrder -> 1]; $Assumptions = {t > 0}; arcLength[t_?NumericQ] := arcLength[t] = NIntegrate[Norm[{1, f'[tau]}], {tau, 0, t}]; timeFromArc[s_?NumericQ] := timeFromArc[s] = t /. ...


8

Using the option MaxRecursion -> 8 greatly reduces the problem in a better way than PlotPoints as points are added only in the regions where is needed i.e. with big first and second derivatives. Here is with an overkill of MaxRecursion -> 12 and WorkingPrecision -> 22 just to be sure. g1 = Plot3D[F[x, y], {x, 0, 2.5}, {y, 0, 11}, BoxRatios ...


8

This behaves better with a RegionFunction: p1 = Plot3D[(1 - 1/4 (x - y/x)^2)/x, { x, 0, 2.5}, {y, 0, 11}, BoxRatios -> {3, 3, 2.2}, PlotPoints -> {30, 30}, PlotRange -> {0, 3.5}, MeshFunctions -> {#1 &}, Lighting -> "Neutral", ClippingStyle -> Opacity[1]] p2 = Plot3D[0.00001, { x, 0, 2.5}, {y, 0, 11}, BoxRatios -> {3, 3, ...


7

You need to write function to set new coord and new edge shape function. Here's one example to do such things: mergeVertex[g_, set_List] := Block[{vcoord, ids, ncoord, ng, newv, nedge, endp, oedge, pind, neshape}, vcoord = GraphEmbedding[g]; ids = {VertexIndex[g, #]} & /@ set; ncoord = Join[Delete[vcoord, ids], {Mean[Extract[vcoord, ...


6

Using the setting Mesh->Full seems to solve the issue (in both Version 9 and 10): With[{dates = {1906, 1907, 1912, 1929, 1941, 1949, 1952, 1953, 1965, 1976, 1998, 1998}, evens = Range[0, 11]*(92/11) + 1906}, ListPlot[{dates, evens}, Joined -> True, Mesh -> Full, InterpolationOrder -> None, PlotMarkers -> Automatic, Filling -> {1 ...


3

I assume the extra points are created for the filling polygon, and erroneously given a plot marker along with the "real" points. A simple workaround is just to create two plots, one with filling and one with plot markers, and combine them with Show: With[{dates = {1906, 1907, 1912, 1929, 1941, 1949, 1952, 1953, 1965, 1976, 1998, 1998}, evens = Range[0, ...


1

My output looks a little bit different sphere = {Cos[u] Sin[v], Sin[u] Sin[v], Cos[v]}; MeanCurvature[f_] := With[{du = D[f, u], dv = D[f, v]}, Simplify[(Det[{D[du, u], du, dv}] * dv.dv - 2 Det[{D[f, u, v], du, dv}] * du.dv + Det[{D[dv, v], du, dv}] * du.du) / (2 Simplify[(du.du * dv.dv - (du.dv)^2)]^(3/2))]]; mean = ...


1

In order to get things work I advise you to first check out help page for the function you're planning to use. Here, lets check out ParametricPlot3D. And then look up your code for differences. ParametricPlot3D[{x, radii[x]*Cos[t], radii[x]*Sin[t] + centers[x][[2]], EdgeForm[]}, {t, 0, 2 Pi}, {x, lowerx, upperx}, ViewPoint -> {1, -3, .5}, PlotPoints ...


2

As Oska noted in the comments, adding the option CornerNeighbors->False in arrayGraph gives the desired result for 2D. (See also this answer to a different Q/A).. ClearAll[arrayGraph]; arrayGraph[mat_, opts : OptionsPattern[]] := Module[{m = Module[{i = 1}, mat /. 1 :> i++], edges, vcs, v}, v = ComponentMeasurements[m, "Label"][[All, 1]]; vcs = ...


3

Try this: graphList = {{1, 2}, {1, 3}, {1, 4}, {2, 5}, {3, 6}, {4, 7}} Graph[UndirectedEdge @@@ graphList, GraphLayout -> "SpringElectricalEmbedding"] There are a couple layout methods available, but the ones you probably want to use are either "SpringElectricalEmbedding" or "SpringEmbedding". Both work by a minimization of an energy functional ...


0

Just an addendum to ybeltukov's nice answer (I don't like the loud blue) n = 12; Graphics @ {EdgeForm[Thin], Table[{RandomColor[], Rectangle[{x, -i}, {x + #[[i]], 1 - i}]}, {i, Length @ #}, {x, 1, n, #[[i]]}] & @ Divisors @ n}


0

Three new Swatch designs for those of us disliking digits and fingers n = 1.5; im = Image @ ContourPlot[Im[ArcSin[(x + I y)^6]], {x, -n, n}, {y, -n, n}, Frame -> False, Contours -> 4, ContourShading -> ColorData[36, "ColorList"]]; GraphicsRow[{ dil = Dilation[im, 10], ImageEffect[dil, {"Embossing", 3, 3}], GradientFilter[dil, ...


2

You could also use field = 1.45; Plot[x, {x, 1, 3}, Epilog -> Inset[Style[Row[{"H = ", field, " T"}], 12], {1.5, 2.5}]]


2

field = 1.45; Plot[x, {x, 1, 3}, Epilog -> {Style[Text["H = " <> ToString@field <> " T", {1.5, 2.5}], 12]}]


4

Just use MeshFunction. Manipulate[ParametricPlot3D[{Sin[\[Theta]] Cos[\[Phi]], Sin[\[Theta]] Sin[\[Phi]], Cos[\[Theta]]}, {\[Theta], 0, \[Pi]}, {\[Phi], 0, 2 \[Pi]}, PlotStyle -> Opacity[0.5], Mesh -> {{0.}}, MeshStyle -> {Red, Thick}, MeshFunctions -> {Sin[a] Cos[b] #1 + Sin[a] Sin[b] #2 + Cos[a] #3 &}], {a, 0, \[Pi]}, {b, 0, 2 \[Pi]}] ...


2

Here's my take on it: With[{n=24}, Graphics[{Hue[3/5], EdgeForm[Thin], MapIndexed[Table[Rectangle[{x, First@#2-1}, {x+#1, First@#2}], {x, 0, n-#1, #1}]&, Reverse@Divisors@n]}]]


3

rng = Range[0, 24, #] & /@ Divisors[24]; Graphics[{{Hue[0.6], Rectangle[{0, 0}, {24, 8}]}, Map[Line, MapThread[ Map[Function[x, {{x, #2}, {x, #2 + 1}}], #1] &, {Reverse[rng], Range[0, 7, 1]}], {2}], Table[Line[{{0, j}, {24, j}}], {j, 0, 8}]}]


5

I used Grid for this. n = 36; PadRight and SpanFromLeft make empty spaces. Grid[Flatten@Table[PadRight[{""},#,SpanFromLeft],{n/#}]& /@ Divisors@n,Frame-> All]


1

With respect to my question, I was after the partitioning of 10 between 2 and 4 integers, so "ulvi" ans. helped. Show[FerrersDiagram[IntegerPartitions[10, {2, 4}]], Frame -> True, FrameLabel -> {Style["N", Large, Bold], Style["Level", Large, Bold]}, RotateLabel -> True, LabelStyle -> Directive[Bold, Large]]


1

Argument should be a partition: FerrersDiagram[{1, 1, 2, 2, 4}]


14

You can obtain it with a proper combination of Table and Divisors n = 24; Graphics@{Hue[3/5], EdgeForm[Thin], Table[Rectangle[{x, -i}, {x + #[[i]], 1 - i}], {i, Length@#}, {x, 1, n, #[[i]]}] &@Divisors@n} Image-processing approach can be even more compact Image@Flatten[ArrayPad[ConstantArray[{0, .4, 1}, {n/#, 18, 20 # - 2}], {0, 1, 1, 0}] & ...


7

Here's a Table of Table's approach for starters: list = {1, 2, 3, 4, 6, 8, 12, 24}; Graphics[{Hue[3/5], EdgeForm[Thin], Table[Rectangle[{24 (j - 1)/list[[k]], k}, {24 j/list[[k]], k + 1}], {k, 8}, {j, list[[k]]}]}]


2

Here's a qualitative way to do the computation using FFTs. First, make some data (in this, the disks all have phase 1, but that can be easily fixed): w1 = 600; w2 = 800; dat = Sum[ RotateRight[ DiskMatrix[ RandomInteger[{1, 150}], {w1, w2}], {RandomInteger[{-1000, 1000}], RandomInteger[{-1000, 1000}]}], {k, 6}]; Here's a plot of ...


7

Here is a cheat using BoxWhiskerChart. The error bars are quantiles (0.05, 0.95) and not symmetric confidence interval. It is not ideal wrt placement of mean marker. Using: rv = RandomVariate[NormalDistribution[10, 3], {20, 10}]; BoxWhiskerChart[rv, {{"MeanMarker", Style[\[FilledSmallCircle], 20], Blue}}, Method -> {"BoxRange" -> (Quantile[#, ...


7

You can use ErrorListPlot as described in: How to : Add Error Bars to Charts and Plots. (This might be considered "easily found" however I don't believe "caterpillar plot" would find it.) The first example from the documentation: Needs["ErrorBarPlots`"] ErrorListPlot[Table[{i, RandomReal[{0.2, 1}]}, {i, 10}]] By the way if you find that the error ...


5

Mathematica has a lot of image-processing functions. The proper combination of them will give you the desired result. Loading and cropping: $HistoryLength = 0; img = Binarize@ImagePad[#, -{{340, 80}, {230, 60}}] &@ Import@"http://i.stack.imgur.com/5FnSe.jpg" Erosion and removing small white components img2 = SelectComponents[#, ...


2

An alternative method based on kguler's finding: ParametricPlot[r {Cos[t], Sin[t]}, {r, 0, 12}, {t, 0, 2 Pi}, Mesh -> 23, Axes -> False, MeshShading -> {{c, c}, {c, c}}, PlotRange -> {{-9, 9}, {-4, 4}}] /. c :> Hue@RandomReal[] Note that as well as the kluger's answer this is based on undocumented details of the implementation of ...


1

Indeed your problem is the different image sizes Try fixing the PlotRange frames = Table[ ParametricPlot3D[ {r Cos[\[Theta]], r Sin[\[Theta]], f[r, \[Theta]]}, {r, 0, 4}, {\[Theta], 0, 2 \[Pi]} , PlotRange -> {{-5, 5}, {-5, 5}, {-15, 15}} ], {t, 1, 10, 0.1}]; Now all images are the same size. Tally[ImageDimensions /@ frames] ...



Top 50 recent answers are included