Rescale Graphics3D com base em proporções de caixa

Question

Se eu plotar uma esfera usando Graphics3Dcom BoxRatios->1, então obtenho um gráfico bonito:

Show[Graphics3D[{Red, Sphere[{0, 0, 0}, 1]}], BoxRatios -> 1, 
 PlotRange -> {{-4, 4}, {-4, 4}, {-4, 4}}]

Imagem:

No entanto, se PlotRangeou BoxRatiosmudar, a esfera ficará distorcida:

Se eu souber o BoxRatiose PlotRangeantes de plotar, posso usar Ellipsoidpara fazer algo que parece esférico em qualquer plotagem 3D:

Pergunta: Existe alguma maneira de criar meu próprio "Objeto Gráfico" personalizado que plota um elipsóide em 3D que é dimensionado com base nas dimensões do gráfico ( BoxRatiose PlotRange) para parecer perfeitamente esférico? Gostaria que meu "Objeto Gráfico" se ajustasse automaticamente BoxRatiose PlotRangeda mesma forma que se PointSizeajusta automaticamente à largura do gráfico sem a necessidade de intervenção do usuário.

Observação: você pode estar curioso para saber por que estou fazendo esta pergunta. O motivo é que Graphics3D[{PointSize[0.035],Red,Point[{0,0,0}]}]produz um ponto em 3D que se parece com um disco plano, e eu gostaria de representar pontos em 3D como esferas em escala perfeita. Spherepor si só não é uma resposta perfeita porque pode parecer distorcida com base nas dimensões da trama.

Answer 1

Atualização: Enquanto esperamos por algumas atualizações de lançamento futuras Sphereque permitem Offset[o]e Scaled[s]especificam o raio (como é atualmente o caso para Diske Circle), podemos usar o pós-processamento da seguinte maneira:

Se a entrada é um Graphicsobjeto e os valores de opção BoxRatiose PlotRangenão são conhecidos com antecedência, podemos extraí-los a partir do objeto antes de usar scaleSphere.

Multicolumn[
 glist = Show[Graphics3D[{Red, Sphere[{0, 0, 0}, 1]}], BoxRatios -> #,
      PlotRange -> #2, 
     PlotLabel -> Row[{"BoxRatios: ", #, "\n  PlotRange: ", #2}], 
     ImageSize -> Medium] & @@@ ratiorangepairs, 2]

ClearAll[postProcess]
postProcess = # /. s_Sphere :> 
     scaleSphere[BoxRatios /. Quiet@AbsoluteOptions[#, BoxRatios], 
       PlotRange@#][s] &;


Multicolumn[#, 2] &[postProcess /@ glist]

Resposta original:

Com taxas de caixa conhecidas e intervalos de gráfico, você pode usar Scalepara construir uma função para processar Sphere[...]:

ClearAll[scaleSphere]

scaleSphere[br_, pr_] := Scale[#, Normalize[-Subtract @@@ pr, Max] / br] &;

Exemplos:

ratiorangepairs =  Tuples[{{1, {1, 2, 3}}, 
  {{{-4, 4}, {-4, 4}, {-4, 4}}, {{-4, 4}, {-4, 4}, {-1, 1}}}}]; 

Multicolumn[#, 2] &[Show[Graphics3D[{Red, scaleSphere[##]@Sphere[{0, 0, 0}, 1]}], 
    BoxRatios -> #, PlotRange -> #2, 
    PlotLabel -> Row[{"BoxRatios: ", #, "\n  PlotRange: ", #2}], 
    ImageSize -> Medium] & @@@ ratiorangepairs]