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$
  • $\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 Sep 5 '17 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 Sep 5 '17 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$ – becko Sep 5 '17 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$ – aardvark2012 Sep 5 '17 at 11:55
  • 2
    $\begingroup$ FWIW, in MMA 10.4 the result is 211.133, i.e., a relative error of around 1%. $\endgroup$ – AccidentalFourierTransform Sep 5 '17 at 12:38
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$
  • $\begingroup$ Curious that this works fine. Any idea why my example fails? $\endgroup$ – becko Sep 5 '17 at 20:40
  • $\begingroup$ @becko - I was unable to access your data so I cannot know why it has problems. $\endgroup$ – Bob Hanlon Sep 5 '17 at 20:53
  • $\begingroup$ It's on pastebin, pastebin.com/raw/2RgJLmNr. $\endgroup$ – becko Sep 5 '17 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 Sep 5 '17 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 Sep 6 '17 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.