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

| improve this answer | |
$\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

| improve this answer | |
$\endgroup$
  • $\begingroup$ Thank you, I think this works, I just need to adjust where the lattice path starts and finishes. $\endgroup$ – apkg Oct 27 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.