2
$\begingroup$

so I wondered if there is a way to use histogram list such that it doesn't bin in quadrat mode, but given a set of 3D points, could bin over a tessellation of some regular tetrahedrons/hexagons/spheres?

$\endgroup$
12
  • 2
    $\begingroup$ This might finally help someone. (It was originally written due to an embarrassing misunderstanding.) $\endgroup$
    – Szabolcs
    Commented Feb 26, 2019 at 16:25
  • $\begingroup$ Amazing! I'm going to see if I can make it work in 3D, thanks @Szabolcs $\endgroup$
    – MKF
    Commented Feb 26, 2019 at 16:27
  • $\begingroup$ Can itgeneralise to 3D? and with the tally function, can we only make it tetrahedral, with colours defined by transparency instead? $\endgroup$
    – MKF
    Commented Feb 26, 2019 at 16:29
  • $\begingroup$ You might consider SmoothKernelDistribution. It works in all dimensions. $\endgroup$
    – JimB
    Commented Feb 26, 2019 at 16:38
  • 1
    $\begingroup$ Can you tile space with tetrahedra? I don't think it's possible. $\endgroup$
    – Szabolcs
    Commented Feb 26, 2019 at 18:58

3 Answers 3

3
$\begingroup$
th = Tetrahedron[{{0, 0, 0}, {1, 0, 0}, {1/2, Sqrt[3]/2, 0}, {1/2, Sqrt[3]/6, Sqrt[6]/3}}];
bins = N @ NestedSymmetricSubdivision[th, 3];
centers = RegionCentroid /@ bins;
nf = Nearest[centers -> "Index"];

