2
$\begingroup$

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]

enter image description here

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}}]

enter image description here

getting after Show[{pp1, g1}]

enter image description here

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:

enter image description here

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

$\endgroup$
3
  • $\begingroup$ I think there is a minor problem with the parentheses, but I can't see where. $\endgroup$
    – apkg
    Oct 28 '20 at 11:15
  • 1
    $\begingroup$ should be Show[pp1, MapAt[GeometricTransformation[#, TranslationTransform[{0, -5, -1}]] &, Show[g1], {1}]] $\endgroup$
    – kglr
    Oct 28 '20 at 11:24
  • $\begingroup$ 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. $\endgroup$
    – apkg
    Oct 28 '20 at 11:45
1
$\begingroup$

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}]

enter image description here

Show[pp1, tr[g1, pp1]]

enter image description here

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}]

enter image description here

Show[pp2, tr[g2, pp2]]

enter image description here

$\endgroup$
1
$\begingroup$

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];

enter image description here

$\endgroup$
1
  • $\begingroup$ Thank you, I think this works, I just need to adjust where the lattice path starts and finishes. $\endgroup$
    – apkg
    Oct 27 '20 at 14:51

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.