5
$\begingroup$

I am using Mathematica 11.1.1.0, on a Mac.

I have a list of 51 non-intersecting balls of radius 1. The total volume is easily computed exactly, $51\times 4\pi/3 \approx 213.6283004441$.

Now suppose I put the centers of the spheres in a file (attached, sphere.txt), and then I do this:

spheres = Import[NotebookDirectory[] <> "/spheres.txt", "Table"]
RegionMeasure[RegionUnion @@ (Ball[#, 1] & /@ spheres)]

The answer I get 202.068, has an error of 6%.

I need to compute region volumes of more complicated region unions that might overlap, but this result is discouraging. Is there a way to improve this result?

The example file spheres.txt can be downloaded from here. Note that the balls are touching at the surface, but the volume of the intersection between any pair is zero.

$\endgroup$
14
  • $\begingroup$ Are you sure that these balls are disjoint? RegionDisjoint @@ (Ball[#, 1] & /@ spheres) says False. That answer could be incorrect, but have you verified it? $\endgroup$
    – Szabolcs
    Commented Sep 5, 2017 at 9:54
  • 2
    $\begingroup$ As far as I can tell, it should be possible to do it in several ways: 1. Method -> {"NIntegrate", PrecisionGoal -> ...} (doesn't work) 2. NIntegrate[1, x \[Element] region, PrecisionGoal -> ...] (doesn't work well) 3. BoundaryDiscretizeRegion[..., MaxCellMeasure -> 0.1], then RegionMeasure (works, but very slow). Good question, I don't have a good answer. $\endgroup$
    – Szabolcs
    Commented Sep 5, 2017 at 10:34
  • 1
    $\begingroup$ @Szabolcs I had fixed that, but someone edited the question and posted a new pastebin link using the old link. Now I fixed it again. $\endgroup$
    – a06e
    Commented Sep 5, 2017 at 11:35
  • 1
    $\begingroup$ RegionMeasure is (afaik) based on DiscretizeRegion, which I've found to be problematic in many ways. One alternative might be with Volume, which seems to know about the exact volume of a sphere (and about sphere intersections). Specifically, Volume[Ball[spheres[[1 ;; k]], ConstantArray[1, k]]] manages to compute the area with an error of about 10^-7, but only up to k = 9 at which point it breaks. (Possibly related to @MichaelE2's comment?) $\endgroup$ Commented Sep 5, 2017 at 11:55
  • 2
    $\begingroup$ FWIW, in MMA 10.4 the result is 211.133, i.e., a relative error of around 1%. $\endgroup$ Commented Sep 5, 2017 at 12:38

1 Answer 1

2
$\begingroup$
$Version

(*  "11.1.1 for Mac OS X x86 (64-bit) (April 18, 2017)"  *)

balls = Flatten[
   Table[Ball[{x, y, z}], {x, 0, 20, 2}, {y, 0, 20, 2}, {z, 0, 20, 
     2}], 2];

Length[balls]

(*  1331  *)

ballsRgn = RegionUnion[balls];

Volume[ballsRgn] == Total[Volume /@ balls] == 
 Length[balls]*Volume[Ball[]]== 1331*4 Pi/3

(*  True  *)
$\endgroup$
9
  • $\begingroup$ Curious that this works fine. Any idea why my example fails? $\endgroup$
    – a06e
    Commented Sep 5, 2017 at 20:40
  • $\begingroup$ @becko - I was unable to access your data so I cannot know why it has problems. $\endgroup$
    – Bob Hanlon
    Commented Sep 5, 2017 at 20:53
  • $\begingroup$ It's on pastebin, pastebin.com/raw/2RgJLmNr. $\endgroup$
    – a06e
    Commented Sep 5, 2017 at 21:02
  • $\begingroup$ @becko - rationalize your data and you can see that there is overlap between some of the balls. Length[Select[ Norm /@ (Subtract @@@ Subsets[spheres // Rationalize[#, 0] &, {2}]), # < 2 &]] $\endgroup$
    – Bob Hanlon
    Commented Sep 5, 2017 at 23:55
  • 1
    $\begingroup$ @becko - Using N@ employs machine precision and precludes you from seeing the numbers that are slightly less than 2. Use N[#,20]&@ and you will see the 15 numbers slightly less than 2 $\endgroup$
    – Bob Hanlon
    Commented Sep 6, 2017 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.