How to draw a Circle in 3D on a sphere [duplicate]

Question

The Circle function is strictly a 2D Graphics object, so that we cannot directly combine a Circle with a Graphics3D object such as a sphere:

 Show[{ Graphics3D[Sphere[] , Circle[]] }]  

(* Circle is not a Graphics3D primitive or directive *)

How can I draw circle in 3D?

For example consider a unit Sphere[] centered at the origin. How can we draw a circle passing through a specified point with the circle center along a vector passing through a second point.

Answer 1

Circle

Let's create circle3D that is something you would expect from Circle but with an extra argument for its normal vector.

With

circle3D[centre_: {0, 0, 0}, radius_: 1, normal_: {0, 0, 1}, angle_: {0, 2 Pi}] :=
  Composition[
    Line,
    Map[RotationTransform[{{0, 0, 1}, normal}, centre], #] &,
    Map[Append[#, Last@centre] &, #] &,
    Append[DeleteDuplicates[Most@#], Last@#] &,
    Level[#, {-2}] &,
    MeshPrimitives[#, 1] &,
    DiscretizeRegion,
    If
  ][
    First@Differences@angle >= 2 Pi,
    Circle[Most@centre, radius],
    Circle[Most@centre, radius, angle]
  ]

we can produce, for example, the following.

A unit circle centred at the origin with the z-axis as its normal:

Graphics3D[circle3D[]]

A unit circle centred at {2, 3, 4} with the z-axis as its normal:

Graphics3D[circle3D[{2, 3, 4}, 2]]

A circle centred at {2, 3, 4} with radius 2 and the z-axis as its normal:

Graphics3D[circle3D[{2, 3, 4}, 2]]

A circle centred at {2, 3, 4} with radius 2 and normal vector pointing in the direction of $\hat\imath - \hat\jmath + \hat{k}$:

Graphics3D[circle3D[{2, 3, 4}, 2, {1, -1, 1}]]

An arc, drawn from 0 to 180 degrees, of a circle whose origin is centred at {2, 3, 4}, radius is 2, and normal vector points in the direction of $\hat\imath - \hat\jmath + \hat{k}$:

Graphics3D[circle3D[{2, 3, 4}, 2, {1, -1, 1}, {0, 180 Degree}]]

Neat Examples

tocartesian = CoordinateTransformData["Spherical" -> "Cartesian", "Mapping"];
circles = MapThread[
  circle3D[{0, 0, 0}, #1, tocartesian[{#1, #2, 0}]] &,
  {Range[37], Range[0 Degree, 360 Degree, 10 Degree]}
];
ListAnimate@Table[
  Graphics3D[
    Rotate[#, n Degree, {0, 1, 0}] & /@ circles,
    Boxed -> False,
    PlotRange -> 37 {{-1, 1}, {-1, 1}, {-1, 1}}
  ],
  {n, 180}
]

tocartesian = CoordinateTransformData["Spherical" -> "Cartesian", "Mapping"];
spherecentre = RandomReal[{-1, 1}, 3];
sphereradius = RandomReal[{1, 2}];
dotsize = sphereradius/20;
randcirc := Module[
  {circleradius, randompoint},
  circleradius = RandomReal[{dotsize, sphereradius}];
  randompoint = TranslationTransform[spherecentre][
    tocartesian[{sphereradius, RandomReal[{0, Pi}], 
    RandomReal[{0, 2 Pi}]}]
  ];
  {
    RandomColor[],
    Sphere[randompoint, dotsize],
    circle3D[
      spherecentre +
        Sqrt[sphereradius^2 - circleradius^2] Normalize[randompoint - spherecentre],
      circleradius,
      randompoint - spherecentre
    ]
  }
];
Graphics3D[
  {
    {Opacity[0.3, LightGray], Sphere[spherecentre, sphereradius]},
    Thick,
    Table[randcirc, {10}]
  },
  Boxed -> False
]

Extras

Disk

Likewise, we can construct disk3D that behaves like Disk but with an extra argument for its normal vector.

disk3D[centre_: {0, 0, 0}, radius_: 1, normal_: {0, 0, 1}, angle_: {0, 2 Pi}] :=
  Polygon[
    Map[RotationTransform[{{0, 0, 1}, normal}, centre]][
      If[First@Differences@angle >= 2 Pi, #, Append[#, centre]] &[
        Map[Append[#, Last@centre] &][
          SortBy[#, sortf[#, Most@centre] &] &[
            MeshCoordinates[DiscretizeRegion[
              Circle[Most@centre, radius, angle]
]]]]]]]
sortf := Composition[
    If[Negative[#], # + 2 Pi, #] &,
    N[ArcTan @@ (#1 - #2)] &
]

The sorting of points is adapted from nikie's answer in #48091

Examples:

Graphics3D[disk3D[]]

Graphics3D[disk3D[{2, 3, 4}, 2, {1, -1, 1}, {30 Degree, 180 Degree}]]

It's a Polygon after all, so it behaves just like any other region object in Mathematica. You can execute, for example,

RegionMeasure[disk3D[{2, 3, 4}, 2, {1, -1, 1}, {30 Degree, 180 Degree}]]

and get the area:

5.2232

or style it like

disk = disk3D[{2, 3, 4}, 2, {1, -1, 1}, {30 Degree, 180 Degree}];
Graphics3D[{EdgeForm[], Red, disk}]

Ellipse

After circle3D, why not ellipse3D as well?

ellipse3D[centre_: {0, 0, 0}, radii_: {1, 1}, normal_: {0, 0, 1}] := 
  Polygon[
    RotationTransform[{{0, 0, 1}, normal}, centre][
      Map[Append[#, Last@centre] &][
        SortBy[#, N[ArcTan @@ (# - Most@centre)] &] &[
          MeshCoordinates[BoundaryDiscretizeRegion[
            Ellipsoid[Most@centre, radii]
]]]]]]

Graphics3D[ellipse3D[]] is equivalent to Graphics3D[circle3D[]]:

Graphics3D[ellipse3D[{2, 3, 4}, {1, 2}, {1, -1, 1}]]

RegionMeasure[ellipse3D[{2, 3, 4}, {1, 2}, {1, -1, 1}]]

6.25978

which is a little bit off from that of the same ellipse in 2D:

RegionMeasure[Ellipsoid[{2, 3}, {1, 2}]]

2π

due to the discretisation.

Answer 2

center = Normalize@{1, 2, 3};
point = Normalize@{0, 2, 1};

with minimum of algebra:

Show[
 ParametricPlot3D[
    Evaluate[ N[center + RotationMatrix[t, center].(point - center)]], 
    {t, 0, 2 Pi}],
 Graphics3D[{Sphere[], Blue, Sphere[{center, point}, .05]}]
 , PlotRange -> 1.1
 ]

Answer 3

circle is 2D and sphere is 3D. Hence you are missing one dimension to make them both show together. i.e. you need orientation for the circle.

This should get you started. You can approximate a circle with Cylinder of very small length.

Graphics3D[{
  {Red, Cylinder[{{1, 0, 0}, {1.01, 0, 0}}, 1]},
  Sphere[{0, 0, 0}, 1]
  }, Boxed -> False]

Answer 4

You can also plot two partial spheres and highlight where they meet

 smallSphere = ParametricPlot3D[
   {Cos[θ] Sin[ϕ], Cos[θ] Cos[ϕ], Sin[θ]},
   {θ, -π, π}, {ϕ, -π/2, π/2},
   Mesh -> None,
   PlotStyle -> {LightBlue, Opacity[0.4]},
   BoundaryStyle -> Directive[Thick, Red],
   RegionFunction -> (#2 > .6 &)
   ];
 bigSphere = ParametricPlot3D[
   {Cos[θ] Sin[ϕ], Cos[θ] Cos[ϕ], Sin[θ]},
   {θ, -π, π}, {ϕ, -π/2, π/2},
   Mesh -> None,
   PlotStyle -> {Blue, Opacity[0.5]},
   RegionFunction -> (#2 < .6 &)
   ];
Show[bigSphere, smallSphere, PlotRange -> All, Axes -> None, Boxed -> False]

Answer 5

draw[sphere : {sC_, sR_}, circle: {ctr_, pt_}] := 
 ParametricPlot3D[sR {Cos[u] Sin[v],Sin[u] Sin[v],Cos[v]}+sC, {u,0,2 Pi}, {v,0,2 Pi}, 
  MeshFunctions -> (Norm[{##}[[1;;3]]-ctr] - Norm[ctr-pt] &), Mesh -> {{0}}]

SeedRandom[42];
sCenter = {1, 1, 1}; sRadius = 1;
cs = Map[Plus[Normalize[#], sCenter] &, RandomReal[{-1, 1} sRadius, {10, 2, 3}], {2}]
draw[{sCenter, sRadius}, #] & /@ cs // Show

Also

f[r_, u_, v_]= CoordinateTransformData["Spherical"->"Cartesian","Mapping",{r, u, v}]; 

draw1[sphere : {sphC_, sphR_}, ctr_, pt_] := 
 ParametricPlot3D[f[sphR, u, v] + sphC, {u, 0, 2 Pi}, {v, 0, 2 Pi}, 
  MeshFunctions -> Function[{x, y, z, u, v}, Norm[{x, y, z} - ctr] - Norm[ctr- pt]], 
  Mesh -> {{0}}]

draw1[{{1, 1, 1}, 1}, {1, 1, 2}, {1, 0, 1}]

Answer 6

You can also use Exclusions with ParametricPlot3D:

ParametricPlot3D[{Cos[u] Sin[v], Cos[u] Cos[v], Sin[u]}, {u, -π, π}, {v, -π/2, π/2}, 
 Mesh -> None, PlotStyle -> Opacity[.25, Blue], PlotPoints -> 80, MaxRecursion -> 4,
 Exclusions -> {Cos[u] Cos[v] == .7}, 
 ExclusionsStyle -> ({Directive[Opacity[1], Thick, Red]})]

Answer 7

I've found this useful on a number of occasions: use a BezierCurve, which can be a 3D object, to approximate a circle.

 bezierarc[xc_, a_, b_ , r_: 1, n_: {0, 0, 1}] := 
   (* Bezier approximation to an arc *)
   (*Excellent approximation for included angle b-a < Pi/2 *)
   (* "pretty good" approximation for b-a< Pi *)
   Module[{rstar, del, p, c, d},
   c = (a + b)/2;
   d = (a - b)/2;
   rstar = (8 - ( Cos@a + Cos@b )/Cos@c )/6;
   del = (13 Sin@d - 8  Sin[d/2] Sqrt[14 + 2 Cos@d ])/9;
   p = r {
     {Cos[a], Sin[a]} ,
     rstar {Cos[c], Sin[c]} -   del {-Sin[c], Cos[c]} ,
     rstar  {Cos[c], Sin[c]} +   del  {-Sin[c], Cos[c]} ,
     {Cos[b], Sin[b]}};
   If[Length[xc] == 3 , 
      p = RotationMatrix[{ {0, 0, 1}, n}]. Append[#, 0] & /@ p];
   BezierCurve[xc + # & /@ p]]
 beziercircle[xc_, r_: 1, n_: {0, 0, 1}] := 
    bezierarc[xc, Sequence @@ # , r, n ] & /@  (Pi /2 Partition[Range[0, 4], 2, 1])

This is designed to work in 2- or 3-d:

 GraphicsRow[{Graphics@beziercircle[{0, 0}, 1] ,
    Graphics3D@{beziercircle[{0, 0, 0}, 1, {1, 1, 1}], 
           Line[{{0, 0, 0}, {1, 1, 1}}] }}]

for the example at hand,

   center = Normalize@{1, 2, 3};
   point = Normalize@{0, 2, 1};

of course the true circle center is not actually on the sphere so we need to do a bit of math:

 cc = center First@
     Select[ f /. 
           Solve[ (f center  - point ).(f center) == 0 , f ] , # > 0 & ]
 Graphics3D[{ Sphere[] , Thick, Red, 
      beziercircle[cc, Norm[point - cc], center] , Blue, 
          Sphere[#, .05] & /@ {center, point}}]