How to force the ellipsoid of BubbleChart3D to be spherical when the BoxRatios is rectangular?

Question

I have a BubbleChart3D as below, while the BoxRatio is rectangular:

BlockRandom[SeedRandom[123];
pts1 = RandomReal[1, {10, 4}];
pts2 = RandomReal[10, {10, 4}];]
BubbleChart3D[{pts1, pts2}, BoxRatios -> {0.5, 1.5, 2}]

As you can see, the points are ellipsoids instead of spheres. How can I force the points to become spherical again?

Many thanks!

---

Many thanks for the reply. But I may need to add a subsequent section for the question, as the situation is so odd: whenever I changed my data, the shape of the sphere can be changed from sphere back to ellipsoid.

I try to simplify my current work as below:-

k = 10;
BlockRandom[SeedRandom[123]; pts0 = RandomReal[10, {k, 4}];]

pts1 = pts0;
pts1[[All, 1]] = pts0[[All, 1]] + (x1 = -50);
pts1[[All, 2]] = pts0[[All, 2]] + (x2 = 80);
pts1[[All, 3]] = pts0[[All, 3]] + (x3 = 200);

boxRatio1 = {0.5, 1.5, 2.7};
plotRange1 = {{-70, -30}, {60, 110}, {0, 250}};

cef[br_: {1, 1, 1}, pr_] := (dPr = Flatten@(Differences /@ pr); Scale[ChartElementData["Bubble3D"][##], MapThread[Times, {1.5/br, dPr/Min[dPr]}]] &);

bchart3b = BubbleChart3D[pts1, ImageSize -> 200, BoxRatios -> boxRatio1, ChartElementFunction -> cef[boxRatio1, plotRange1], PlotRange -> plotRange1]

As you can see, when k is 10, the shape of the points are spheres. When k is 9, the shape of the points are ellipsoid...

Why is that?

Answer 1

Update 2: Finding a fix for that would work for all built-in ChartElementFunctions seems challenging. The following modification of cef works only for "Bubble3D". The function addMetaData attaches the MinMax of the last column of the data and the range of bubble sizes as metadata, and this metadata is used by cef2 in rescaling the sphere primitives.

ClearAll[cef2, addMetaData]
cef2[br_: {1, 1, 1}, pr_: {{0, 1}, {0, 1}, {0, 1}}, sc_: .1] := Module[
    {ced = ChartElementData["Bubble3D"][##], 
     rs = sc Rescale[#2[[-1]], #3[[1, 1]], #3[[1, 2]]] Norm[
        Subtract @@ Transpose[pr]] Normalize[-Subtract @@@ pr]/br},
    Replace[ced, Scale[a_, b_, c_] :> Scale[a, rs, c], {0, ∞}]] &;

addMetaData[data_, bsizes_] := data -> {MinMax[data[[All, -1]]], bsizes};

k = 9;
boxRatio1 = {0.5, 1.5, 2.7};
plotRange1 = {{-70, -30}, {60, 110}, {0, 250}};
bsizes = {0.1, .5};
Row[{BubbleChart3D[pts1, ImageSize -> 200, BoxRatios -> boxRatio1, 
   PlotRange -> plotRange1], 
  BubbleChart3D[addMetaData[pts1, bsizes], ImageSize -> 200, 
   BoxRatios -> boxRatio1, PlotRange -> plotRange1, 
   ChartElementFunction -> cef2[boxRatio1, plotRange1]]}]

Update: A custom ChartElementFunction that modifies the built-in ones using Scale to remove the distortion:

ClearAll[cef]
cef[br_: {1, 1, 1}][cedf_: "Bubble3D"] := Scale[ChartElementData[cedf][##], 1/br] &;

Examples:

br1 = {0.5, 1.5, 2};
Row[BubbleChart3D[{pts1, pts2}, ImageSize -> 200, BoxRatios -> br1, 
    ChartElementFunction -> #] & /@ {"Bubble3D", cef[br1][]}]

br2 = {3, 1, 2};
Row[BubbleChart3D[{pts1, pts2}, ImageSize -> 200, BoxRatios -> br2, 
    ChartElementFunction -> #] & /@ {"Bubble3D", cef[br2][]}]

Row[BubbleChart3D[{pts1, pts2}, ImageSize -> 200, BoxRatios -> br1, 
    ChartElementFunction -> #] & /@ {"ProfileCube", cef[br1]["ProfileCube"]}]

Original answer:

You can post-process the output of BubbleChart3D to modify the distorted spheres. If you don't mind loosing tooltips (due to the option setting PerformanceGoal -> "Speed"), post-processing becomes easier:

postprocess = # /. Translate[Scale[{a_}, b_, c_], d_] :> 
 Translate[Scale[{a}, b/(BoxRatios /. Options[#, BoxRatios]), c], d] &;

Example:

bc3d1 = BubbleChart3D[{pts1, pts2}, BoxRatios -> {0.5, 1.5, 2}, 
   PerformanceGoal -> "Speed", ImageSize -> 300];
Row[{bc3d1, postprocess @ bc3d1}]