Custom 3d histogram

Question

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?

This might finally help someone. (It was originally written due to an embarrassing misunderstanding.) — Szabolcs, Feb 26 '19 at 16:25
Amazing! I'm going to see if I can make it work in 3D, thanks @Szabolcs — MKF, Feb 26 '19 at 16:27
Can itgeneralise to 3D? and with the tally function, can we only make it tetrahedral, with colours defined by transparency instead? — MKF, Feb 26 '19 at 16:29
You might consider SmoothKernelDistribution. It works in all dimensions. — JimB, Feb 26 '19 at 16:38
In 3D, this could in principle be opaque right? because you would be looking at regions hidden within some volume that already has points in it - I guess you would need an opacity option on the distribution somehow — MKF, Feb 26 '19 at 16:51
Actually I think it would be best to bin in terms of tetrahedrons — MKF, Feb 26 '19 at 16:53
I see the Sierpinski mesh https://reference.wolfram.com/language/ref/SierpinskiMesh.html and wonder if this is possible — MKF, Feb 26 '19 at 17:40
Seems related! https://mathematica.stackexchange.com/questions/167819/elementmesh-from-tetrahedron-subdivision — MKF, Feb 26 '19 at 17:55
Can you tile space with tetrahedra? I don't think it's possible. — Szabolcs, Feb 26 '19 at 18:58
You can and I just did it, I will forward it on in an hour or so! — MKF, Feb 26 '19 at 19:30
No, it's not possible to tile space with identical tetrahedra. — Szabolcs, Feb 26 '19 at 20:24
I mean sure, if you don't allow them to flip right. But if some are flipped, its like a 3d Zelda symbol — MKF, Feb 26 '19 at 20:29

kglr · Accepted Answer · 2019-03-10T14:14:16.327

3

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]}]

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]

edited Mar 10 '19 at 14:14

answered Mar 10 '19 at 13:13

kglr

394,356
18
477
896

Wow, your skills know no bounds, massive massive thanks for figuring these out! – MKF Mar 10 '19 at 13:23
Thank you @MKF for the kind words. – kglr Mar 10 '19 at 13:24
I feel I was little help that's all – MKF Mar 10 '19 at 13:24
1

In any case, truly amazing @kglr – MKF Mar 10 '19 at 13:31
@MKF, thank you for the accept. Btw, can I suggest that you revisit some of your older questions to check if any of the answers are worth accepting? – kglr Mar 10 '19 at 13:57
sure which ones? – MKF Mar 10 '19 at 13:57
@MKF, this, this, this, this and this have answers. – kglr Mar 10 '19 at 14:04
thank you, all sorted – MKF Mar 10 '19 at 14:05
by the way, how is tetrahedron defined for you? its just th right? – MKF Mar 10 '19 at 14:09
1

@MKF, yes; thank you. Fixed now. – kglr Mar 10 '19 at 14:14

score 1 · Answer 2 · answered Feb 27 '19 at 13:52

1

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]

answered Feb 27 '19 at 13:52

MKF

591
2
10

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? – MKF Feb 27 '19 at 13:55
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 – MKF Feb 27 '19 at 13:56
These are all tetrahedra, but they are not identical. Some have a different shape than others. When you mentioned histogram, I assumed you wanted identical shapes (possibly flipped or rotated), something in analogy with a 2D triangular lattice. – Szabolcs Feb 27 '19 at 14:30
My bad, Sorry for the confusion! I want to basically implement the technique you have somehow to the tetrahedron layout above; actually I think these are all identical up to reflections... – MKF Feb 27 '19 at 14:34
So if you plot a bunch of points in 3D which lie inside each mini tetramino, it does a very similar thing to ListDensityPlot3D[HistogramList[pts, 10][[2]], DataRange -> the region of the tetrahedron], or equivalently your tally function. The feature I want to change is not colour however, but opacity of each tetramino – MKF Feb 27 '19 at 14:35
1

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. – N.J.Evans Feb 27 '19 at 16:26
Sorry I'm not sure how this would be implemented, for one if points lie inside a tetramino, how does mathematica know which volume its in? – MKF Feb 28 '19 at 00:26
I thought about it, and I think I have an idea... – MKF Feb 28 '19 at 12:10
2

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. – Szabolcs Feb 28 '19 at 14:49
2

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. – Szabolcs Feb 28 '19 at 14:50
They are not the same shape? I need to check this xD thanks for the headsup! Maybe its just the angle, but they look symmetric to me... – MKF Feb 28 '19 at 18:01
Exactly that was my idea also to borrow your hexagonal method – MKF Feb 28 '19 at 18:02
Damn - they aren't symmetric :( – MKF Feb 28 '19 at 22:19

MKF · Answer 3 · 2019-03-03T13:33:19.127

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

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

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!

I think perhaps binning over the tetraminos and using something like this is great https://mathematica.stackexchange.com/questions/17260/3d-heatmap-density-plot — MKF, Mar 03 '19 at 12:05
And maybe via Which or Count there could be some success — MKF, Mar 03 '19 at 13:47

Custom 3d histogram

3 Answers3