# Overlay Graph3D with Graphics, with aligned coordinates

I have a Graph3D object representing a 3D lattice path

g3d = With[{n = 4},
Graph3D[GridGraph[{n, n, n}],
VertexCoordinates -> Tuples[Range[n], 3]]];
g1 = HighlightGraph[g3d, Subgraph[g3d, FindPath[g3d, 1, 64, {9}, 1]],
PlotTheme -> "Monochrome", ImageSize -> Small]


and a Graphics3D object of selected cubes beneath it

PlanePartitionDiagram[l_List] :=
Module[{i, j, k},
Graphics3D[{EdgeForm[{Black, Thickness[0.01]}],
Table[Cuboid[{j, -i, k}], {i, Length[l]}, {j, Length[l[[i]]]}, {k,
l[[i, j]]}]}, Boxed -> False, ViewProjection -> "Orthographic",
ViewPoint -> {1, 1, 1},
Lighting -> {{"Directional",
RGBColor[1., 0.96,
0.2], {{0, 0, 1}, {0, 0, 0}}}, {"Directional",
RGBColor[0.2, 0.2, 1.], {{0, 1, 0}, {0, 0, 0}}}, {"Directional",
RGBColor[1., 0.2, 0.2], {{1, 0, 0}, {0, 0, 0}}}}]]
pp1 = PlanePartitionDiagram[{{0, 3, 2, 2}, {0, 3, 2, 2}, {0, 0, 2,
2}, {0, 0, 0, 2}}]


getting after Show[{pp1, g1}]

What I can't do is get the lattice path graph and the plane partition to align so that the bottom left corner of each image are aligned, and the cubes are beneath the path, similar to:

It appears the viewpoint on the two figures with Show has to be shared. Is there a way of aligning them?

• I think there is a minor problem with the parentheses, but I can't see where.
– apg
Oct 28, 2020 at 11:15
• should be Show[pp1, MapAt[GeometricTransformation[#, TranslationTransform[{0, -5, -1}]] &, Show[g1], {1}]]
– kglr
Oct 28, 2020 at 11:24
• Yes that works well. I also adjusted the plane partition to PlanePartitionDiagram[{{0, 3, 2, 2}, {0, 3, 2, 2}, {0, 0, 2, 2}}], and the lattice path to {49, 50, 51, 35, 19, 23, 24, 8, 12, 16}, and used Show[pp1, MapAt[GeometricTransformation[#, TranslationTransform[{1, -4, 0}]] &, Show[g1], {1}]] to get a fitting example.
– apg
Oct 28, 2020 at 11:45

We can use TranslationTransform to move the origin of the graph object:

ClearAll[tr]
tr[g_, pp_] := MapAt[GeometricTransformation[#,
TranslationTransform[
First[Transpose @ CoordinateBounds[Cases[pp, Cuboid[x_] :> x, All]]] -
First[Transpose @ CoordinateBounds@GraphEmbedding[g]]]] &,
Show @ g, {1}]


Examples:

nng = IndexGraph@NearestNeighborGraph[#, VertexCoordinates -> #] & @ Tuples[Range[4], 3];

pp1 = PlanePartitionDiagram[{{0, 3, 2, 2}, {0, 3, 2, 2}, {0, 0, 2, 2}, {0, 0, 0, 2}}];

g1 = HighlightGraph[nng, Subgraph[nng, FindPath[nng, 1, 64, {9}, 1]],
PlotTheme -> "Monochrome"];

Row[Show[#, ImageSize -> Medium] & /@ {g1, pp1}]


Show[pp1, tr[g1, pp1]]


pp2 = PlanePartitionDiagram[{{0, 3, 2, 2}, {0, 3, 2, 2}, {0, 0, 2, 2}}];

g2 = HighlightGraph[nng, Subgraph[nng, {49, 50, 51, 35, 19, 23, 24, 8, 12, 16}],
PlotTheme -> "Monochrome"];

Row[Show[#, ImageSize -> Medium] & /@ {g2, pp2}]


Show[pp2, tr[g2, pp2]]


Change the definition of g3d,but I don't know how to change the HighlightGraph :-(

newg3d[x_, y_, z_] :=
With[{n = 5},
Graph3D[GridGraph[{n, n, n}],
VertexCoordinates ->
Tuples[{Range[5] + x, Range[5] + y, Range[5] + z}]]];
g3d = newg3d[0, -5, 0];


• Thank you, I think this works, I just need to adjust where the lattice path starts and finishes.
– apg
Oct 27, 2020 at 14:51