I have a function in polar coordinate
f[\[Theta],\[Phi]] = 1 + 2 Cos[2 \[Theta]].
The function is centered at the origin. Is there a way to plot another function of the same shape but centered at (1,0,0), i.e. shifted along x-axis? What I want is to have two functions of identical shape centered at (0,0,0) and (1,0,0) respectively but I only have the explicit form of the function at (0,0,0).
SphericalPlot3D[1 + 2 Cos[2 \[Theta]],
{\[Theta], 0, Pi}, {\[Phi], 0, 2 Pi}]
EDIT: Changed colors and corrected color issues.
sp3d = SphericalPlot3D[
1 + 2 Cos[2 θ], {θ, 0, Pi}, {ϕ, 0, 2 Pi},
ColorFunction ->
Function[{x, y, z, θ, ϕ, r},
Piecewise[{{Red, 1 + 2 Cos[2 θ] < 0}}, Lighter@Orange]],
ColorFunctionScaling -> False,
PlotPoints -> 25,
MaxRecursion -> 3];
Manipulate[
Show[
sp3d,
ReplacePart[
sp3d, {1, 1} ->
sp3d[[1, 1]] /. {x_?NumericQ, y_?NumericQ, z_?NumericQ} :> {x + offset,
y, z}],
PlotRange -> All], {{offset, 1}, 0, 3, 0.25, Appearance -> "Labeled"}]
{0, 0, 1} to those whose third coordinate is a numeric value. The first two coordinates are already restricted to being numeric by being bound to within the interval {-1, 1}. The Graphics3D contains other lists of length three that are not points and should not be translated.
$\endgroup$
Commented
Nov 7, 2018 at 21:20
First generate data points from your function:
data = Flatten[
Table[{1 + 2 Cos[2 \[Theta]], \[Theta], \[Phi]},
{\[Theta], 0, Pi, Pi/500}, {\[Phi], 0, 2 Pi, 2 Pi/500}], 1];
Next a mapping from polar to cartesian:
mapping =
CoordinateTransformData["Spherical" -> "Cartesian", "Mapping"];
now the points (transformed) with offset of {1,0,0}:
ListPointPlot3D[# + {1, 0, 0} & /@ (mapping /@ data),
BoxRatios -> Automatic]
or
ListSurfacePlot3D[# + {1, 0, 0} & /@ (mapping /@ data),
MaxPlotPoints -> 60,
BoxRatios -> Automatic]
Both together:
mappeddata = mapping /@ data;
plt1 = ListSurfacePlot3D[# + {1, 0, 0} & /@ mappeddata,
MaxPlotPoints -> 30, PlotStyle -> {Opacity[0.5], Red}];
plt2 = ListSurfacePlot3D[mappeddata,
MaxPlotPoints -> 30, PlotStyle -> {Opacity[0.5], Blue}];
Show[plt1, plt2]
For exact copies apply Translate to the graphics elements, which are in position 1 of the graphics returned by plotting functions:
g = SphericalPlot3D[1 + 2 Cos[2 θ], {θ, 0, Pi}, {ϕ, 0, 2 Pi}];
vecs = {{0, 0, 0}, {1, 0, 0}};
Show[MapAt[Translate[#, vecs] &, g, 1], PlotRange -> All]
It's very efficient, as g is computed once, only one copy is stored, and the translations are computed by the GPU (I think).
vecs = 2 Tuples[{Range[0, 3], Range[0, 2], {0}}];
g12 = Show[MapAt[Translate[#, vecs] &, g, 1], PlotRange -> All]
ByteCount /@ {g, g12}
(* {697504, 698024} *)
