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$
  • 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 '20 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$ – Penelope Benenati Nov 30 '20 at 23:10
  • $\begingroup$ Penelope, it is faster because it is not correct:) $\endgroup$ – kglr Nov 30 '20 at 23:11
  • 2
    $\begingroup$ Yes,you need Ball[] $\endgroup$ – cvgmt Nov 30 '20 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 '20 at 23:39
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$
  • $\begingroup$ Thank you a lot @kglr ! $\endgroup$ – Penelope Benenati Nov 30 '20 at 23:49
  • 1
    $\begingroup$ @PenelopeBenenati, my pleasure. Thank you for the accept. $\endgroup$ – kglr Nov 30 '20 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$
  • $\begingroup$ Thank you very much @cvgmt ! This approach seems to be really fast! $\endgroup$ – Penelope Benenati Dec 1 '20 at 0:06
  • 1
    $\begingroup$ @PenelopeBenenati Thanks your vote up! $\endgroup$ – cvgmt Dec 1 '20 at 0:10
  • $\begingroup$ You are welcome! Why did you replace RandomChoice by RandomSample? $\endgroup$ – Penelope Benenati Dec 1 '20 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 '20 at 0:15
  • $\begingroup$ I see, thank you! $\endgroup$ – Penelope Benenati Dec 1 '20 at 0:16

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.