Problem with making torus graph in Graph3D by identifying edge of a square graph

Question

Background: I want to imply periodicity along the given edges for a graph. For example in a square lattice with identifying parallel edges, you can construct a torus. consider the following image

So I start with the construction of a square lattice network

nmax = 15;(*Length of lattice*)
points = Flatten[Table[{i, j}, {i, -nmax, nmax}, {j, -nmax, nmax}], 
     1];(*list coordinate of the lattice*)
d1 = (Sqrt[2] + 1)/2;(*Max distance to construct linked between coordination of the lattice*)
d0 = 1/2;(*Min distance to construct linked between coordination of the lattice*)
nn = Nearest[points -> "Index"];
(*function which determine the nearest of a vertex. we can do this*) 
(*also by for example DistanceMatrixor or NearestNeighborGraph*)
ha = Select[
   Flatten[ParallelTable[Module[{pp}, pp = nn[points[[i]], {10, d1}];
      Select[{i + 0 pp, pp, 
          Norm /@ ((points[[pp]]\[Transpose] - 
               points[[i]])\[Transpose])}\[Transpose], 
        d1 > #[[3]] &][[All, {1, 2}]]], {i, 1, Length[points]}], 
    1], #[[1]] > #[[2]] &];
(*I use select to just consider one linke between two vortex ,*)
(*This part is somehow hard to catch at a glince but it did not *)
(*change following discussion. Consider this line  as a function*)
(*making nearest neighbor links*)
Graph3D[ha]

where gives,

now I am looking to identifying edges. I use the following, for the left and right one

vortexL =points//SortBy[Flatten[Position[#[[All, 1]], Max[#[[All, 1]]]]], points[[#, 2]] &] &;
vortexR =points//SortBy[Flatten[Position[#[[All, 1]], Min[#[[All, 1]]]]],points[[#, 2]] &] &;

and for up and down edge we have

vortexU =points//SortBy[Flatten[Position[#[[All, 2]], Max[#[[All, 2]]]]], points[[#, 1]] &] &;
vortexD =points//SortBy[Flatten[Position[#[[All, 2]], Min[#[[All, 2]]]]],points[[#, 1]] &] &;

now i define identifier as

vchanger = {Table[vortexL[[i]] -> vortexR[[i]], {i, 1, Length@vortexL}],Table[vortexU[[i]]-> vortexD[[i]], {i, 1, Length@vortexU}]};

By applying it on ha (the link address) sequentially you can see how periodicity along those edges established,

ha = ha /. vchanger[[1]];
Graph3D[ha]

and

ha = ha /. vchanger[[2]];
Graph3D[ha]

where gives,

although it seems torus, by rotation it, you notify two crossings of the links

Question? So I am wondering, I did a mistake to construct the lattice and implication of periodic boundary condition, or this is the problem of Mathematica? Do someone has an option for Graph3D to make it correct shape?

Update My problem is almost the visualization of correct geometry this lattice has.

Answer 1

I'd recommend using IGraphM, you can find a thorough documentation here.

Within it, there are graphs with periodic boundary conditions for the square/hexagonal cases, and it is fully compatible with all the network functionality of MMA, so you can perform any computations with the graphs.

For instance, suppose I want a m x n square lattice with periodic boundaries.

Install IGraphM. This is, of course, done only the first time you need to use IGraphM:

Get["https://raw.githubusercontent.com/szhorvat/IGraphM/master/IGInstaller.m"]

Load the packlet. This is done every time you need IGraphM functionality in your code:

<< IGraphM`

Declare your dimensions, and the periodicity option, plot the Graph in 3D (optional):

m = 15;
n = 15;
mySquareGraph = Graph3D[IGSquareLattice[{m, n}, "Periodic" -> True]]

Just for demonstration, the hexagonal periodic graph (which is, in effect, a triangular lattice):

myHexagonalGraph = Graph3D[IGTriangularLattice[{m, n}, "Periodic" -> True]]

Now you can do all sorts of computations with them, either with IGraphM commands or the regular MMA commands.

Answer 2

If it is not essential to get a Graph3D object, you can use ParametricPlot3D to get the desired looks:

ClearAll[torus, toroidalGrid]

torus[t_, v_, a_: 1, b_: 3] := {(b + a Cos[t]) Sin[v], (b + a Cos[t]) Cos[v], a Sin[t]}

toroidalGrid[n_, m_, a_: 1, b_: 3][ opts___ : OptionsPattern[]] := 
  Module[{sd = 0.001 + Range[0, 2 Pi - 2 Pi/#, 2 Pi/#] & /@ {n, m}}, 
   Show[ParametricPlot3D[torus[v, t, a, b], {t, 0, 2 Pi}, {v, 0, 2 Pi}, 
      Mesh -> sd, PlotStyle -> None, opts, MeshStyle -> Gray,   
      Axes -> False, Boxed -> False, ImageSize -> Medium], 
   Graphics3D[GraphicsComplex[torus[#2, #, a, b] & @@@ Tuples[sd], 
     {PointSize[Large], Point@Range[n m]}]]]]

Examples:

Grid @ 
 Transpose[{GridGraph[{##}], toroidalGrid[##][ ]} & @@@ {{2, 2}, {3, 3}, {3, 5}, {4, 3}}]

You can use MaxRecursion -> 0 and small values for PlotPoints to get straight edges:

Grid @ Transpose @ 
 ({GridGraph[{##}], 
   toroidalGrid[##][MaxRecursion -> 0, PlotPoints -> {##} + 1, 
     PlotRangePadding -> Scaled[.1] ]} & @@@ {{3, 3}, {4, 4}, {3, 5}, {5, 6}}) 

We can post-process lines into tubes and points into spheres to get something that looks like the output from Graph3D:

toroidalGrid[##][MaxRecursion -> 0, PlotPoints -> {##} + 1, 
    PlotRangePadding -> Scaled[.1] , ImageSize -> 800, 
    Lighting -> {{"Directional", GrayLevel[0.7], 
       ImageScaled[{1, 1, 0}]}, {"Point", GrayLevel[0.9], 
       ImageScaled[{0, 0, 3.5}], {0, 0, 0.07}}}] &[10, 6] /. 
  {l_Line :> {Hue[0.6, 0.2, 0.8], Tube[l[[1]], .06]}, 
   Point[x_] :> {Hue[.6, .6, 1], Sphere[x, .2]}}

A variant that adds vertex labels:

ClearAll[toroidalGrid2]

toroidalGrid2[n_, m_, a_: 1, b_: 3][opts___ : OptionsPattern[]] := 
 Module[{sd = 0.001 + Range[0, 2 Pi - 2 Pi/#, 2 Pi/#] & /@ {n, m}}, 
  Show[ParametricPlot3D[torus[t, v, a, b], {v, 0, 2 Pi}, {t, 0, 2 Pi},
     Mesh -> sd, PlotStyle -> None, opts, 
    MeshStyle -> Directive[Hue[0.6, 0.2, 0.8], Thick], Axes -> False, 
    Boxed -> False, ImageSize -> Medium, PlotRangePadding -> Scaled[.2]], 
   Graphics3D[GraphicsComplex[torus[#2, #, a, b] & @@@ Tuples[sd],
      {Text[##] & @@@ Transpose[{Join @@ Transpose@Partition[Range[n m], n], 
         Range[n m]}], Hue[.6, .6, 1], Sphere[#, .35] & /@ Range[n m]}]]]]

Examples:

Grid @ Transpose @
  ({GridGraph[{##}, VertexLabels -> Placed["Name", Center], VertexSize -> .3], 
    toroidalGrid2[##][Method -> {"ShrinkWrap" -> True}]} & @@@ 
  {{2, 2}, {3, 3}, {3, 5}, {4, 3}})

Answer 3

You could set up coordinates manually:

rings = Range @@@ Most[Transpose[{vortexD, vortexU - 1}]];
coords = Table[{4 + (3 + Cos[v]) Sin[u], 4 + (3 + Cos[v]) Cos[u], 
  4 + Sin[v]}, {u, 0, 2 Pi, 2 Pi/(Length[rings] - 1)}, {v, 0, 2 Pi, 
  2 Pi/(Length[rings[[1]]] - 1)}];

Graph[Fold[VertexContract[#1, #2] &, Graph[ha], 
  Join[Transpose[{vortexR, vortexL}], Transpose[{vortexD, vortexU}]]],
  VertexCoordinates -> Thread[Flatten[rings] -> Flatten[coords, 1]]]