# Plotting the image of a function of 3 variables in $R^3$

Reading the question plotting the image of a function under constraints I see that the TransformedRegion command allows one to plot the image of functions whose domain is in $$R^2$$ and the image is in $$R^2$$. I tried to use TransformedRegion with a function of $$R^3$$ into $$R^3$$ but it did not work and there is no TransformedRegion3D command.

reg = DiscretizeRegion[
ImplicitRegion[True, {{x, 0, 1}, {y, 0, 1}, {z, 0, 1}}],
MaxCellMeasure -> 0.001]

f[x_, y_, z_] := {y*z, x*z, x*y}



Question: Is there some way to plot the image of f in the code above in Mathematica?

• What would this look like? Perhaps plot a cloud of random points in a cube and displace them using the function. Commented Apr 27 at 15:59
• But: mr = MeshRegion[{{0, 0, 0}, {1, 0, 0}, {1, 1, 0}, {0, 1, 0}, {0, 0, 1}, {1, 0, 1}, {1, 1, 1}, {0, 1, 1}, {0.5, 0.5, 1.5}, {1.5, 0, 0}, {1.5, 1, 0}, {1, -0.5, 0}}, Hexahedron[{1, 2, 3, 4, 5, 6, 7, 8}]] and \[ScriptCapitalR] = TransformedRegion[mr, ShearingTransform[30 Degree, {1, 0, 0}, {0, 1, 0}]] Commented Apr 27 at 16:33
• treg = TransformedRegion[reg, f] and Region[treg] works as well but on the cloud. It seems to go to hang up on v12.2.0.
– Syed
Commented Apr 28 at 1:07

## 3 Answers

TheTransformedRegion command also works in 3D. In your case

reg = ImplicitRegion[True, {{x, 0, 1}, {y, 0, 1}, {z, 0, 1}}];
treg = TransformedRegion[reg,
Function[p, {p[[2]]*p[[3]], p[[1]]*p[[3]],p[[1]]*p[[2]]}]];
Region[treg]


• Thanks! There is a missing [ in the code in the answer: p[1]] should be p[[1]]. I tried to edit it but it would not allow for corrections less than 6 characters... Commented Apr 27 at 18:50
• @SergioParreiras" Thank you. Fixed. Commented Apr 27 at 18:55
Clear[reg, f];
reg = DiscretizeRegion[
ImplicitRegion[{0 <= x <= 1, 0 <= y <= 1, 0 <= z <= 1}, {x, y, z}],
MaxCellMeasure -> 0.01];
f[x_, y_, z_] := {y*z, x*z, x*y};
RegionPlot3D[reg,
DisplayFunction ->
ReplaceAll[{x_Real, y_Real, z_Real} :> f[x, y, z]],
MaxRecursion -> 3, PlotPoints -> 2, ViewPoint -> {-2.4, -1.7, -1.7}]


• Yes, this is a faster way. However, RegionMember[treg,{x,y,z}] produces x | y | z) \[Element] Reals && ((x == 0 && y == 0 && z == 0) || (x == 0 && y == 0 && z == 1) || (x == 0 && y == 0 && z < 1 && z > 0) || (x <= 1 && x >= 0 && y <= 1 && y >= 0 && x y - z == 0 && z >= 0) || (x > 0 && y > 0 && x y - z <= 0 && z > 0 && -y + x z <= 0 && x - y z >= 0) || (x <= 1 && x > 0 && x - y >= 0 && y >= 0 && -y + x z == 0) || (x >= 0 && x - y <= 0 && y <= 1 && y > 0 && x - y z == 0)), whereas RegionMember[reg, {x, y, z}] doesn't produces an expression. Commented Apr 28 at 9:14
• (i) RegionConvert[treg, "Parametric"] produces ParametricRegion[{{y z, x z, x y}, 0 <= x <= 1 && 0 <= y <= 1 && 0 <= z <= 1}, {x, y, z}]. (ii) Indeed, RegionPlot3D draws better than Region. Commented Apr 28 at 9:33
• @user64494 RegionPlot3D[treg] does not product the smooth graphics3D since treg is too complex althought it is the parametric form. Commented Apr 28 at 9:36
• Every approach has its advantages and deficiencies. Commented Apr 28 at 9:55

Visualization of how the transformation take place based on @cvgmt answer.

reg = DiscretizeRegion[
ImplicitRegion[{0 <= x <= 1, 0 <= y <= 1, 0 <= z <= 1}, {x, y, z}],
MaxCellMeasure -> 0.001];
f[x_, y_, z_] := {y*z, x*z, x*y};

Manipulate[
RegionPlot3D[reg,
DisplayFunction ->
ReplaceAll[{x_Real, y_Real,
z_Real} :> (Transpose[{#[[2]] - #[[1]], #[[1]]}] . {n, 1} &@{{x,
y, z}, f[x, y, z]})], Boxed -> False, Mesh -> 9], {n, 0, 1}]


Manipulate with much quicker response (not based on @cvgmt answer).

lines = {Table[Line@{{n, 0, 0}, {n, 0, 1}}, {n, 0, 1, 1/10}],
Table[Line@{{0, 0, n}, {1, 0, n}}, {n, 0, 1, 1/10}],
Table[Line@{{n, 0, 0}, {n, 1, 0}}, {n, 0, 1, 1/10}],
Table[Line@{{0, n, 0}, {1, n, 0}}, {n, 0, 1, 1/10}],
Table[Line@{{0, n, 0}, {0, n, 1}}, {n, 0, 1, 1/10}],
Table[Line@{{0, 0, n}, {0, 1, n}}, {n, 0, 1, 1/10}],
Table[Line@{{n, 1, 0}, {n, 1, 1}}, {n, 0, 1, 1/10}],
Table[Line@{{0, 1, n}, {1, 1, n}}, {n, 0, 1, 1/10}],
Table[Line@{{n, 0, 1}, {n, 1, 1}}, {n, 0, 1, 1/10}],
Table[Line@{{0, n, 1}, {1, n, 1}}, {n, 0, 1, 1/10}],
Table[Line@{{1, n, 0}, {1, n, 1}}, {n, 0, 1, 1/10}],
Table[Line@{{1, 0, n}, {1, 1, n}}, {n, 0, 1, 1/10}]} // Flatten //
DeleteDuplicates;
nlines = lines /. {x_, y_, z_} :> {y z, x z, x y};

(Transpose /@ Transpose[{#[[2]] - #[[1]], #[[1]]}]) . {n,
1} & /@ (Transpose[{lines, nlines}] /. Line -> Sequence);
Manipulate[
Graphics3D[{Opacity[0.5], Line[%]}, Boxed -> False], {n, 0, 1}]