Skip to main content

graphics - How to conveniently plot 3-category Dirichlet data in equilateral triangle instead of 2-simplex


I'm wondering if there's something in Mathematica similar to the built-in function in R shown in the figures below, borrowed from this post, possibly with flexible axes "orientation", ticksmarks, tick numbers, and gridlines.


enter image description here


By a 3-category Dirichlet distribution, it means that each data point is in the form of $\{u, v, 1-u-v\}$, where the degree of freedom is two with $0

Currently I've been doing something like the demonstrative code below, transforming the data points myself from $\{u,v\}$ in the usual Cartesian coordinates to the "triangular" coordinates. (here the "vertical" axis is flipped just like those plots from R)


ClearAll[Opt, data, dN]; 
dN = 100;
data = RandomReal[{0, 1}, {dN, 3}];
data = data/(Total /@ data);
Opt = {PlotStyle -> PointSize -> Medium, AspectRatio -> 1, PlotRange -> {{0, 1}, {0, 1}}, GridLines -> {{1}, {1}} };

GraphicsRow[{ListPlot[data[[;; , 1 ;; 2]],
Epilog -> Line@{{1, 0}, {0, 1}}, Evaluate@Opt] ,
ListPlot[ Thread@{1/2 (1 + data[[;; , 1]] - data[[;; , 2]]), Sqrt[3] data[[;; , 3]]/2} ,
Epilog -> {FaceForm[], EdgeForm@Thickness@.01, Triangle@{{0, 0}, {1, Sqrt[3]}/2, {1, 0}}}, Evaluate@Opt]}, ImageSize -> 500]

enter image description here


Firstly I feel kind of stupid having to do it this way every time. Secondly, it's tedious to add the tickmarks, gridlines, etc.


So, repeating my question statement in the opening line:



Is there actually a similar built-in graphics package in MMA? If not, is there a convenient way to achieve some if not all the features in a "triangular plot" shown in the R plots?




I would imagine that Dirichlet distribution is pretty common and someone have developed something practically useful already.


Pointers to references or any suggestions will be appreciated.



Answer



How is this? It does not support all Graphics options, but that can be customized. As is, it mimics the styling of ListPlot.


ClearAll[BarycentricPlot];
BarycentricPlot[data_?MatrixQ,
OptionsPattern[{
"Ticks" -> N@Range[0, 1, 1/10]
}]] :=

