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]}]
Improve this question
$\endgroup$
6
  • 1
    $\begingroup$ Where is the definition on nf? And what is your question? $\endgroup$
    – m_goldberg
    Commented 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
    Commented 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
    Commented 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
    Commented Mar 9, 2019 at 17:36
  • $\begingroup$ Your definition o nf only begs the question — what is points. $\endgroup$
    – m_goldberg
    Commented Mar 10, 2019 at 1:37

1 Answer 1

Reset to default
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

Improve this answer
$\endgroup$
7
  • $\begingroup$ Nice! Is there an easy way to avoid the boundary effect in the GeoHistogram approach? $\endgroup$
    – Chris K
    Commented Mar 10, 2019 at 8:59
  • 1
    $\begingroup$ @ChrisK, it turned out to be easier than I thought:) $\endgroup$
    – kglr
    Commented 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
    Commented Mar 10, 2019 at 9:41
  • 1
    $\begingroup$ @MKF, my pleasure. Thank you for a great question and the accept. $\endgroup$
    – kglr
    Commented 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
    Commented 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.