13
$\begingroup$

so this is currently what I'm building

triangles[n_Integer?(# >= 2 &)] :=
  (*the subdivision by elementary geometry*)
  Flatten[ 
    Union[
      Table[
        Polygon[
          {{(i + j/2)/n, Sqrt[3]/2 j/n},
           {(i + 1 + j/2)/n, Sqrt[3]/2  j/n},
           {(i + 1/2 + j/2)/n, Sqrt[3]/2 (j + 1)/n}}],
        {j, 0, n - 1}, {i, 0, n - 1 - j}],
      Table[
        Polygon[
          {{(i + 1/2 + j/2)/n, Sqrt[3]/2 (j + 1)/n},
           {(i + 3/2 + j/2)/n, Sqrt[3]/2 (j + 1)/n},
           {(i + 1 + j/2)/n, Sqrt[3]/2 j/n}}],
        {j, 0, n - 1},{i, 0, n - 2 - j}]]]

(*Generate ternary frame*)
triangle = triangles[50];

(*acenters and acentroids match in this case*)
acoords = Table[triangle[[i]][[1]], {i, 1, Length[triangle]}];
acenters = Table[Mean[acoords[[i]]], {i, 1, Length[triangle]}];
acentroids = Table[RegionCentroid[triangle[[i]]], {i, 1, Length[triangle]}];

Using https://scicomp.stackexchange.com/questions/1473/sort-a-cloud-of-points-with-respect-to-an-unstructured-mesh-of-hexahedral-cells/1474#1474 I'm trying to recreate the following histogram module in R (https://stackoverflow.com/questions/26221236/ternary-heatmap-in-r):

cloud = RandomReal[{0, 1}, {1000, 2}];
indices = First /@ nf /@ cloud;
Histogram[indices];

tally = Tally[indices];

ListDensityPlot[Join[points, List /@ Sort[tally][[All, 2]], 2], 
  InterpolationOrder -> 0, 
  Epilog -> (Text[#2, points[[#1]]] & @@@ tally), 
  PlotRange -> {{-.5, 5}, {-.5, 5}}, Mesh -> All, 
  ColorFunction -> (ColorData["BeachColors"][1 - #] &)]

I think this will bin in hexagons, rather than triangles. Alternatively RegionMember might be the way

maps = Map[RegionMember, triangle];
counts = Table[Tally[Map[maps[[i]], cloud]], {i, 1, Length[maps]}]
$\endgroup$
6
  • 1
    $\begingroup$ Where is the definition on nf? And what is your question? $\endgroup$
    – m_goldberg
    Mar 9, 2019 at 14:42
  • $\begingroup$ nf = Nearest[N[points] -> Range@Length[points]];; I want to build the ternary plot as in stackoverflow.com/questions/26221236/ternary-heatmap-in-r $\endgroup$
    – MKF
    Mar 9, 2019 at 14:59
  • $\begingroup$ I spoke to Wolfram, they say RegionMember is computationally expensive, so I'm thinking of another way to check $\endgroup$
    – MKF
    Mar 9, 2019 at 16:48
  • 3
    $\begingroup$ Using maps[[i]] @ cloud instead of maps[[i]] /@ cloud will be orders of magnitude faster in the RegionMember approach. Of course using Nearest on the region centroids will be much faster than using RegionMember. $\endgroup$
    – Carl Woll
    Mar 9, 2019 at 17:36
  • $\begingroup$ Your definition o nf only begs the question — what is points. $\endgroup$
    – m_goldberg
    Mar 10, 2019 at 1:37

1 Answer 1

15
$\begingroup$
ClearAll[toSimplex, nF]
toSimplex = #[[1]] {1, 0} + #[[2]] {1, Sqrt@3}/2 &/@(Normalize[#, Total[#]/Max[#] &]&/@#)&;

n = 10;
centroids = N[RegionCentroid /@ triangles[n]];
nF = Nearest[centroids -> "Index"];

SeedRandom[1]
pts0 = RandomReal[{0, 1}, {1000, 2}];
pts = toSimplex @ pts0;
groups = GatherBy[pts, nF[#, 1] &];
tallies = {Rescale[Length /@ groups], triangles[n][[nF[#[[1]], 1][[1]]]] & /@ groups};
Show[Graphics[Transpose[{ColorData["Rainbow"] /@ #, #2} & @@ tallies], Frame -> True], 
 ListPlot[Tooltip[#, Length@#] & /@ groups, 
  PlotStyle -> (ColorData[{"Rainbow", "Reversed"}] /@ (tallies[[1]]))]]

enter image description here

Alternatively, you can use GeoHistogram which allows triangular bins:

Show[GeoHistogram[Reverse /@ pts, N[triangles[10]],
  ColorFunction -> "Rainbow", PlotStyle -> Directive[Opacity[1], EdgeForm[White]],
  PlotRange -> All, Frame -> True, GeoBackground -> None, 
  GeoRange -> {{0, 1}, {0, 1}} ], 
 ListPlot[Tooltip[#, Length@#] & /@ groups, 
  PlotStyle -> (ColorData[{"Rainbow", "Reversed"}] /@ (tallies[[1]]))], 
  PlotRange -> All, AspectRatio -> 1, ImageSize -> Large]

enter image description here

To color by opacity:

Show[GeoHistogram[Reverse /@ pts, N[triangles[10]], 
  ColorFunction -> (Opacity[Rescale[#, {0, 1}, {.1, 1}], Red] &), 
  PlotStyle -> EdgeForm[Darker @ Red], 
  PlotRange -> All, Frame -> True, GeoBackground -> None, 
  GeoRange -> {{0, 1}, {0, 1}}], 
 ListPlot[pts, PlotStyle -> Directive[PointSize[Small], Black]], 
 AspectRatio -> 1, PlotRange -> All]

enter image description here

$\endgroup$
7
  • $\begingroup$ Nice! Is there an easy way to avoid the boundary effect in the GeoHistogram approach? $\endgroup$
    – Chris K
    Mar 10, 2019 at 8:59
  • 1
    $\begingroup$ @ChrisK, it turned out to be easier than I thought:) $\endgroup$
    – kglr
    Mar 10, 2019 at 9:02
  • $\begingroup$ @kglr that is amazing! I hope my bits and pieces made sense, but this is truly an elegant solution. thanks so much! $\endgroup$
    – MKF
    Mar 10, 2019 at 9:41
  • 1
    $\begingroup$ @MKF, my pleasure. Thank you for a great question and the accept. $\endgroup$
    – kglr
    Mar 10, 2019 at 9:45
  • $\begingroup$ @kglr, currently the bins are coloured by Rainbow; is there a way to colour by opacity? $\endgroup$
    – MKF
    Mar 10, 2019 at 9:49

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.