SeedRandom[1]
rp = RandomPoint[Cuboid[], 3000];
tF = FindGeometricTransform[th[[1]], Tetrahedron[][[1]]][[2]];
transformed = tF /@ (Normalize[#, Total[#]/Max[#] &] & /@ rp);
Row[{Graphics3D[{Blue, Point@rp, Opacity[.05], Cuboid[]}, ImageSize -> 400], 
  Graphics3D[{Red, Point@transformed, Opacity[.05], th}, 
   BoxRatios -> 1, ImageSize -> 400]}]

enter image description here

groups = GatherBy[transformed, nf[#, 1] &];
tallies = {Rescale[Length /@ groups], bins[[nf[#[[1]], 1]]] & /@ groups};
Show[Graphics3D[{FaceForm[], th, 
   Transpose[{FaceForm[Opacity[Rescale[#, {0, 1}, {0.05, .25}], Blue]]&/@#, #2}&@@tallies]},
  Boxed -> True, BoxRatios -> 1], 
 ListPointPlot3D[groups, PlotStyle -> (ColorData[{"Rainbow", "Reversed"}]/@ tallies[[1]])],
  ImageSize -> Large]

enter image description here

$\endgroup$
10
  • $\begingroup$ Wow, your skills know no bounds, massive massive thanks for figuring these out! $\endgroup$
    – MKF
    Commented Mar 10, 2019 at 13:23
  • $\begingroup$ Thank you @MKF for the kind words. $\endgroup$
    – kglr
    Commented Mar 10, 2019 at 13:24
  • $\begingroup$ I feel I was little help that's all $\endgroup$
    – MKF
    Commented Mar 10, 2019 at 13:24
  • 1
    $\begingroup$ In any case, truly amazing @kglr $\endgroup$
    – MKF
    Commented Mar 10, 2019 at 13:31
  • 1
    $\begingroup$ @MKF, yes; thank you. Fixed now. $\endgroup$
    – kglr
    Commented Mar 10, 2019 at 14:14
1
$\begingroup$

This isn't an answer, just a response to the previous comment

SymmetricSubdivision[Tetrahedron[pl_], k_] /; 0 <= k < 2^Length[pl] :=
  Module[{n = Length[pl] - 1, i0, bl, pos}, i0 = DigitCount[k, 2, 1];
  bl = IntegerDigits[k, 2, n];
  pos = FoldList[If[#2 == 0, #1 + {0, 1}, #1 + {1, 0}] &, {0, i0}, 
    Reverse[bl]];
  Tetrahedron@Map[Mean, Extract[pl, #] & /@ Map[{#} &, pos + 1, {2}]]]

NestedSymmetricSubdivision[Tetrahedron[pl_], level_Integer] /; 
  level == 0 := Tetrahedron[pl]
NestedSymmetricSubdivision[Tetrahedron[pl_], level_Integer] /; 
  level > 0 := 
 Flatten[NestedSymmetricSubdivision[
     SymmetricSubdivision[Tetrahedron[pl], #], level - 1] & /@ 
   Range[0, 7]]

Graphics3D[
 NestedSymmetricSubdivision[
  Tetrahedron[{{0, 0, 0}, {1, 0, 0}, {1/2, Sqrt[3]/2, 0}, {1/2, Sqrt[
     3]/6, Sqrt[6]/3}}], 3], BaseStyle -> Opacity[0], Boxed -> False]

The mesh I wish to histogram over

$\endgroup$
13
  • $\begingroup$ So the question is the following now, is there a way to convert this into a mesh, and tally all the points inside each mini tetrahedron, so that each tetrahedron has different opacity based on the number of points inside each region? $\endgroup$
    – MKF
    Commented Feb 27, 2019 at 13:55
  • $\begingroup$ My guess is yes using ListDensityPlot3D[HistogramList[pts, 10][[2]], DataRange -> the region of the tetrahedron] but with the above converted into a mesh somehow $\endgroup$
    – MKF
    Commented Feb 27, 2019 at 13:56
  • 1
    $\begingroup$ You can easily find out if a point is in a tetrahedron using RegionMember[Tetraherdon[{....}]][pointOfInterest]. This would be easy to repurpose for tallying the points in each tetrahedron, though it might be slow. $\endgroup$
    – N.J.Evans
    Commented Feb 27, 2019 at 16:26
  • 2
    $\begingroup$ Taking your own code, look at Graphics3D /@ NestedSymmetricSubdivision[ Tetrahedron[{{0, 0, 0}, {1, 0, 0}, {1/2, Sqrt[3]/2, 0}, {1/2, Sqrt[3]/6, Sqrt[6]/3}}], 1]. It's quite clear from simple visual inspection that the tetrahedra are not identical. We can verify that they have the same Volume, but not the same SurfaceArea or the same shape. Of course we can still use them for binning if we want to. $\endgroup$
    – Szabolcs
    Commented Feb 28, 2019 at 14:49
  • 2
    $\begingroup$ If you can determine a center for each cell (tetrahedron or other) such that the cell would be a Voronoi cell, then you can use the same approach as in the code I linked: use Nearest to determine which cell each binned point belongs to. $\endgroup$
    – Szabolcs
    Commented Feb 28, 2019 at 14:50
0
$\begingroup$

So I have some random points that lie in the tetrahedron, Random points,

and also calculate the centres of the tetraminos using Mean.

I apply indices = First /@ nf /@ cloud as in @Szabolcs code and now want to bin the points in each tetramino bin.

Here is histogram of the indices to check things are happening

Histogram

I have tried

tally = Tally[indices];

ListDensityPlot3D[Join[cloud, List /@ Sort[tally][[All, 2]], 2],
  ColorFunction -> (ColorData["BeachColors"][1 - #] &)]

To bin the points but to no avail.

As for @N.J.Evans response, I define RegionMemberFunctions as

Map[RegionMember, NestedSymmetricSubdivision[
 Tetrahedron[{{0, 0, 0}, {1, 0, 0}, {1/2, Sqrt[3]/2, 0}, {1/2, Sqrt[
    3]/6, Sqrt[6]/3}}], 3]];

But if I try to now tally/bin the points with

    Table[Map[regionmemberfunctions[[i]], cloud], {i, 1, 
   Length[NestedSymmetricSubdivision[
     Tetrahedron[{{0, 0, 0}, {1, 0, 0}, {1/2, Sqrt[3]/2, 0}, {1/2, Sqrt[
        3]/6, Sqrt[6]/3}}], 3]]}];

It takes forever... Any ideas greatly appreciated!

$\endgroup$
2
  • $\begingroup$ I think perhaps binning over the tetraminos and using something like this is great mathematica.stackexchange.com/questions/17260/… $\endgroup$
    – MKF
    Commented Mar 3, 2019 at 12:05
  • $\begingroup$ And maybe via Which or Count there could be some success $\endgroup$
    – MKF
    Commented Mar 3, 2019 at 13:47

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.