5
$\begingroup$

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

enter image description here

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,

enter image description here

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]

enter image description here

and

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

where gives,

enter image description here

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

enter image description here

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.

$\endgroup$
  • 1
    $\begingroup$ 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. $\endgroup$ – Szabolcs May 14 at 7:12
7
$\begingroup$

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

enter image description here

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

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

enter image description here

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

| improve this answer | |
$\endgroup$
  • $\begingroup$ 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. $\endgroup$ – Rasoul-Ghadimi May 14 at 6:07
  • $\begingroup$ 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 :) $\endgroup$ – TumbiSapichu May 14 at 6:16
  • $\begingroup$ Thank you @TumbiSapichu, I add your suggestion at the end of my question. $\endgroup$ – Rasoul-Ghadimi May 14 at 6:21
5
$\begingroup$

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

enter image description here

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

enter image description here

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

enter image description here

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

enter image description here

| improve this answer | |
$\endgroup$
3
$\begingroup$

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

enter image description here

| improve this answer | |
$\endgroup$

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.