Module[{λ, pts, plot, h, c, opts, g, s, prolog, gridlinesx,
gridlinesy, ticks},
h = Sin[Pi/3];
c = {1/2, h/3};
λ = data/Total[data, {2}];
plot = ListPlot[λ.Developer`ToPackedArray[
N[{{0, 0}, {1, 0}, {1/2, h}}]]];
opts = Options[plot];
ticks = OptionValue["Ticks"];
gridlinesy = ticks[[2 ;; -2]] h;

gridlinesx = gridlinesy/Tan[Pi/3];
g[label_, θ_, ϕ_] :=
Graphics[{
Rotate[
Text[Style[label, {}], {1/2, h + 0.1}], Ï•, {1/2,
h + 0.1}],
GridLinesStyle /. opts,
Line@Transpose[{
Transpose[{gridlinesx , gridlinesy}],
Transpose[{1 - gridlinesx , gridlinesy}]

}]
},
PlotRangePadding -> 0,
ImageMargins -> 0.1,
PlotRange -> {{0, 1}, {0, 2 h}},
Axes -> {True, False},
Ticks -> {Table[{x, Rotate[x, 4 Pi/3 + θ]}, {x, ticks}],
None},
AxesStyle -> (AxesStyle /. opts)
];

s = 1.055;
prolog = Graphics[{
Inset[g["\!\(\*SubscriptBox[\(μ\), \(3\)]\)", -Pi, 0], c, c,
s],
Rotate[
Inset[g["\!\(\*SubscriptBox[\(μ\), \(1\)]\)", 0, Pi], c, c,
s], 2/3 Pi, c],
Rotate[
Inset[g["\!\(\*SubscriptBox[\(μ\), \(2\)]\)", -Pi, -Pi], c,
c, s], 4/3 Pi, c]

},
PlotRange -> {{0, 1}, {0, h}},
PlotRangePadding -> Scaled[0.15],
Frame -> False
];
Show[{prolog, plot}]
]

dN = 1000;
data = RandomReal[{0, 1}, {dN, 3}];

BarycentricPlot[data]

enter image description here


Comments

Popular posts from this blog

front end - keyboard shortcut to invoke Insert new matrix

I frequently need to type in some matrices, and the menu command Insert > Table/Matrix > New... allows matrices with lines drawn between columns and rows, which is very helpful. I would like to make a keyboard shortcut for it, but cannot find the relevant frontend token command (4209405) for it. Since the FullForm[] and InputForm[] of matrices with lines drawn between rows and columns is the same as those without lines, it's hard to do this via 3rd party system-wide text expanders (e.g. autohotkey or atext on mac). How does one assign a keyboard shortcut for the menu item Insert > Table/Matrix > New... , preferably using only mathematica? Thanks! Answer In the MenuSetup.tr (for linux located in the $InstallationDirectory/SystemFiles/FrontEnd/TextResources/X/ directory), I changed the line MenuItem["&New...", "CreateGridBoxDialog"] to read MenuItem["&New...", "CreateGridBoxDialog", MenuKey["m", Modifiers-...

How to thread a list

I have data in format data = {{a1, a2}, {b1, b2}, {c1, c2}, {d1, d2}} Tableform: I want to thread it to : tdata = {{{a1, b1}, {a2, b2}}, {{a1, c1}, {a2, c2}}, {{a1, d1}, {a2, d2}}} Tableform: And I would like to do better then pseudofunction[n_] := Transpose[{data2[[1]], data2[[n]]}]; SetAttributes[pseudofunction, Listable]; Range[2, 4] // pseudofunction Here is my benchmark data, where data3 is normal sample of real data. data3 = Drop[ExcelWorkBook[[Column1 ;; Column4]], None, 1]; data2 = {a #, b #, c #, d #} & /@ Range[1, 10^5]; data = RandomReal[{0, 1}, {10^6, 4}]; Here is my benchmark code kptnw[list_] := Transpose[{Table[First@#, {Length@# - 1}], Rest@#}, {3, 1, 2}] &@list kptnw2[list_] := Transpose[{ConstantArray[First@#, Length@# - 1], Rest@#}, {3, 1, 2}] &@list OleksandrR[list_] := Flatten[Outer[List, List@First[list], Rest[list], 1], {{2}, {1, 4}}] paradox2[list_] := Partition[Riffle[list[[1]], #], 2] & /@ Drop[list, 1] RM[list_] := FoldList[Transpose[{First@li...

plotting - How to draw lines between specified dots on ListPlot?

I would like to create a plot where I have unconnected dots and some connected. So far, I have figured out how to draw the dots. My code is the following: ListPlot[{{1, 1}, {2, 2}, {3, 3}, {4, 4}, {1, 4}, {2, 5}, {3, 6}, {4, 7}, {1, 7}, {2, 8}, {3, 9}, {4, 10}, {1, 10}, {2, 11}, {3, 12}, {4,13}, {2.5, 7}}, Ticks -> {{1, 2, 3, 4}, None}, AxesStyle -> Thin, TicksStyle -> Directive[Black, Bold, 12], Mesh -> Full] I have thought using ListLinePlot command, but I don't know how to specify to the command to draw only selected lines between the dots. Do have any suggestions/hints on how to do that? Thank you. Answer One possibility would be to use Epilog with Line : ListPlot[ {{1, 1}, {2, 2}, {3, 3}, {4, 4}, {1, 4}, {2, 5}, {3, 6}, {4, 7}, {1, 7}, {2, 8}, {3, 9}, {4, 10}, {1, 10}, {2, 11}, {3, 12}, {4, 13}, {2.5, 7}}, Ticks -> {{1, 2, 3, 4}, None}, AxesStyle -> Thin, TicksStyle -> Directive[Black, Bold, 12], Mesh -> Full, Epilog -> { Line[ ...