55
$\begingroup$

How can I get a ternary density plot just like the plots from OriginLab? ternary density plot

ContourPlot and DensityPlot seemingly can accept the [f, {x}, {y}]-style,but cannot accept the [f, {x},{y}, {z}]-style.

$\endgroup$
2

8 Answers 8

19
$\begingroup$

Here's my attempt at an implementation, using ReliefImage[] to give the plots some depth perception:

triangleTicks[arg_List: {5, 4}, tl_: 0.01] := Module[{divs, dQ, sides, st},
             dQ = VectorQ[#, IntegerQ] && Length[#] == 2 &;
             sides = Partition[{{0, 0}, {1, 0}, {1, Sqrt[3]}/2}, 2, 1, 1];
             divs = If[dQ[arg] || (MatrixQ[arg, NumericQ] && First[Dimensions[arg]] == 1),
                       {arg}, arg];
             divs = If[dQ[#], 
                       DeleteCases[MapAt[Function[f, Flatten[ArrayPad[#, -1] & /@ f]], 
                                   FindDivisions[{0, 1, 1/Rest[FoldList[Times, 1, #]]}, #], 
                                         2], {}], #] & /@
                       divs[[Mod[Range[3], Length[divs], 1]]];
             st = MapThread[Table[Join[Transpose[{1 - d, d}].#1, List /@ d, 2], {d, #2}] &,
                            {sides, divs}];
             MapIndexed[Block[{pt = N[Most[#1]], os}, 
                               os = Scaled[RotationTransform[2 π (#2[[1]] - 2)/3][
                                                           {tl/#2[[2]], 0}], pt];
                              If[#2[[2]] == 2, Line[{pt, os}],
                                 {Text[ToString[If[IntegerQ[Last[#1]],
                                                   Identity, N][Last[#1]]], os,
                                       {{1, 1}, {-1, -1}, {1, -1}}[[#2[[1]]]]],
                                  Line[{pt, os}]}]] &, st, {3}]]

Options[TernaryReliefPlot] =
{AspectRatio -> Automatic, Background -> None, BaselinePosition -> Automatic,
 BaseStyle -> {}, ClippingStyle -> {Black, White}, ColorFunction -> "ThermometerColors",
 ColorFunctionScaling -> True, ColorOutput -> Automatic, ContentSelectable -> Automatic,
 CoordinatesToolOptions -> Automatic, DisplayFunction :> $DisplayFunction, Epilog -> {},
 FormatType :> TraditionalForm, FrameLabel -> None, FrameTicks -> Automatic,
 ImageMargins -> 0., ImagePadding -> All, ImageSize -> Automatic,
 ImageSizeRaw -> Automatic, LabelStyle -> {}, Method -> Automatic, PlotLabel -> None,
 PlotPoints -> Automatic, PlotRange -> All, PlotRegion -> Automatic,
 PreserveImageOptions -> Automatic, Prolog -> {}, RotateLabel -> True};

TernaryReliefPlot[f_, opts : OptionsPattern[]] :=
       Module[{fl, flt, ft, img, n, rl, sides},
              sides = {{0, 0}, {1, 0}, {1, Sqrt[3]}/2};
              fl = OptionValue[FrameLabel];
              If[fl =!= None,
                 If[fl === Automatic, fl = ToString /@ Range[3]];
                 If[Head[fl] =!= List, fl = PadRight[{fl}, 3, ""]];
                 flt = {fl, ListCorrelate[{{1}, {1}}/2, sides, 1]} ~Join~
                 If[MatchQ[OptionValue[RotateLabel], True | Automatic],
                    {{{0, 2.5}, {0, -2.5}, {0, -2.5}},
                     {{1, 0}, {1, -Sqrt[3]}/2, {1, Sqrt[3]}/2}},
                    {{{0, 2.5}, {-2.5, 0}, {2.5, 0}}}]];
              ft = OptionValue[FrameTicks]; If[ft === Automatic, ft = {5, 4}];
              n = OptionValue[PlotPoints]; If[n === Automatic, n = 300];
              img = ReliefImage[SparseArray[{j_, k_} /; j >= k :> 
                                            f @@ ({j - k, k - 1, n - j}/(n - 1)), {n, n}],
                                FilterRules[Join[{opts}, Options[TernaryReliefPlot]],
                                            Options[ReliefImage]]];
              Graphics[{If[ft =!= None, triangleTicks[ft], {}],
                        Texture[img], Polygon[sides, VertexTextureCoordinates ->
                                              {{0, 0}, {1, 0}, {0, 1}}],
                        If[fl =!= None, MapThread[Text, flt], {}]},
                       Axes -> False, AxesLabel -> None, Frame -> False,
                       FrameLabel -> None, Method -> Automatic, PlotRange -> All, 
                       FilterRules[Join[{opts}, Options[TernaryReliefPlot]],
                                   Options[Graphics]]]]

Try it out:

TernaryReliefPlot[#3 Sin[10 #1]^2 + #3 (1 - #3) Cos[20 #2]^2 &, 
                  ColorFunction -> (Hue[0.85 #] &), 
                  FrameLabel -> {Style["p", Large], Style["q", Large], Style["r", Large]},
                  FrameTicks -> {4, 2}]

a ternary relief plot

It's still missing a few things (e.g. grid lines), but it's a start. I'll try to improve on this when I get the chance.

$\endgroup$
43
$\begingroup$

A basic approach

You can start with a regular density plot, restricted to the domain of x and y using RegionFunction. Then you can transform the plot to an equilateral triangle.

f[p_, q_, r_] := r Sin[10 p]^2 + (1 - r) r Cos[20 q]^2;

dp = DensityPlot[f[x, y, 1 - x - y], {x, 0, 1}, {y, 0, 1}, 
  RegionFunction -> (#1 <= 1 - #2 &), ColorFunction -> (Hue[0.85 #] &),
   Frame -> None, PlotRange -> All, AspectRatio -> Automatic]

Mathematica graphics

It's easy enough to construct the transformation by hand, but it's also easy to use FindGeometricTransform.

{error, xf} = 
  FindGeometricTransform[
    {{0, 0}, {1, 0}, {1, Tan[Pi/3]}/2},
    {{0, 0}, {1, 0}, {0, 1}}];

Graphics[
  GeometricTransformation[
   First @ dp,
   xf
   ]]

Mathematica graphics

We can apply ticks modifying this answer to create a triangleTicks function (see below).

triangleTicks[Graphics[
  GeometricTransformation[
   First@dp,
   xf
   ]]
 ]

Mathematica graphics


Update 3 - A better looking (at low-res) approach

Here's another parametrization that goes along with Mathematica's native subdivision of the plot domain. It shows that the right triangles in the subdivision of the base image are mapped to equilateral triangles in the transformed image. So it looks less distorted, although from a mathematical point of view, the denser the same points, the more faithful the representation. The plot above appears to have a roughly ENE bias due to the mesh subdivision getting compressed.

cartestianToBarycentric2 = 
 Compile[{{x, _Real}, {y, _Real}}, (x - y) {1, 0} + y {1, Sqrt[3]}/2, 
  RuntimeAttributes -> {Listable}, RuntimeOptions -> "Speed"]; base = 
 DensityPlot[f[x - y, y, 1 - x], {x, 0, 1}, {y, 0, 1},
  Mesh -> All, MaxRecursion -> 0, RegionFunction -> (#1 >= #2 &), 
  ColorFunction -> (Hue[0.85 #] &), Frame -> None, PlotRange -> All, 
  AspectRatio -> Automatic];
transformed = MapAt[
   cartestianToBarycentric2 @@ Transpose[#] &,
   base,
   {1, 1}];
Graphics[{
  Inset[Show[base, AlignmentPoint -> {1.2, 0}], {0, 0}, Automatic, 
   1],
  Thick, Arrow[{{-0.1, 0.4}, {0.15, 0.4}}],
  Inset[Show[transformed, AlignmentPoint -> {-0.1, 0}], {0, 0}, 
   Automatic, 1]},
 PlotRange -> {{-1.2, 1.15}, {-0.05, 1.0}}
 ]

Mathematica graphics

Here is a plot with a coordinate grid:

dp = DensityPlot[f[x - y, y, 1 - x], {x, 0, 1}, {y, 0, 1},
   MeshFunctions -> {#1 - #2 &, #2 &, 1 - #1 &}, Mesh -> 19,
   RegionFunction -> (#1 >= #2 &), ColorFunction -> (Hue[0.85 #] &), 
   Frame -> None, PlotRange -> All, AspectRatio -> Automatic];
triangleTicks[
 MapAt[
  cartestianToBarycentric2 @@ Transpose[#] &,
  dp,
  {1, 1}]
 ]

Mathematica graphics


Update 1 -- Getting rid of GeometricTransform from the plot

Alexey Popkov pointed out that there is a problem with GeometricTransform and exporting. It was easy to fix the density plot, and the ticks needed rewriting (see below).

cartestianToBarycentric = 
  Compile[{{x, _Real}, {y, _Real}}, x {1, 0} + y {1, Sqrt[3]}/2, 
   RuntimeAttributes -> {Listable}, RuntimeOptions -> "Speed"];

MapAt[
 cartestianToBarycentric @@ Transpose[#] &,
 dp,
 {1, 1}]

Update 2 -- Getting rid of GeometricTransform from the ticks

tickGraphics now avoids using GeometricTransform

Basically tickGraphics creates an axis on one side of the equilateral triangle. It is rotated about the sides (counter-rotating the text). The argument total represents the sum of the ternary variables (which should be constant).

ClearAll[tickGraphics, triangleTicks];
Module[{ticklen = 0.025, (*length of ticks (const parameter)*)
        textoffset = 0.04},
 
 tickGraphics[tickrange : {0., total_}, angle_] := 
  With[{rotSideXF = RotationTransform[angle, total {1., Tan[Pi/6]}/2.]},
   {Line[rotSideXF /@ Thread[{tickrange, 0}]],
    With[{rotTickXF = Composition[
          RotationTransform[π/3., rotSideXF @ {#, 0.}],
          rotSideXF]},
       {Text[NumberForm[N @ #, {3, 2}], 
         rotTickXF[total {-ticklen - textoffset, 0} + {#, 0.}], {0, 0.}],
        {Line[rotTickXF /@ {total {-ticklen, 0} + {#, 0.}, {#, 0.}}]}}] & /@
     Select[N @ FindDivisions[tickrange, 4], 0. <= # <= total &]
    }
   ];
 
 triangleTicks[g_Graphics, total_: 1] :=
  Show[
   Graphics[First@g],
   Graphics[{
     AbsoluteThickness[0.5],
     Table[
      tickGraphics[{0., total}, N@angle],
      {angle, 0, 4 Pi/3, 2 Pi/3}]}],
   Axes -> False, Frame -> None, 
   PlotRange -> total {{0, 1 + ticklen}, {0, Sqrt[3]/2 + ticklen/2}}, 
   PlotRangePadding -> 0.07 total, PlotRangeClipping -> False, 
   ImagePadding -> {{20, 5}, {20, 5}}]
 ]
$\endgroup$
11
  • $\begingroup$ What is the definition for function f[x, y, 1 - y] you have plotted? $\endgroup$ Jan 3, 2014 at 17:54
  • $\begingroup$ Ugh, it took me forever to find the transform, +1. $\endgroup$ Jan 3, 2014 at 18:09
  • $\begingroup$ Is the range you've used for f correct for a ternary plot? I thought the sum of the arguments needs to be <= 1. $\endgroup$ Jan 3, 2014 at 18:19
  • $\begingroup$ According to Wikipedia, the sum of three variables must be a constant for ternary plot. $\endgroup$ Jan 3, 2014 at 18:25
  • 4
    $\begingroup$ The answer is great. It is worth to mention that if someone wants ticks to be perpendicular to the corresponding side of the equilateral triangle it is sufficient to replace π/3. with π/2. in the tickGraphics function. (+1) $\endgroup$ Jan 4, 2014 at 9:55
30
$\begingroup$

Update: now it is real ternary plot.

You can start with the 2D-adaptation of the surface plotting:

texturize[f_, n_, colf_] := # /. Polygon[{v1_, v2_, v3_}] :> {EdgeForm[], 
      Texture@ImageData@Colorize[Image@f[#1, #2, 1 - #1 - #2] &[#, Transpose[#]] &@
          ConstantArray[Range[-1./n, 1 + 1/n, 1./n], n + 3], 
         ColorFunction -> colf, ColorFunctionScaling -> False], 
      Polygon[{v1, v2, v3}, VertexTextureCoordinates -> {{1 - 1.5/(n+3), 1 - 1.5/(n+3)}, 
         {1.5/(n+3), 1.5/(n+3)}, {1.5/(n+3), 1 - 1.5/(n+3)}}]} &;

f = #3 Sin[10 #1]^2 + (1 - #3) #3 Cos[20 #2]^2 &;

triangleTicks@Graphics@N@Polygon[{{0, 0}, {1, 0}, {1/2, Sqrt[3]/2}}] 
     // texturize[f, 300, Hue]

enter image description here

Here f assumed to be Listable. For ticks I used Michael's triangleTicks function.

Note, that this approach is ~100 times faster than corresponding DensityPlot!

$\endgroup$
6
  • 4
    $\begingroup$ Is this really a ternary plot? Or just the plot simply mapped/clipped to a triangle? In a ternary plot, three variables are plotted and at each point in the triangle, the sum of the three variables is a constant. $\endgroup$
    – rm -rf
    Jan 3, 2014 at 14:38
  • $\begingroup$ @rm-rf I have found time to update my post. Now it is really a ternary plot. $\endgroup$
    – ybeltukov
    Jan 4, 2014 at 14:31
  • $\begingroup$ (+1) Your code is fast but very difficult to read. Please add an explanation what it basically does. $\endgroup$ Jan 4, 2014 at 15:44
  • $\begingroup$ @AlexeyPopkov It replaces the triangle to the triangle with a texture. I prepare a rectangular grid with ConstantArray and calculate texture on it. Values 1./n and 1.5/n are necessary to produce small margins in the texture. $\endgroup$
    – ybeltukov
    Jan 4, 2014 at 17:41
  • $\begingroup$ Why not do all DensityPlots this way (with an appropriate mapping of a rectangle, etc.)? $\endgroup$
    – Michael E2
    Jan 4, 2014 at 19:27
21
$\begingroup$

The built-in ContourPlot3D seems fast enough for me:

f = #3 Sin[10 #1]^2 + (1 - #3) #3 Cos[20 #2]^2 &;

frange = Through@{NMinValue, NMaxValue}[{f[x, y, z], 
                    0 <= x <= 1 && 0 <= y <= 1 && 0 <= z <= 1}, {x, y, z}];

AbsoluteTiming[
    trigplot3d = 
        ContourPlot3D[x + y + z == 1, {x, 0, 1}, {y, 0, 1}, {z, 0, 1},
            PlotRange -> All,
            PlotPoints -> 50,
            (* you can add any kind of mesh: *)
            MeshFunctions -> Function[{x, y, z, w}, f[x, y, z]],
            Mesh -> 10,
            (* ColorFunction is essential: *)
            ColorFunctionScaling -> False,
            ColorFunction -> Function[{x, y, z, w},
                    ColorData["Rainbow"][
                        Rescale[f[x, y, z], frange]
                        ]]
            ]]

ternary density plot on ContourPlot3D

The rest work is to transform the Graphics3D to Graphics:

opt3d = {VertexNormals, BoxRatios, Lighting, RotationAction, SphericalRegion};
optboth = {PlotRange, PlotRangePadding};

trigplot2d = 
    trigplot3d /. GraphicsComplex[pts_, others__] :> GraphicsComplex[
                            # + {1/2, 1/(2 Sqrt[3])} & /@ (
                                     ((pts/Sqrt[2]).
                                      RotationMatrix[{{1, 1, 1}, {0, 0, 1}}]\[Transpose]
                                     )[[All, 1 ;; 2]].
                                     RotationMatrix[-((3 π)/4)]\[Transpose]
                                    ),
                            others] /.
                Rule[opt_, _] /; MemberQ[opt3d, opt] :> Sequence[] /.
            Rule[opt_, v_] /; MemberQ[optboth, opt] :> Rule[opt, v[[1 ;; 2]]] /.
        Graphics3D -> Graphics;

Using Michael E2's nice ticking function triangleTicks:

triangleTicks[trigplot2d]

final ternary density plot

$\endgroup$
18
$\begingroup$

I chose to start my solution from ternary points as opposed to a plot in cartesian points. My concern with the latter route is that 1 of the axes (the hypotenuse of the original triangle) is larger than the x and y axes and therefore is transformed differently from these two axes.

First, the meat of the transformation; I find the transformation function to convert a ternary point to a point on the {{1,0},{0,1},{0.5,Sqrt[3]/2}} triangle and create a grid ternary points {a,b,c} that obey a + b + c = 1.

(* find the transformation function *)
tf = FindGeometricTransform[{{0, 0, 0}, {1, 0, 0}, {0.5, Sqrt[3]/2,0}}, 
  {{1, 0, 0}, {0, 1, 0}, {0, 0, 1}}][[2]];
(* function to make cartesian coordinates out of ternary coordinates *)
ccoords[pt_] := tf[pt][[{1, 2}]];
(* Create a set of coordinates that total 1 *)
tcoords = 
  DeleteCases[Tuples[Range[0, 100, 1], 3], x_ /; Total[x] != 100]/100;

Next I make several functions to create tickmarks. These are a bit cumbersome because I first tried to make them general (any number of tickmarks) but backed away from that idea once I realized it was over my head:

Clear[tickPoints, tickMarks, tickLabels, axesLabels, region]
(* Now assuming 10 tick marks, not debugged with num =!= 10 *)
tickPoints[poly_, num_: 10] := Flatten[Map[
    (* Segment a line *) 
    Table[
      poly[[#[[1]]]] + 1/num  i (poly[[#[[2]]]] - poly[[#[[1]]]]), {i,
        1, num}] &,
    (* Map over all faces, uses same number of ticks per face, 
    not equidistant segments *)
    Table[{i, i + 1}, {i, 1, 2}]~Join~{{3, 1}}], 1];
(* Make tick marks angled such that the point along the ternary axes *)


tickMarks[poly_, num_: 10] := (GeometricTransformation[
      Line[#], ScalingTransform[0.25, #[[2]] - #[[1]], #[[1]]]] & /@ 
    Quiet@Drop[
      With[{list = tickPoints[region, 10]},
       MapIndexed[{#1,

          Flatten[RotationTransform[-60 Degree, #1][
            list[[#2 + 1]]]]} &, list]
       ], {10, -1, 10}]);

(* Create tick labels for the ticks - note I do not use tick marks on \
the vertices *)
tickLabels[num_: 10] := Module[{t},
   t = Quiet@Drop[
      With[{list = tickPoints[region, num]}, 
       MapIndexed[
         Flatten[RotationTransform[-90 Degree, #1][
            tickPoints[region][[#2 + 1]]]] &, tickPoints[region]][[
        1 ;; -2]]], {num, -1, num}];
   MapThread[
    Text[N@#1, #2] &, {Flatten@
      ConstantArray[Range[0 + 1/num, 1 - 1/num, 1/num], 3], t}]];
(* Instead of vertex tick marks, I use a separate function and call \
these labels *)
axesLabels[a_, b_, c_] := {Text[a, {-0.01, 0}, {1, 0}], 
   Text[b, {1.01, 0}, {-1, 0}], Text[c, {0.5, 1.02 Sqrt[3]/2}]};
(* These functions require that a polygon is defined *)
region = {{0, 0}, {1, 0}, {0.5, Sqrt[3]/2}, {0, 0}};

Some trivial functions to show that the plotting makes sense:

tfunc[a_, b_, c_] := a;

ListDensityPlot[
  Partition[Flatten@Transpose[{ccoords /@ tcoords, tfunc @@@ tcoords}], 3],
    ColorFunction -> (Hue[0.85 #] &),
    Epilog -> {Line@region, Black, Quiet@tickMarks[region, 10], tickLabels[], 
      axesLabels["A", "B", "C"]}, Frame -> None, 
    PlotRange -> {{-0.15, 1.15}, {-0.15, 1.15}}, 
    PlotLegends -> Automatic]

Mathematica graphics

tfunc[a_, b_, c_] := Sin[Pi a] + Sin[2 Pi b] + Sin[3 Pi c];

Mathematica graphics

I haven't done any thorough testing at this point; however I can Export these images without problem.

$\endgroup$
1
  • $\begingroup$ It appears that your tick marks are not parallel to the side they relate to, i.e. they are 60 degrees off. Compare yours with the other answers. $\endgroup$ Jun 29, 2015 at 12:15
12
$\begingroup$

First transform cartesian coordinates to simplex coordinates and then apply the function f to get the $z$-values:

f[{a_, b_, c_}] := Which[ (* simple z-values for testing *)
       a >= 1/2, 0,
       b >= 1/2, 1,
       c >= 1/2, 2,
       True, 3]; 

(* transform simplex coordinates to cartesian ones *)
(* using the following simplex vertices: {{0, 0}, {1, 0}, {1/2, Sqrt[3]/2}} *)
transform[{x_, y_}] := {1, 0, 0} + x*{-1, 1, 0} + y*{-1/Sqrt@3, -1/Sqrt@3, 2/Sqrt@3};

(* test whether a point is inside the simplex *)
insideQ[pt_List] := (Total@pt==1 && And@@NonNegative@pt);

ContourPlot[f@transform@{x, y}, {x, 0, 1}, {y, 0, 1}, 
   RegionFunction -> (insideQ@transform@{#1, #2} &), 
   BoundaryStyle -> Black,
   MaxRecursion -> 3]

Mathematica graphics

Using the same f function as Michael E2:

f[{p_, q_, r_}] := r Sin[10 p]^2 + (1 - r) r Cos[20 q]^2;
{
 DensityPlot[f@{x, y, 1 - x - y}, {x, 0, 1}, {y, 0, 1}, 
  ColorFunction -> (Hue[0.85 #] &), 
  RegionFunction -> (#1 <= 1 - #2 &)],
 DensityPlot[f@transform@{x, y}, {x, 0, 1}, {y, 0, 1}, 
  ColorFunction -> (Hue[0.85 #] &), 
  RegionFunction -> (insideQ@transform@{#1, #2} &), 
  BoundaryStyle -> Black]
 }

Mathematica graphics

$\endgroup$
2
  • $\begingroup$ (+1) For comparison with Michael's answer one should define f as f[{p_, q_, r_}] := r Sin[10 p]^2 + (1 - r) r Cos[20 q]^2;. $\endgroup$ Jan 4, 2014 at 10:07
  • $\begingroup$ Thanks @Alexey, I've included it. $\endgroup$ Jan 4, 2014 at 10:44
2
+75
$\begingroup$

Have a look for example at a tutorial for what is behind the question: Ternary Contour. So this works not on functions but on numerical data series from tables. Like in this demonstration composition of vapor and liquid phases for a ternary ideal mixture this is then intepreted as function of values, for example an interpolation function, over the composition modelation of the three composites of a ternary real or ideal mixture.

From the source code of the demonstration in the DensityPlot replace the Norm with the function of Your interest and You are done.

To do some nicer annotation of what is interesting in Your ternary mixture density plot make use of the code of the demonastration basic ternary phase diagram. This can be change to a manipulation easily.

So a solution without interpolation is:

Manipulate[
 Module[{x1, x2, x3, y1, y2, y3},
  y1 = \[Alpha]13 x1/(\[Alpha]13 x1 + \[Alpha]23 x2 + x3);
  y2 = \[Alpha]23 x2/(\[Alpha]13 x1 + \[Alpha]23 x2 + x3);
  x3 = 1 - x1 - x2; y3 = 1 - y1 - y2;
  x1 = 0.5` X1 - 0.2886751345948129` X2;
  x2 = 0.5773502691896258` X2; 
  Show[DensityPlot[(1 - X1 - X2)*
      Sin[10 Norm[{x1, x2, x3} - {y1, y2, y3}]]^2 + (X1 + X2) (1 - 
        X1 - X2) Cos[20 Norm[{x1, x2, x3} - {y1, y2, y3}]], {X1, 0, 
     2}, {X2, 0, Sqrt[3.0]}, ImageSize -> {450, 450}, 
    ColorFunction -> "Rainbow", 
    RegionFunction -> 
     Function[{y1, y2}, 
      y2 - Sqrt[3.0] < Sqrt[3.0] (y1 - 1) && 
       y2 - Sqrt[3.0] < -Sqrt[3.0]/1 (y1 - 1)], 
    PlotLegends -> Automatic, PlotRange -> Full], g1, g2, g3, 
   Graphics[{
     Text[Style["B", Italic, 18, "TR"], {1.00, Sqrt[3.0] + 0.1}],
     Text[Style["C", Italic, 18], {-0.05, -0.05}],
     Text[Style["A", Italic, 18], {2.05, -0.05}]}],
   PlotRange -> All, Frame -> False, Axes -> False]],
 Style["relative volatility", Bold],
 {{\[Alpha]13, 1.5, "between A and C"}, 0.1, 3, 0.01, 
  Appearance -> "Labeled"},
 {{\[Alpha]23, 2.5, "between B and C"}, 1, 4.5, 0.01, 
  Appearance -> "Labeled"},
 ControlPlacement -> Top,
 Initialization :> (
   h = Graphics[{Thickness[0.01], Line[{{0, 0}, {2, 0}}], 
      Line[{{0, 0}, {1, Sqrt[3.]}}], Line[{{2, 0}, {1, Sqrt[3.]}}]}, 
     AspectRatio -> 1];
   g1 = Graphics[{Flatten[
       Table[{Black, 
         Line[{{First[x /. NSolve[Sqrt[3] (x) == i , x]], 
            i}, {First[x /. NSolve[Sqrt[3] (2 - x) == i, x]], i}}], 
         Text[i/Sqrt[3], {2 i/Sqrt[3], -0.1}]}, {i, 0, Sqrt[3], 
         0.1 Sqrt[3]}]]}];
   g2 = Graphics[{Flatten[
       Table[{Black, 
         Line[{{First[x /. NSolve[Sqrt[3] (2 - x) == i, x]], 
            i }, {First[
             x /. NSolve[Sqrt[3] (x) == 2 (Sqrt[3] - i), x]], 0}}], 
         Text[i/Sqrt[
            3], {First[x /. NSolve[Sqrt[3] (2 - x) == i, x]] + 0.1, 
           i}]}, {i, 0, Sqrt[3], 0.1 Sqrt[3]}]]}];
   g3 = Graphics[{Flatten[
       Table[{Black, 
         Line[{{First[x /. NSolve[Sqrt[3] (x) ==  i , x]], 
            i}, {First[
             x /. NSolve[Sqrt[3] (2 - x) == 2 (Sqrt[3] - i), x]], 
            0}}], Text[
          i/Sqrt[3], {First[x /. NSolve[Sqrt[3] x ==  i, x]] - 0.1, 
           i}]}, {i, 0, Sqrt[3], 0.1 Sqrt[3]}]]}];)]

enter image description here

The interpolation has to be done on the coordinates used in the ternary density plot. The volatility is a composition parameter pair setting locations in the ternary density plot. Usually only the line in the demonstration basic ternary phase diagram are measured until the density plot is defined complete.

enter image description here

The example image shown looks very like the example from the documentation page of the built-in Interpolation for the 2D case:

Flatten[Table[{{x, y}, LCM[x, y]}, {x, 8}, {y, 8}], 1]
f = Interpolation[%]
ContourPlot[-f[x, y], {x, 1, 8}, {y, 1, 8}, 
 ColorFunction -> "Rainbow", PlotLegends -> Automatic]

enter image description here

This has some noise in the image given in the question.

My answer does not in depth reproduce the original process of the image but it shows up in which perspective the concepts based on paradigms are different in Mathematica and show open that the indepth methodologies are again not longer present in Mathematica since the table like in Origin is passed away again. This is done in other answers like how can i create an advanced grid interface. Mathematica has got the how-can-i-add-column-rearrangement-by-mouse-dragging-to-my-dataset-display-funct. The situation might be different on other OSses.

In Mathematica instead of drag-and-drop a programmatical solution will be favoured.

The biggest confusion is the receipt to conduct the interpolation. In the tutorials form Origin these are just one dimensional series of data points.

$\endgroup$
1
  • $\begingroup$ Interesting. So, suppose we have a list with X,Y,Z values (e.g. {{Xlist},{Ylist},{Zist}}), with the elements ordered (and equal length of the lists), and the constraint the corresponding entries sum up to one. Which of the functions in your code could take this list and make the ternary plot? Thanks! $\endgroup$ Feb 25, 2021 at 21:48
2
$\begingroup$

Update 1

With the vertices of an $n$-ary plot given by $$\{\sec(\pi/n)(\cos(2i\pi/n),\sin(2i\pi/n))\}_{i=1}^n,$$ the normalized altitude of a point to the $i$th edge is given by $$\frac1n-\frac{\sec(\pi/n)}{2n}\left(x\cos\frac{2i\pi}n+x\cos\frac{2(i+1)\pi}n+y\sin\frac{2i\pi}n+y\sin\frac{2(i+1)\pi}n\right).$$ That is, for a fixed $(x,y)$ and $n$, the sum of these altitudes is $1$. This makes our $n$-ary plot function
naryplot[n_,func_]:=DensityPlot[func@Table[1/n-Sec[\[Pi]/n]/(2n)(
  Cos[(2i \[Pi])/n]x+Cos[(2(1+i)\[Pi])/n]x+ 
  Sin[(2i \[Pi])/n]y+Sin[(2(1+i)\[Pi])/n]y
),{i,0,n-1}],{x,y}\[Element]Polygon[Table[
  Sec[\[Pi]/n]{Cos@#,Sin@#}&@(2i \[Pi]/n)
,{i,n}]],BoundaryStyle->Black,Frame->False]/;(IntegerQ@n&&n>2)

which is quite a bit simpler than my original math. It is of course possible to change the ColorFunction and make other plot tweaks. It should be noted that numerical stability is quite poor, which can be easily seen by calling naryplot[3,Plus@@#&] which should be a constant plot (it is instead splotchy). This can be helped by wrapping the altitude math in a Simplify, since choosing a particular $n$ allows Mathematica to perform tremendous simplification of the trig functions. My manual sampling function was symmetric, which (I think) kept instability uniform, while Mathematica's triangulation has far less predictable error.

With the self contained

naryplot[n_,func_, colfunc_:Automatic,plotpoints_:Automatic]:=DensityPlot[func@
Table[Simplify[1/n-Sec[\[Pi]/n]/(2n)(Cos[(2i \[Pi])/n]x+Cos[(2(1+i)\[Pi])/n]x+ 
Sin[(2i \[Pi])/n]y+Sin[(2(1+i)\[Pi])/n]y)],{i,0,n-1}],{x,y}\[Element]Polygon[
Table[Sec[\[Pi]/n]{Cos@#,Sin@#}&@((2i \[Pi])/n),{i,n}]],BoundaryStyle->Black,
Frame->False,ColorFunction->colfunc,PlotPoints->plotpoints]/;(IntegerQ@n&&n>2)

we can reproduce

3ary1

with

naryplot[3, #[[3]] Sin[10 #[[1]]]^2 + (1-#[[3]])#[[3]] Cos[20 #[[2]]]^2&,Hue,100]

and

3ary1

with

naryplot[3,Sin[Pi #[[1]]] + Sin[2 Pi #[[2]]] + Sin[3 Pi #[[3]]],Hue,100]

and the examples of $(n>3)$-ary plots are similar.


Original

It's a geometric fact for a point in a polygon, the sum of altitudes is constant. We can make an expression which maps a cartesian point to one of the entries in its $n$-ary tuple, knowing that minimization of point-line distance is quadratic:

Simplify[Sqrt[(((1 - #) Cos[(2 a \[Pi])/nsides] + # Cos[(
        2 (1 + a) \[Pi])/nsides]) Sec[\[Pi]/nsides] - 
   x)^2 + (Sec[\[Pi]/
     nsides] ((1 - #) Sin[(2 a \[Pi])/nsides] + # Sin[(
        2 (1 + a) \[Pi])/nsides]) - y)^2] &@
Simplify[(-#[[2]]/(2 #[[3]])) &@
CoefficientList[
 Expand[(((1 - t) Cos[(2 a \[Pi])/nsides] + 
        t Cos[(2 (1 + a) \[Pi])/nsides]) Sec[\[Pi]/nsides] - 
     x)^2 + (Sec[\[Pi]/
       nsides] ((1 - t) Sin[(2 a \[Pi])/nsides] + 
        t Sin[(2 (1 + a) \[Pi])/nsides]) - y)^2], t]]]

Blegh, but the result is actually pretty nice. I've assumed polygons are given in polar by $\sec(\text{mod}(\theta+2\pi/n,2\pi/n)-2\pi/n)$ so the resultant $n$-ary tuples sum to $n$; we normalize.

naryconvexcoef[nsides_, a_, x_, y_] := 
 1/(4 nsides) \[Sqrt](Csc[(2 \[Pi])/
   nsides]^2 ((x Cos[(4 a \[Pi])/nsides] - 
      x Cos[(4 (1 + a) \[Pi])/nsides] + 
      2 Cos[((3 + 2 a) \[Pi])/nsides] - 
      2 Cos[(\[Pi] - 2 a \[Pi])/nsides] + 
      2 y Sin[(2 \[Pi])/nsides] + y Sin[(4 a \[Pi])/nsides] - 
      y Sin[(4 (1 + a) \[Pi])/nsides])^2 + (-y Cos[(4 a \[Pi])/
        nsides] + y Cos[(4 (1 + a) \[Pi])/nsides] - 
      2 x Sin[(2 \[Pi])/nsides] + x Sin[(4 a \[Pi])/nsides] - 
      x Sin[(4 (1 + a) \[Pi])/nsides] + 
      2 Sin[((3 + 2 a) \[Pi])/nsides] + 
      2 Sin[(\[Pi] - 2 a \[Pi])/nsides])^2)) /; (IntegerQ@nsides &&
 nsides > 2 && IntegerQ@a)
naryconvexcoef[nsides_, a_, pt_] := 
 naryconvexcoef[nsides, a, pt[[1]], 
  pt[[2]]] /; (IntegerQ@nsides && nsides > 2 && IntegerQ@a)

Here's a demo of the tuple construction

Manipulate[
With[{ang = If[p == {0, 0}, 0, Mod[ArcTan @@ p, 2 \[Pi]]], 
angi = Floor[(n If[p == {0, 0}, 0, Mod[ArcTan @@ p, 2 \[Pi]]])/(
 2 \[Pi])], tuple = naryconvexcoef[n, #, p] & /@ Range[0, n - 1]},
Show[
Graphics[{Text[tuple, p + .2], Text[Plus @@ tuple, p - .2]}, 
PlotRange -> 2],
PolarPlot[
Sec[Mod[\[Theta] + (2 \[Pi])/n, (2 \[Pi])/n] - \[Pi]/
  n], {\[Theta], 0, 2 \[Pi]}]
]], {{p, {1, 0}}, Locator}, {n, 3, 10, 1}]

We make a function to sample polygons:

samplepolyshell[nsides_, density_] := 
 If[density == 0, {{0, 0}}, 
  Join @@ Table[
   Sec[\[Pi]/
     nsides] ((1 - #) {Cos[(2 \[Pi] a)/nsides], 
        Sin[(2 \[Pi] a)/nsides]} + # {Cos[(2 \[Pi] (a + 1))/
         nsides], Sin[(2 \[Pi] (a + 1))/nsides]}) & /@ (
  Range[0, density - 1]/density), {a, 0, 
  nsides - 1}]] /; (IntegerQ@nsides && nsides > 2 && 
IntegerQ@density && density >= 0)
samplepolywhole[nsides_, density_] := 
 Table[(a/density) samplepolyshell[nsides, a], {a, 0, 
  density}] /; (IntegerQ@nsides && nsides > 2 && IntegerQ@density && density >= 0)

And finally make a plotting function

naryplot[n_, func_, density_ : 10, colfunc_ : Automatic] := 
ListDensityPlot[
 Append[#, func@Table[naryconvexcoef[n, i, #], {i, 0, n - 1}]] & /@ 
 samplepolywhole[n, density], 
 ColorFunction -> colfunc] /; (IntegerQ@n && n > 2 && 
  IntegerQ@density && density >= 0)

You can plot the sum of the tuple entries

naryplot[5,Plus@@#&]

5aryplot

or a single tuple entry

naryplot[7,#[[3]]&,5,"FruitPunchColors"]

7aryplot

or a weird function

naryplot[11,Plus@@Table[Sin[i^2 #[[i]]],{i,Length@#}]&,Hue[.85#]&]

enter image description here

I forgot to add an even one, here's

naryplot[11,#[[1]]-#[[4]]&,30]

6aryplot

This could be made a lot faster and prettier by avoiding ListDensityPlot, probably. I'm missing the ticks and grid, but I'll fix these when I have time.

$\endgroup$
1
  • $\begingroup$ I haven't thought it through, but my intuitive feeling is the general n-ary problem could be related to or represented by simplex spline (chpt. 18). $\endgroup$
    – Silvia
    Mar 3, 2021 at 19:33

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.