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

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

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*)
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.

• There is nothing wrong with your graph. It is simply how the default layout algorithm visualizes it. I am not sure which built-in layout algorithm would avoid this. If making it look like a torus in 3D is important to you, you may be better off setting the vertex coordinates manually. Commented May 14, 2020 at 7:12

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.

• Thank you @TumbiSapichu for the answer. I need a periodic boundary condition for an approximant lattice in quasicrystal. Therefore I think I have to write my lattice and its periodicity. However, I install the package, and I found the crossing of the link in your square lattice case. Therefore, I can conclude this the problem of Mathematica Graph3D. I also use Euler characteristics to distinguish the torus. It gives the correct answer; however, I can not yet distinguish it from other geometry. Commented May 14, 2020 at 6:07
• I see. I'm not sure what's the deal with the 'crosslinks', I thought you just needed the lattice data (which is easier in IGraphM anyway), but really you are concerned about the 'correct' visualization, right? You could add this information to your question :) Commented May 14, 2020 at 6:16
• Thank you @TumbiSapichu, I add your suggestion at the end of my question. Commented May 14, 2020 at 6:21

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


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