4
$\begingroup$

Given a set $S_n$ of $n$ points selected uniformly at random in a $d$-ball, I want to estimate the average length of the longest side of a triangle having as vertices any three distinct points of $S_n$, when $n\gg d\gg 1$. Below you can find my approach, which unfortunately does not scale well with the number of points $n$ nor the number of dimensions $d$. Is it possible to improve it to make it more scalable?

n:=300; d:=30;
p := RandomPoint[Sphere[d], {n}];
x:=EuclideanDistance @@@ Subsets[p, {3}][[1 ;; , 1 ;; 2]]; 
y:=EuclideanDistance @@@ Subsets[p, {3}][[1 ;; , 2 ;; 3]]; 
z:=EuclideanDistance @@@ Drop[Subsets[p, {3}], None, {2}];
Mean[Map[Max, Transpose[{x,y,z}]]]
$\endgroup$
7
  • 1
    $\begingroup$ maybe n := 300; d := 30; p := RandomPoint[Sphere[d], {n/3, 3}]; xyz := Apply[EuclideanDistance, Subsets[#, {2}] & /@ p, {2}]; Mean[Map[Max, Transpose[xyz]]]? $\endgroup$
    – kglr
    Nov 30, 2020 at 22:00
  • $\begingroup$ Thank you @kglr ! Why is your approach so fast compare to mine? I am new to Wolfram Language. What is the most significant difference? $\endgroup$ Nov 30, 2020 at 23:10
  • $\begingroup$ Penelope, it is faster because it is not correct:) $\endgroup$
    – kglr
    Nov 30, 2020 at 23:11
  • 2
    $\begingroup$ Yes,you need Ball[] $\endgroup$
    – cvgmt
    Nov 30, 2020 at 23:24
  • 2
    $\begingroup$ since you defined p, x, y and z with SetDelayed, p is reevaluated every time it appears in x (similarly for y and z) . That is, a different p is used when you get x, y and z. $\endgroup$
    – kglr
    Nov 30, 2020 at 23:39

2 Answers 2

4
$\begingroup$

Maybe

SeedRandom[1]
n = 300; d = 30; 
p = RandomPoint[Sphere[d], {n, 3}]; 
xyz =  Apply[EuclideanDistance, Subsets[#, {2}] & /@ p, {2}];

Mean[Map[Max, xyz]]
1.5164

If we use Ball[d] instead of Sphere[d] we get 1.47179.

And a modification of your code (eliminating repeated invocations of Subsets[#,3] on p):

SeedRandom[1]
n = 300; d = 30;
p = RandomPoint[Sphere[d], {n}];
xyz = With[{s3 = Subsets[p, {3}]}, 
   Apply[EuclideanDistance, Subsets[#, {2}] & /@ s3, {2}]];
Mean[Map[Max, xyz]]
1.51594

If we replace Sphere[d] with Ball[d] we get 1.46985.

$\endgroup$
2
  • $\begingroup$ Thank you a lot @kglr ! $\endgroup$ Nov 30, 2020 at 23:49
  • 1
    $\begingroup$ @PenelopeBenenati, my pleasure. Thank you for the accept. $\endgroup$
    – kglr
    Nov 30, 2020 at 23:56
3
$\begingroup$

Seems no so effective.

Here we use RandomPoint to select uniform points in Ball[] and use RandomSample to select three points to construct a random triangle.

SeedRandom[1];
n = 300;
d = 30;
pts = RandomPoint[Ball[d], n];
Table[Max @@ 
   EuclideanDistance @@@ Subsets [RandomSample[pts, 3], {2}], {i, 
   200000}] // Mean

1.46926

$\endgroup$
5
  • $\begingroup$ Thank you very much @cvgmt ! This approach seems to be really fast! $\endgroup$ Dec 1, 2020 at 0:06
  • 1
    $\begingroup$ @PenelopeBenenati Thanks your vote up! $\endgroup$
    – cvgmt
    Dec 1, 2020 at 0:10
  • $\begingroup$ You are welcome! Why did you replace RandomChoice by RandomSample? $\endgroup$ Dec 1, 2020 at 0:12
  • 1
    $\begingroup$ @PenelopeBenenati since RandomSample select three distinguish points and RandomChoice cannot. Perhaps we also need to find a way to avoid co-line and select the real triangles. $\endgroup$
    – cvgmt
    Dec 1, 2020 at 0:15
  • $\begingroup$ I see, thank you! $\endgroup$ Dec 1, 2020 at 0:16

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.